;;; Dealt with simple data abstraction, got into more complexity than
;;; was perhaps clear with the Geography example.  Go back and do some
;;; more simple stuff.  Will involve us with the representation of 
;;; state, generic (Polymorphic) operators, and message-passing.

;;; Simple version:

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

;;; More complexity: error messages, $10 fine for insufficient funds:

(let [[balance 0]]
   (define WITHDRAW
      (lambda [amount]
         (if (< balance amount)
             (let [[old-balance balance]
                   [cr-string (string-cons cr "")]]
                (begin (set balance (max 0 (- balance 10)))
                       (string-append
                          "Insufficient funds; $10 fine"
                          cr-string
                          "   Previous balance: $"
                          (externalize ^old-balance)
                          cr-string
                          "   Requested withdrawal: $"
                          (externalize ^amount)
                          cr-string
                          "   New balance: $"
                          (externalize ^balance))))
             (begin (set balance (- balance amount))
                    balance))))
   (define DEPOSIT
      (lambda [amount]
         (set balance (+ balance amount))))
   (define CURRENT-BALANCE
      (lambda [] balance)))

;;; But wont' worry about such complexities here.

;;; But the problem here is that there is only one account.
;;; Clearly want lots of accounts.  Define MAKE-ACCOUNT of
;;; an initial balance:

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

;;; But this redefines WITHDRAW, DEPOSIT, etc., every time a new
;;; account is made, thereby losing the ability to refer to any
;;; previous account.  Solution:

(define MAKE-ACCOUNT
  (lambda [balance]
    (letrec [[WITHDRAW-FUN
                (lambda [amount]
                   (if (< balance amount)
                       "Insufficient funds"
                       (begin (set balance (- balance amount))
                              balance)))]
             [DEPOSIT-FUN
                (lambda [amount]
                   (set balance (+ balance amount)))]
             [CURRENT-BALANCE-FUN
                (lambda [] balance)]]
       (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))))

;;; Note don't need initial-balance; can just use the local variable
;;; balance.


;;; This works fine, but it can be improved in terms of modularity 
;;; and abstraction:

;;; First, define a CELL, over which CONTENTS and UPDATE are defined.
;;; Very much like "balance":

(define CELL
  (lambda [contents]
    (letrec [[UPDATE-FUN (lambda [new-contents]
                            (set contents new-contents))]
             [CONTENTS-FUN (lambda [] contents)]]
       (lambda [message]
          (cond [(= message 'contents) contents-fun]
                [(= message 'update) update-fun]
                [$T (error "unknown message" message)])))))

(define UPDATE
   (lambda [cell new-contents]
      ((cell 'update) new-contents)))

(define CONTENTS
   (lambda [cell]
      ((cell 'contents))))
 
;;; Can now define ACCOUNT in terms of CELLS, although it is a more
;;; complex definition to read (but it localizes the definitions of
;;; CELLS in a single place, which is good):

(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))))

;;; But more interesting is to abstract the "message-passing" 
;;; routines.  The definitions of WITHDRAW, DEPOSIT, CURRENT-BALANCE,
;;; etc., are all very much the same.

;;; First, define a "send-message" facility:

(define =>
   (lambda args
      (if (< (length args) 2)
          (error "Too few arguments to =>" ^args)
          (((first args) (second args)) . (tail 2 args)))))

;;; It would also be nice to have something like the following:

(define DEFINE-MESSAGE
   (lambda [message]
      (define <message>
         (lambda args
            (((first args) message) . (rest args))))

;;; Problem is with the <message> part; should be quoted.  As it
;;; happens, we can define this with a macro, which I won't explain
;;; (the code is given in the appendix).  Can then define CELLS
;;; as follows:

(define CELL
  (lambda [contents]
    (letrec [[UPDATE-FUN (lambda [new-contents]
                            (set contents new-contents))]
             [CONTENTS-FUN (lambda [] contents)]]
       (lambda [message]
          (cond [(= message 'contents) contents-fun]
                [(= message 'update) update-fun]
                [$T (error "unknown message" message)])))))

(define-message UPDATE)
(define-message CONTENTS)

;;; Even more seriously, can define a new OBJECT macro, so as
;;; to wrap all of this into one!  This would allow:

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

(define-object MAKE-ACCOUNT
   (lambda [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-object FAMILY
   (lambda [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-object M-CONS
   (lambda [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-object EMPTY-M-RAIL
   (lambda []
      [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-object M-CONS
   (lambda [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-object EMPTY-M-RAIL
   (lambda []
      [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)]
            [(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
;;;     [<mess1> <fun1>]
;;;     [<mess2> <fun2>]
;;;        ...
;;;     [<messk> <funk>])

(define OBJECT
   (mlambda [call]
      (letseq [[pairs (pargs call)]
               [fun-names (map (lambda [pair] (acons)) pairs)]]
         '(begin
             ,(map (lambda [pair]
                      '(define-message ,(first pair)))
                   pairs)
             (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))))))))


(define DEFINE-OBJECT
   (mlambda [call]
      (let [[name (arg 1 call)]
            [variables (arg 1 (arg 2 call))]
            [pairs (rest (pargs (arg 2 call)))]]
         (let [[fun-names (map (lambda [pair] (acons)) pairs)]]
            '(begin
               (define ,name
                 (lambda ,variables
                    (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))))))
               ,(map (lambda [pair]
                       '(define-message ,(first pair)))
                     pairs)
               ,^name)))))