;;; This was the functional version we ended up with:

(define MAKE-ACCOUNT
  (lambda [balance]
    (let [[account (cell balance)]]
      (letrec [[WITHDRAW-FUN
                  (lambda [amount]
                     (if (< (contents account) amount)
                         "Insufficient funds"
                         (update account
                                 (- (contents account) amount))))]
               [DEPOSIT-FUN
                  (lambda [amount]
                     (update account (+ (contents account) amount)))]
               [CURRENT-BALANCE-FUN
                  (lambda [] (contents account))]]
       (lambda [message]
          (cond [(= message 'withdraw) withdraw-fun]
                [(= message 'deposit) deposit-fun]
                [(= message 'current-balance) current-balance-fun]
                [$T (error "unknown message" message)]))))))

(define WITHDRAW
   (lambda [account amount]
      ((account 'withdraw) amount)))

(define DEPOSIT
   (lambda [account amount]
      ((account 'deposit) amount)))

(define CURRENT-BALANCE
   (lambda [account]
      ((account 'current-balance))))

;;; Define a new OBJECT macro, *to replace LAMBDA*, so as
;;; to wrap this all together.  This would allow:

(define CELL
   (object [contents]
      [UPDATE (lambda [new-contents]
                 (set contents new-contents))]
      [CONTENTS (lambda [] contents)]))

(define ACCOUNT
   (object [balance]
      [WITHDRAW (lambda [amount]
                   (if (< balance amount)
                       "Insufficient funds"
                       (set balance (- balance amount))))]
      [DEPOSIT (lambda [amount]
                  (set balance (+ balance amount)))]
      [CURRENT-BALANCE (lambda [] balance)]))

(define FAMILY
   (object [mother father kids]
      [MOTHER (lambda [] mother)]
      [FATHER (lambda [] father)]
      [KIDS (lambda [] kids)]
      [NEW-KID (lambda [kid] (set kids (cons kid kids)))]))

;;; Given this machinery, lets define a new kind of rail, to be
;;; called a mutable rail or M-RAIL, in which you can replaced
;;; any element or tail.

(define M-CONS
   (object [element tail]
      [M-RAIL (lambda [] $true)]
      [M-FIRST (lambda [] element)]
      [M-REST (lambda [] tail)]
      [NEW-FIRST (lambda [new-element] (set element new-element))]
      [NEW-REST (lambda [new-tail] (set tail new-tail))]
      [M-NULL (lambda [] $false)]
      [M-LENGTH (lambda [] (+ 1 (m-length tail)))]))

(define EMPTY-M-RAIL
   (object []
      [M-RAIL (lambda [] $true)]
      [M-FIRST (lambda [] (error "empty m-rail" '?))]
      [M-REST (lambda [] (error "empty m-rail" '?))]
      [NEW-FIRST (lambda [new-element] (error "empty m-rail" '?))]
      [NEW-REST (lambda [new-tail] (error "empty m-rail" '?))]
      [M-NULL (lambda [] $true)]
      [M-LENGTH (lambda [] 0)]))

;;; These are hard to see; define M-EXTERNALISE:
;;;

(define M-CONS
   (object [element tail]
      [M-RAIL (lambda [] $true)]
      [M-FIRST (lambda [] element)]
      [M-REST (lambda [] tail)]
      [NEW-FIRST (lambda [new-element] (set element new-element))]
      [NEW-REST (lambda [new-tail] (set tail new-tail))]
      [M-NULL (lambda [] $false)]
      [M-LENGTH (lambda [] (+ 1 (m-length tail)))]
      [M-EXTERNALIZE (lambda []
                        (let [[rs (m-externalize tail)]]
                           (string-append
                               "<"
                               (externalize ↑element)
                               (if (m-null tail) "" " ")
                               (substring 2 (string-length rs) rs))))]))

(define EMPTY-M-RAIL
   (object []
      [M-RAIL (lambda [] $true)]
      [M-FIRST (lambda [] (error "empty m-rail" '?))]
      [M-REST (lambda [] (error "empty m-rail" '?))]
      [NEW-FIRST (lambda [new-element] (error "empty m-rail" '?))]
      [NEW-REST (lambda [new-tail] (error "empty m-rail" '?))]
      [M-NULL (lambda [] $true)]
      [M-LENGTH (lambda [] 0)]
      [M-EXTERNALIZE (lambda [] "<>")])) 


;;; This is all fine, but there is another abstraction we need:
;;; Define it so that the SAME length, first, rest, etc., work on
;;; all of these various data types.

;;; Can't be done with FIRST, REST, etc., because these are primitive
;;; functions, and 3-LISP isn't set up to do this.  But the principle
;;; isn't hard.  Note already that M-FIRST is defined over both empty
;;; and non-empty m-rails; it happens to work because it is a message
;;; for both of them.  So we could define something like:

(define REST!
   (lambda [arg]
      (cond [(rail arg) (rest arg)]
            [(sequence arg) (rest arg)]
            [(string arg) (substring 2 (string-length arg) arg)]
            [(m-rail arg) (m-rest arg)]
            [$T (error "type error for rest" ↑arg)])))

;;; But you could imagine that *everything* would be an "object" of
;;; this sort, and that therefore this last sort of definition wouldn't
;;; be required.

;;; One final detail: hierarchies of types.

;;;  ===============================================================

;;; Put the following stuff into an appendix, because it is hard:
;;;

(define DEFINE-MESSAGE
   (mlambda [call]
      '(define ,(arg 1 call)
          (lambda args
             (((first args) ,↑(arg 1 call)) . (rest args))))))

;;; OBJECT:
;;; 
;;; General form:
;;; 
;;;  (object [state-var-1 ... state-var-k]
;;;     [<mess1> <fun1>]
;;;     [<mess2> <fun2>]
;;;        ...
;;;     [<messk> <funk>])

(define OBJECT
   (mlambda [call]
      (letseq [[state-vars (arg 1 call)]
               [pairs (rest (pargs call))]
               [fun-names (map (lambda [pair] (acons)) pairs)]]
         '(begin
             ,(map (lambda [pair]
                      '(define-message ,(first pair)))
                   pairs)
             (lambda ,state-vars
                (letrec ,(map (lambda [pair fun-name]
                                 '[,fun-name ,(second pair)])
                              pairs
                              fun-names)
                    (lambda [message]
                       (cond . ,(map (lambda [pair fun-name]
                                        '[(= message ,↑(first pair))
                                          ,fun-name])
                                     pairs
                                     fun-names)))))))))