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