[plt-scheme] Steps Towards Stateless State - Commented

(define (append-symbol sym1 sym2)
  (let ((str1 (symbol->string sym1))
        (str2 (symbol->string sym2)))
    (string->symbol (string-append str1 str2))))
;used for constructing fully qualified method names

(define -self- car)
(define -state- cadr)
(define -arguments- caddr)
;used internally to methods

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (->object . st)
  (lambda (method-name . args)
    (apply (eval (append-symbol '->object method-name))
           (let ((self '->object)
                 (state (if (null? st)
                            (list)
                            st))
                 (arguments (car args)))
             (list self state arguments)))))
;this class def also constructs objects of type ->object

(define (->object:state . internals)
  (-state- internals))
;:state method returns the state variables of an object

(define (->object:display . internals)
  (cons (-self- internals) (-state- internals)))
;:display method is like :state method but prefixed with the appropriate class name

(define (->object:set . internals)
  (define (item-q state item)
    (if (null? state)
        #f
        (if (equal? (car state) (car item))
            (list (car state) (cadr state))
            (item-q (cddr state) item))))
  (define (remove-matching state item)
    (if (equal? (car state) (car item))
        (cddr state)
        (cons (car state)
              (cons (cadr state)
                    (remove-matching (cddr state) item)))))
  (define (add1 item state)
    (let ((found (item-q state item)))
      (if found
          (append item (remove-matching state item))
          (append item state))))
  (define (update state arguments)
    (if (null? arguments)
        state
        (update
         (add1 (list (car arguments) (cadr arguments)) state)
         (cddr arguments))))
  (let ((state (-state- internals))
        (arguments (-arguments- internals)))
    (apply ->object (update state arguments))))
;:set method returns a new object of the ->object class

(define (->object:datum . internals)
  (define (item-q state item)
    (if (null? state)
        #f
        (if (equal? (car state) (car item))
            (list (car state) (cadr state))
            (item-q (cddr state) item))))
  (let ((state (-state- internals))
        (arguments (-arguments- internals)))
    (let ((item (append arguments '(#f))))
      (cadr (item-q state item)))))
;:datum method returns a value from the internal state when given its associated
identifier
;very easy to add more methods without modification to the above code
;just add a boiler plate definition at the bottom for any new methods added to the system
;notice that because of message passing we get polymorphism automatically

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (->history . st)
  (lambda (method-name . args)
    (apply (eval (append-symbol '->history method-name))
           (let ((self '->history)
                 (state (if (null? st)
                            (list 'H= 0)
                            st))
                 (arguments (car args)))
             (list self state arguments)))))
;the ->history class is basically the same
;just substituted the new name and added a default state when constructed with no
arguments

(define ->history:state ->object:state)
;inherits method from ->object class

(define ->history:display ->object:display)
;inherits method from ->object class

(define (->history:set . internals)
  (let ((state (-state- internals))
        (arguments (-arguments- internals)))
    (apply ->history (:state (apply (apply ->object state) (list ':set arguments))))))
;need macros for generating method defs that produce new objects
;remember, these are stateless objects

(define ->history:datum ->object:datum)
;inherits method from ->object class
;another good reason for using macros

(define (->history:event . internals)
  (let ((state (-state- internals))
        (arguments (-arguments- internals)))
    (let* ((new (apply ->history state))
           (new (apply :set (list new 'H= (append arguments (:datum new 'H=))))))
      new)))
;add more methods if you like
;then just add the boiler plate

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (:state obj . args)
  (obj ':state args))

(define (:display obj . args)
  (obj ':display args))

(define (:set obj . args)
  (obj ':set args))

(define (:datum obj . args)
  (obj ':datum args))

(define (:event obj . args)
  (obj ':event args))
;this is the boiler plate which must be added for all new methods
;not very hard to add new classes if you want

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(let* ((h1 (->history))
       (h2 (->history 'H= 29))
       (h1 (:set h1 'H= 12))
       (h1 (:set h1 'H= 12 'Z= 30))
       (h2 (:event h2 13))
       (h1 (:event h1 27))
       (h1 (:event h1 5))
       (h2 (:event h2 8)))
  (list (:display h1) (:display h2)))
;all procedures can serialize effects in this way
;amazingly we have not used set! even once

;output:
;
;((->history H= (5 27 . 12) Z= 30) (->history H= (8 13 . 29)))

;Finally:
;
;my solution is not optimal because as was pointed out to me on this mailing list eval
does not play well with nesting
;I propose a solution would be to use a macro that adds explicit case statements
containing the the methods to be called
;as you can see the process I followed to derive a new class was quite mechanical in
nature so why don't we mechanize it?
;I would also like feedback on what I can do to improve efficiency (I will learn what I
need to make this work
;
;Feedback on usefulness for automated corectness proofs would be nice too.

Best,

-Zelah

____________________________________________________________
FREE 3D EARTH SCREENSAVER - Watch the Earth right on your desktop!
Check it out at http://www.inbox.com/earth