;;; @Package     Protobj
;;; @Subtitle    Prototype-Delegation Object Model in Scheme
;;; @HomePage    http://www.neilvandyke.org/protobj/
;;; @Author      Neil W. Van Dyke
;;; @AuthorEmail neil@@neilvandyke.org
;;; @Version     0.1
;;; @Date        5 January 2005

;;; @legal
;;; Copyright @copyright{} 2005 Neil W. Van Dyke.  This program is Free
;;; Software; you can redistribute it and/or modify it under the terms of the
;;; GNU Lesser General Public License as published by the Free Software
;;; Foundation; either version 2.1 of the License, or (at your option) any
;;; later version.  This program is distributed in the hope that it will be
;;; useful, but without any warranty; without even the implied warranty of
;;; merchantability or fitness for a particular purpose.  See the GNU Lesser
;;; General Public License [LGPL] for details.  For other license options and
;;; commercial consulting, contact the author.
;;; @end legal

;; (require (lib "9.ss" "srfi"))

(module protobj (object? object-parent object-set! object-get object-apply
			 object-apply/noslot-thunk
			 object-raw-clone/no-slots-copy
			 object-raw-clone/copy-immed-slots
			 object-raw-clone/copy-all-slots
			 current-root-object
			 ^ ! ? %
			 @)

  (import scheme chicken)

(define-syntax protobj-internal:testeez
  (syntax-rules () ((_ x ...)
                    (error "Tests disabled.")
		    ;;(testeez x ...)
                    )))

;;; @section Introduction

;;; Protobj is a Scheme library that implements a simple prototype-delegation
;;; object model, somewhat similar to that of [Self], and also related to
;;; [SLIB-Object] and [OScheme].  Protobj was written mainly as a
;;; @code{syntax-rules} learning exercise, but also because people ask about
;;; prototype object models for Scheme from time to time.  Like most object
;;; systems, it should be regarded as an amusement.  Protobj library defines
;;; both a verbose set of procedures, and terse special syntax.
;;;
;;; Protobj is based on objects with named slots that can contain arbitrary
;;; values.  Object have immediate slots, and single parent objects from which
;;; additional slots are inherited.  When setting in a child object a slot
;;; inherited from the parent, a new immediate slot is created in the child so
;;; that the parent is unaffected and the slot is no longer inherited.
;;;
;;; Methods are simply closures stored in slots.  When a method is applied, the
;;; first term of the closure is the receiver object.  Unlike Self, getting
;;; getting the contents of the slot is distinguished from invoking a method
;;; contained in the slot.  This distinction was made due to the way
;;; first-class closures are often used in Scheme.
;;;
;;; An object is cloned by invoking the @code{clone} method.  The default root
;;; object's @code{clone} method creates a new child object without any
;;; immediate slots, rather than copying any slots.  This behavior can be
;;; overridden to always copy certain slots, to copy immediate slots, or to
;;; copy all inherited slots.  An overriding @code{clone} method can be
;;; implemented to apply its parent's @code{clone} method to itself and then
;;; set certain slots in the new child appropriately.
;;;
;;; Protobj requires R5RS, [SRFI-9], [SRFI-23], and [SRFI-39].

;;; @section Tour

;;; The following is a quick tour of Protobj using the terse special syntax.
;;;
;;; @enumerate
;;;
;;; @item
;;; Bind @code{a} to the new object that is created by cloning the default root
;;; object (@code{%} is special syntax for invoking the @code{clone} method):
;;; @lisp
;;; (define a (%))
;;; @end lisp
;;;
;;; @item
;;; Verify that @code{a} is an object and that @code{a}'s parent is the default
;;; root object:
;;; @lisp
;;; (object? a) @result{} #t
;;; (eq? (^ a) (current-root-object)) @result{} #t
;;; @end lisp
;;;
;;; @item
;;; Add to @code{a} a slot named @code{x} with value @code{1}:
;;; @lisp
;;; (! a x 1)
;;; @end lisp
;;;
;;; @item
;;; Get @code{a}'s slot @code{x}'s value:
;;; @lisp
;;; (? a x) @result{} 1
;;; @end lisp
;;; 
;;; @item
;;; Bind @code{b} to a clone of @code{a}:
;;; @lisp
;;; (define b (% a))
;;; @end lisp
;;; 
;;; @item
;;; Get @code{b}'s slot @code{x}'s value, which is inherited from @code{a}:
;;; @lisp
;;; (? b x) @result{} 1
;;; @end lisp
;;; 
;;; @item
;;; Set @code{a}'s slot @code{x}'s value to @code{42}, and observe that
;;; @code{b} inherits the new value:
;;; @lisp
;;; (! a x 42)
;;; (? a x) @result{} 42
;;; (? b x) @result{} 42
;;; @end lisp
;;; 
;;; @item
;;; Set @code{b}'s slot @code{x}'s value to @code{69}, and observe that @var{a}
;;; retains its own @code{x} value although @var{b}'s @code{x} value has been
;;; changed:
;;; @lisp
;;; (! b x 69)
;;; (? a x) @result{} 42
;;; (? b x) @result{} 69
;;; @end lisp
;;; 
;;; @item
;;; Add to @code{a} an @code{xplus} slot containing a closure that implements a
;;; method of the object:
;;; @lisp
;;; (! a xplus (lambda (self n) (+ (? self x) n)))
;;; @end lisp
;;; 
;;; @item
;;; Apply the method to the @code{a} and @code{b} objects (@code{b} inherits
;;; any new slots added to @code{a}):
;;; @lisp
;;; (@@ a xplus 7) @result{} 49
;;; (@@ b xplus 7) @result{} 76
;;; @end lisp
;;;
;;; @item
;;; Observe the shorthand syntax for applying methods to an object multiple
;;; times, with the syntax having the value of the lastmost application:
;;; @lisp
;;; (@@ a (xplus 1000) (xplus 7)) @result{} 49
;;; @end lisp
;;; 
;;; @item
;;; Bind to @var{c} an object that clones @var{a} and adds slot @var{y} with
;;; value @code{101}:
;;; @lisp
;;; (define c (% a (y 101)))
;;; @end lisp
;;; 
;;; @item
;;; Get the values of both the @code{x} and @code{y} slots of @code{c}:
;;; @lisp
;;; (? c x y) @result{} 42 101
;;; @end lisp
;;; 
;;; @item
;;; Finally, bind @code{d} to a clone of @code{a} that overrides @code{a}'s
;;; @code{x} slot:
;;; @lisp
;;; (define d (% a (x 1) (y 2) (z 3)))
;;; (? d x y z) @result{} 1 2 3
;;; @end lisp
;;;
;;; @end enumerate

;;; @section Basic Interface

;;; The basic interface of Protobj is a set of procedures.

(define-record-type object
  (protobj-internal:make-object parent slots)
  object?
  (parent object-parent          protobj-internal:set-parent!)
  (slots  protobj-internal:slots protobj-internal:set-slots!))

(define (protobj-internal:find-slot obj slot-symbol proc noslot-thunk)
  (let loop ((o obj))
    (cond ((assq slot-symbol (protobj-internal:slots o)) => proc)
          (else (cond ((object-parent o) => loop)
                      (else (noslot-thunk)))))))

;;; @defproc object? x
;;;
;;; Predicate for whether or not @var{x} is a Protobj object.

;; see define-record-type

;;; @defproc object-parent obj
;;;
;;; Yields the parent object of object @var{obj}.

;; see define-record-type

;; TODO: Expose a "set-object-parent!"?

;;; @defproc object-set! obj slot-symbol val
;;;
;;; Sets the slot identified by symbol @var{slot-symbol} in object @var{obj} to
;;; value @code{val}.

(define (object-set! obj slot-symbol val)
  (let ((slots (protobj-internal:slots obj)))
    (cond ((assq slot-symbol slots) => (lambda (slot) (set-cdr! slot val)))
          (else (protobj-internal:set-slots! obj (cons (cons slot-symbol val)
                                                       slots))))))

;;; @defproc object-get obj slot-symbol
;;;
;;; Yields the value of slot named by symbol @var{slot-symbol} in object
;;; @var{obj} (immediate or inherited).  If no slot of that name exists, an
;;; error is signaled.

(define (object-get obj slot-symbol)
  (protobj-internal:find-slot
   obj
   slot-symbol
   cdr
   (lambda () (error "Object has no such slot:" obj slot-symbol))))

;; (define (object-get/procs obj slot-symbol proc noslot-thunk)
;;   (protobj-internal:find-slot obj
;;                               slot-symbol
;;                               (lambda (slot) (proc (cdr slot)))
;;                               noslot-thunk))

;;; @defproc object-get obj slot-symbol noslot-thunk
;;;
;;; Yields the value of slot named by symbol @var{slot-symbol} in object
;;; @var{obj} (immediate or inherited), if any such slot exists.  If no slot of
;;; that name exists, then yields the value of applying closure
;;; @var{noslot-thunk}.

(define (object-get/noslot-thunk obj slot-symbol noslot-thunk)
  (protobj-internal:find-slot obj
                              slot-symbol
                              cdr
                              noslot-thunk))

;;; @defproc object-apply obj slot-symbol @{ arg @}*
;;;
;;; Applies the method (closure) in the slot named by@var{slot-symbol} of
;;; object @var{obj}.  The first term of the method is @var{obj}, and one or
;;; more @var{arg} are the remaining terms.  If no such slot exists, an error
;;; is signaled.

(define (object-apply obj slot-symbol . args)
  (apply (object-get obj slot-symbol) obj args))

;;; @defproc object-apply/noslot-thunk obj noslot-thunk slot-symbol @{ arg @}*
;;;
;;; Like @code{object-apply}, except that, if the slot does not exist, instead
;;; of signalling an error, the value is the result of applying
;;; @var{noslot-thunk}.

(define (object-apply/noslot-thunk obj slot-symbol noslot-thunk . args)
  (protobj-internal:find-slot obj
                              slot-symbol
                              (lambda (slot) (apply (cdr slot) obj args))
                              noslot-thunk))

;; TODO: Implement "object-apply/try", which calls a thunk (or is a no-op) if
;; no slot can be found.  Maybe special syntax for doing this apply/try to a
;; parent.  One of the things this might be most useful for is in a "clone"
;; method, to invoke any parent "clone" method within additional behavior.

;;; @defproc  object-raw-clone/no-slots-copy    obj
;;; @defprocx object-raw-clone/copy-immed-slots obj
;;; @defprocx object-raw-clone/copy-all-slots   obj
;;;
;;; These procedures implement different ways of cloning an object, and are
;;; generally bound as @code{clone} methods in root objects.
;;; @code{/no-slots-copy} does not copy any slots, @code{/copy-immed-slots}
;;; copes immediate slots, and @code{/copy-all-slots} copies all slots
;;; including inherited ones.

(define (object-raw-clone/no-slots-copy obj)
  (protobj-internal:make-object obj '()))

(define (object-raw-clone/copy-immed-slots obj)
  (protobj-internal:make-object obj
                                (map (lambda (pair)
                                       (cons (car pair) (cdr pair)))
                                     (protobj-internal:slots obj))))

(define (object-raw-clone/copy-all-slots obj)
  ;; Note: We could save a few "(assq X '())" calls by copying the immediate
  ;; slots first.
  (let loop-objs ((o    obj)
                  (seen '()))
    (if o
        (let loop-slots ((slots  (protobj-internal:slots o))
                         (result seen))
          (if (null? slots)
              (loop-objs (object-parent o) result)
              (loop-slots (cdr slots)
                          (let ((name (caar slots)))
                            (if (assq name seen)
                                result
                                (cons (cons name (cdar slots)) result))))))
        (protobj-internal:make-object obj seen))))

;; (define (object-clone obj)
;;   (object-apply obj 'clone))

;;; @defparam current-root-object
;;;
;;; Parameter for the default root object.  The initial value is a root object
;;; that has @code{object-raw-clone/no-slots-copy} in its @code{clone} slot.

;; TODO: Make this a parameter, or lose it altogether.

(define current-root-object
  (make-parameter
   (protobj-internal:make-object
    #f
    (list (cons 'clone object-raw-clone/no-slots-copy)))))

;;; @section Terse Syntax

;;; Since Protobj's raison d'etre was to play with syntax, here it is.  Note
;;; that slot names are never quoted.

;;; @defsyntax ^ obj
;;;
;;; Parent of @var{obj}.

(define-syntax ^ (syntax-rules () ((_ ?o) (object-parent ?o))))

;;; @defsyntax  ! obj slot val
;;; @defsyntaxx ! obj (slot val) ...
;;;
;;; Sets object @var{obj}'s slot @var{slot}'s value to @var{val}.  In the
;;; second form of this syntax, multiple slots of @var{obj} may be set at once,
;;; and are set in the order given.

(define-syntax !
  (syntax-rules ()
    ((_ ?o (?s0 ?v0) (?s1 ?v1) ...) (let ((o ?o))
                                      (! o ?s0 ?v0)
                                      (! o ?s1 ?v1) ...))
    ((_ ?o ?s ?v)                   (object-set! ?o (quote ?s) ?v))))

;;; @defsyntax ? obj @{ slot @}+
;;;
;;; Yields the values of the given @var{slot}s of @var{obj}.  If more than one
;;; @var{slot} is given, a multiple-value return is used.

(define-syntax ?
  (syntax-rules ()
    ((_ ?o ?s)     (object-get ?o (quote ?s)))
    ((_ ?o ?s ...) (let ((o ?o)) (values (? o ?s) ...)))))

;;; @defsyntax  @@ obj slot @{ arg @}*
;;; @defsyntaxx @@ obj @{ (slot @{ arg @}* ) @}+
;;;
;;; Applies @var{obj}'s @var{slot} method, with @var{obj} as the first term and
;;; @var{arg}s as the remaining terms.  In the second form of this syntax,
;;; multiple methods may be applied, and the value is the value of the last
;;; method application.

(define-syntax protobj-internal:apply*
  (syntax-rules ()
    ((_ (X0 X1 ...) S A0 ...) (let ((temp (X0 X1 ...)))
                                (protobj-internal:apply* temp S A0 ...)))
    ((_ OVAR        S A0 ...) ((object-get OVAR (quote S)) OVAR A0 ...))))

(define-syntax @
  (syntax-rules ()
    ((_ ?o (?s0 ?a0 ...) (?s1 ?a1 ...) ...)
     (let ((o ?o))
       (protobj-internal:apply* o ?s0 ?a0 ...)
       (protobj-internal:apply* o ?s1 ?a1 ...) ...))
    ((_ ?o ?s ?a ...)
     (protobj-internal:apply* ?o ?s ?a ...))))

;;; @defsyntax % [ obj @{ (slot val) @}* ]
;;;
;;; Clones object @var{obj}, binding any given @var{slot}s to respective given
;;; @var{val}s.

(define-syntax %
  (syntax-rules ()
    ((_)                            (% (current-root-object)))
    ((_ ?o)                         (@ ?o clone))
    ((_ ?o (?s0 ?v0) (?s1 ?v1) ...) (let ((o (% ?o)))
                                      (! o ?s0 ?v0)
                                      (! o ?s1 ?v1) ...
                                      o))))


;;; Extensions (by felix)

(define-record-printer (object x port)
  (@ x print port) )

(! (current-root-object) print
   (lambda (self #!optional (port (current-output-port)))
     (display "#<object>" port)))

)

;;; @section Tests

;;; The Protobj test suite can be enabled by editing the source code file and
;;; loading [Testeez]; the test suite is disabled by default.

#;(define (protobj-internal:test)
  (protobj-internal:testeez
   "Protobj"

   (test-define "Object \"a\""                     a (%))
   (test/equal  "\"a\" parent is root"  (eq? (^ a) (current-root-object)) #t)
   (test-eval   "Add to \"a\" slot \"x\" value 1"  (! a x 1))
   (test/equal  "\"a\" slot \"x\" is 1"            (? a x)                 1)
   (test-define "Object \"b\" clones \"a\""        b (% a))
   (test/equal  "\"b\" inherited slot \"x\" is 1"  (? b x)                 1)
   (test-eval   "Set \"a\" slot \"x\" to 42"       (! a x 42))
   (test/equal  "\"b\" slot \"x\" is now 42"       (? b x)                 42)
   (test-eval   "Set \"b\" slot \"x\" to 69"       (! b x 69))
   (test/equal  "\"b\" slot \"x\" is 69"           (? b x)                 69)
   (test/equal  "\"a\" slot \"x\" is still 42"     (? a x)                 42)

   (test-eval "Add to object \"a\" an \"xplus\" slot containing a method"
              (! a xplus (lambda (self n) (+ (? self x) n))))

   (test/equal "42 + 7 = 49" (@ a xplus 7) 49)
   (test/equal "69 + 7 = 76" (@ b xplus 7) 76)

   (test/equal "42 + 7 = 49" (@ a (xplus 1000) (xplus 7)) 49)

   (test-define "Object \"c\" clones \"a\", adds slot \"y\""
                c (% a (y 101)))
   (test/equal "\"c\" slot \"x\" is 42"  (? c x) 42)
   (test/equal "\"c\" slot \"y\" is 101" (? c y) 101)

   (test-define "Object \"d\" clones \"a\", adds slots"
                d (% a (x 1) (y 2) (z 3)))
   (test/equal "\"d\" slot \"x\" is 1"  (? d x) 1)
   (test/equal "\"d\" slot \"y\" is 2"  (? d y) 2)
   (test/equal "\"d\" slot \"z\" is 3"  (? d z) 3)

   (test/equal
    "Copying object-raw-clone functions"
    (let* ((o (% (% (% (current-root-object)
                       (a 1) (b 2) (c 3))
                    (b 4) (a 5) (d 6))
                 (e 7) (b 8) (c 9))))
      (list
       (protobj-internal:slots (object-raw-clone/copy-immed-slots o))
       (protobj-internal:slots (object-raw-clone/copy-all-slots   o))))
    `(((c . 9) (b . 8) (e . 7))
      ((clone . ,object-raw-clone/no-slots-copy)
       (a . 5) (d . 6) (e . 7) (b . 8) (c . 9))))

   ;; TODO: Add more tests.
   ))

;;; @unnumberedsec History

;;; @table @asis
;;;
;;; @item Version 0.1 --- 5 January 2005
;;; Initial release.
;;;
;;; @end table

;;; @unnumberedsec References

;;; @table @asis
;;;
;;; @item [LGPL]
;;; Free Software Foundation, ``GNU Lesser General Public License,'' Version
;;; 2.1, February 1999, 59 Temple Place, Suite 330, Boston, MA 02111-1307
;;; USA.@*
;;; @uref{http://www.gnu.org/copyleft/lesser.html}
;;;
;;; @item [OScheme]
;;; Anselm Baird-Smith, ``OScheme.''@*
;;; @uref{http://koala.ilog.fr/abaird/oscheme/om.html}
;;;
;;; @item [Self]
;;; David Ungar and Randall B. Smith, ``Self: The Power of Simplicity,''
;;; @i{Lisp and Symbolic Computation}, 4, 3, 1991.@*
;;; @uref{http://research.sun.com/self/papers/self-power.html}
;;;
;;; @item [SLIB-Object]
;;; Wade Humeniuk, ``Macroless Object System,'' SLIB @code{object}.@*
;;; @uref{http://swissnet.ai.mit.edu/~jaffer/slib_7.html#SEC180}
;;;
;;; @item [SRFI-9]
;;; Richard Kelsey, ``Defining Record Types,'' SRFI 9, 9 September 1999.@*
;;; @uref{http://srfi.schemers.org/srfi-9/srfi-9.html}
;;;
;;; @item [SRFI-23]
;;; Stephan Houben, ``Error reporting mechanism,'' SRFI 23, 26 April 2001.@*
;;; @uref{http://srfi.schemers.org/srfi-23/srfi-23.html}
;;;
;;; @item [SRFI-39]
;;; Marc Feeley, ``Parameter objects,'' SRFI 39, 30 June 2003.@*
;;; @uref{http://srfi.schemers.org/srfi-39/srfi-39.html}
;;;
;;; @item [Testeez]
;;; Neil W. Van Dyke, ``Testeez: Simple Test Mechanism for Scheme,'' Version
;;; 0.1.@*
;;; @uref{http://www.neilvandyke.org/testeez/}
;;;
;;; @end table