4
Data Control and Object Oriented Programming
4.1. Procedure Blocks
; = volume of a length len, radius rad cylinder
(define (cylinder-volume rad len)
(define pi (acos -1)) ; = 3.1416...
; = area of a radius r circle
(define (base-area r) (* pi (square r)))
; body of circle-volume
(* len (base-area rad)))
4.1.1. The Nesting Instinct
Improving Understandability
(define (max-avg exams)
(max (/ (apply + (cdar exams))
(length (cdar exams)))
(/ (apply + (cdadr exams))
(length (cdadr exams)))
(/ (apply + (cdaddr exams))
(length (cdaddr exams)))))
(define (max-avg exams)
(define exam1 (cdar exams))
(define exam2 (cdadr exams))
(define exam3 (cdaddr exams))
(define avg1 (/ (apply + exam1) (length exam1)))
(define avg2 (/ (apply + exam2) (length exam2)))
(define avg3 (/ (apply + exam3) (length exam3)))
(max avg1 avg2 avg3))
Improving Reliability
; = (|x - y| <= delta)
(define (close? x y)
(<= (dist x y) delta))
(define delta 100)
(define (close? x y)
(define delta 1e-20)
(<= (dist x y) delta))
(define delta 100)
; = (+ n ... 0)
(define (triangle n)
(if (natural? n)
(unsafe-triangle n)
(error "bad input" triangle n)))
(define (triangle n)
; local definition
(define (unsafe-triangle n)
(if (zero? n)
0
(+ n (unsafe-triangle (- n 1)))))
; body of triangle
(if (natural? n)
(unsafe-triangle n)
(error "bad input" triangle n)))
Improving Efficiency
(define (mean scores)
(if (distribution? scores)
(/ (apply + scores) (length scores))
(error "bad input" mean scores)))
(define (distribution? val)
(and (list? val)
(all? real? val)
(not (null? val))))
(define (std-dev scores)
(if (distribution? scores)
(sqrt (variance scores))
(error "bad input" std-dev scores)))
(define (deviation score)
(- score (mean scores)))
(define (variance scores)
(define (deviation score)
(- score (mean scores)))
(define deviations (map deviation scores))
(mean (map square deviations)))
(define (variance scores)
(define mu (mean scores))
(define (deviation score) (- score mu))
(define deviations (map deviation scores))
(mean (map square deviations)))
(define (variance scores)
(define mu (mean scores))
(define (deviation^2 score) (square (- score mu)))
(mean (map deviation^2 scores)))
4.2. The Environment Model of Eager Evaluation
4.2.1. Bindings
4.2.2. Environments
4.2.3. Static versus Dynamic Scope Rules
(define (close? x y)
(<= (dist x y) delta))
(define delta 1e-20)
(define (small? delta) (close? delta 0))
4.3. Abstract Data Types
4.3.1. Example : The CARD ADT
(define card1 '(ace . heart))
(define card2 '(king . club))
(define card3 '(three . spade))
(define (make-card rank suit) (cons rank suit))
(define ranks
'(ace two three four five six seven eight nine ten
jack queen king))
(define suits '(spade club diamond heart))
(define (make-card rank suit)
(if (and (member? rank ranks) (member? suit suits))
(cons rank suit)
(error "bad input(s)" make-card rank suit)))
(define (rank card) (car card))
(define (suit card) (cdr card))
(define rank car)
(define suit cdr)
(define spade 'spade)
(define heart 'heart)
(define diamond 'diamond)
(define club 'club)
(define ace 'ace)
(define two 'two)
;etc.
(define queen 'queen)
(define king 'king)
(define card1 (make-card ace spade))
(define card2 (make-card jack diamond))
(define (spade? card)
(eq? spade (suit card)))
(define (ace? card)
(eq? ace (rank card)))
Using the CARD ADT
; = list of all cards of input suit
(define (make-suit suit) ???)
; = (rank . suit)
(define (make-card-of-suit rank)
(make-card rank suit)) ; suit is non-local
; = list of all cards of suit input
(define (make-suit suit)
; local, hence in the scope of suit
(define (make-card-of-suit rank)
(make-card rank suit))
(map make-card-of-suit ranks))
(define spades (make-suit spade))
(define hearts (make-suit heart))
(define diamonds (make-suit diamond))
(define clubs (make-suit club))
(define deck (append spades hearts clubs diamonds))
(define (pick-a-card cards)
(list-ref cards (random (length cards))))
4.3.2. Information Hiding and Data Abstraction
4.3.3. Example: The POINT ADT
POINT ::= #(REAL REAL REAL)
(define (point? val)
(and (vector? val)
(= (vector-length val) 3)
(and (real? (vector-ref val 0))
(real? (vector-ref val 1))
(real? (vector-ref val 2))
(define (xc point)
(if (point? point)
(vector-ref point 0)
(error "bad input" xc point)))
(define make-point vector)
(define (make-point xc yc zc)
(if (and (real? xc) (real? yc) (real? zc))
(vector xc yc zc)
(error "bad input(s)" make-point xc yc zc)))
(define (point+ point1 point2)
(if (and (point? p1) (point? p2))
(make-point
(+ (xc point1) (xc point2))
(+ (yc point1) (yc point2))
(+ (zc point1) (zc point2)))
(error "bad input(s)" point+ point1 point2)))
(define (scalar* num point)
(if (and (real? num) (point? point))
(make-point
(* num (xc point))
(* num (yc point))
(* num (zc point)))
(error "bad input(s)" scalar* num point)))
(define (point- point1 point2)
(point+ point1 (scalar* -1 vector2)))
(define (point* point1 point2)
(if (and (point? point1) (point? point2))
(+ (* (xc point1) (xc point2))
(* (yc point1) (yc point2))
(* (zc point1) (zc point2)))
(error "bad input(s)" point* point1 point2)))
(define (point-dist point1 point2)
(sqrt (point* (point- point1 point2)
(point- point1 point2))))
4.4. Overloading
7.1
; = reverse of string, vector, list, or pair input
(define (val-reverse val)
(cond ((list? val) (reverse val))
((string? val)
(list->string
(reverse (string->list val))))
((vector? val)
(list->vector
(reverse (vector->list val))))
((pair? val) (cons (cdr val) (car val)))
(else val)))
; = #t if val1 < val2, val1 & val2 any ordinals
(define (ord<? val1 val2)
(cond
((and (real? val1) (real? val2))
(< val1 val2))
((and (string? val1) (string? val2))
(string<? val1 val2))
((and (char? val1) (char? val2))
(char<? val1 val2))
(else (error "bad input(s)" ord<? val1 val2))))
4.5. Domains as Data
(define number-type 'number)
(define char-type 'char)
(define boole-type 'boole)
(define port-type 'port)
(define string-type 'string)
(define procedure-type 'procedure)
(define vector-type 'vector)
(define list-type 'list)
(define pair-type 'pair)
(define symbol-type 'symbol)
(define value-type 'value) ; the universal type
(define (get-type val)
(cond ((symbol? val) symbol-type)
((number? val) number-type)
((string? val) string-type)
((procedure? val) procedure-type)
((vector? val) vector-type)
((char? val) char-type)
((boolean? val) boole-type)
((list? val) list-type)
((pair? val) pair-type)
(else value-type)))
4.5.1. Programmer-defined Types
(define (make-type-tag texp) (cons 'type texp))
; = #t if val is type tagged
(define (typed? val)
(and (pair? val)
(pair? (car val))
(eq? (caar val) 'type)))
; = ((type . texp) . untyped-val)
(define (put-type texp untyped-val)
(if (typed? val)
(cons (make-type-tag texp)
(rem-type untyped-val)) ; switch
(cons (make-type-tag texp) untyped-val)))
; = val, where typed-val = ((type . texp) . val)
(define (rem-type typed-val)
(if (typed? val)
(cdr typed-val)
typed-val)) ; no type to remove
; = type of user or system typed val
(define (type val)
(if (typed? val)
(cdar val) ; = texp of ((type . texp) . xxx)
(get-type val))
(define (type=? texp1 texp2)
(equal? texp1 texp2)) ; structural type equivalence
4.5.2. Example: Complex Numbers
(define rectangular-type 'rectangular)
(define polar-type 'polar)
; = ((type . rectangular) . (rp . ip))
(define (make-rectangular rp ip)
(if (and (real? rp) (real? ip))
(put-type rectangular-type (cons rp ip))
(error "bad input(s)" make-rectangular rp ip)))
; = ((type . polar) . (mag . ang))
(define (make-polar mag ang)
(if (and (real? mag) (real? ang))
(put-type polar-type (cons mag ang))
(error "bad input(s)" make-polar mag ang)))
(define (polar? val)
(type=? (type val) polar-type))
(define (rectangular? val)
(type=? (type val) rectangular-type))
(define (complex? val)
(or (polar? val) (rectangular? val) (real? val)))
(define (real-part z)
; z' = untyped z
(define z' (rem-type z)) ; works even if z is real!
(cond ((rectangular? z) (car z'))
((polar? z) (* (car z') (cos (cdr z'))))
((real? z) z)
(else (error "bad input" real-part z))))
(define (rectangular->polar z)
(if (rectangular? z)
(put-type polar-type (rem-type z))
(error "bad input to rectangular->polar: " z)))
(define (rectangular->polar z)
(if (rectangular? z)
(make-polar (magnitude z) (angle z))
(error "bad input" rectangular->polar z)))
(define (polar->rectangular z) ???)
; = "a+bi", suitable for printing
(define (complex->string z)
(if (complex? z)
(string-append
(number->string (real-part z))
"+"
(number->string (imag-part z))
"i")
(error "bad input" complex->string z)))
; = z1 + z2
(define (complex+ z1 z2)
(if (and (complex? z1) (complex? z2))
(make-rectangular
(+ (real-part z1) (real-part z2))
(+ (imag-part z1) (imag-part z2)))
(error "bad input(s)" complex+ z1 z2)))
; = z1 * z2
(define (complex* z1 z2)
(if (and (complex? z1) (complex? z2))
(make-polar
(* (magnitude z1) (magnitude z2))
(+ (angle z1) (angle z2)))
(error "bad input(s)" complex* z1 z2)))
4.6. Data Driven Programming
(define (make-point xc yc zc)
; define message dispatcher
(define (self msg)
(case msg
((xc) xc)
((yc) yc)
((zc) zc)
((type) 'point)
(else (error msg-err self msg)))
(if (and (real? xc) (real? yc) (real? zc))
self ; return dispatcher!
(error "bad input(s) make-point xc yc zc)))
(define msg-err "unrecognized message")
(define p1 (make-point 7 2 9))
(define (xc point)
(if (point? val)
(point 'xc)
(error "bad input" xc point)))
(define (point? val)
(and (procedure? val)
(eq? 'point (val 'type))))
(define p2 (point+ p1 p1))
(define (display-point point)
(writeln "(" (xc point) (yc point) (zc point) ")"))
Appendices
Appendix 4.1. Object Oriented Programming
Objects and Classes
Inheritance
SOOE: A Simple Object Oriented Extension of Scheme
(define (make-xxx ...)
(define parent (make-yyy ...))
; methods and data go here
(define (self . msg)
(case (car msg)
; message handling goes here
((parent) parent)
((class) 'xxx)
(else (delegate parent msg))))
self)
; some pre-defined messages:
(define parent 'parent)
(define class 'class)
(define delegate apply)
(define (send object . msg)
(apply object msg))
(define (base-object . msg)
(case (car msg)
((parent) base-object)
((class) 'base-class)
(else
(error "unrecognized message"
'base-object
msg)))))
Example:
The Employee Class
(define (make-employee name ssn)
; data members
(define parent base-object)
(define salary 0)
; method members
(define (display-method)
(writeln "Name:" #\tab name)
(writeln "SSN:" #\tab ssn)
(writeln "Salary:" #\tab salary))
(define (set-salary amt)
(set! salary amt))
(define (self . msg)
(case (car msg)
((get-salary) salary)
((get-name) name)
((get-ssn) ssn)
((display print write show) (display-method))
((set-salary) (set-salary (cadr msg)))
((parent) parent)
((class) 'Employee)
(else (delegate parent msg))))
self)
(send smith 'set-salary 90000)
The Secretary Class
(define (make-secretary name ssn speed)
(define parent (make-employee name ssn))
(define (display-method)
(send parent print)
(writeln "Position: " #\tab 'secretary)
(writeln "WPM: " #\tab speed))
(define (self . msg)
(case (car msg)
((get-wpm) speed)
((display print write show) (display-method))
((parent) parent)
((class get-position) 'Secretary)
(else (delegate parent msg))))
self)
(define jones
(make-secretary "Jim Jones" 111223333 60))
The Manager Class
(define (make-manager name ssn)
(define parent (make-employee name ssn))
(define secretary base-object) ; for now
(define (display-method)
(define sec (send secretary 'get-name))
(send parent print)
(writeln "Position: " #\tab 'manager)
(writeln "Secretary: " #\tab sec))
(define (set-secretary sec)
(set! secretary sec))
(define (self . msg)
(case (car msg)
((get-secretary) secretary)
((set-secretary) (set-secretary (cadr msg)))
((display print write) (display-method))
((parent) parent)
((class get-position) 'manager)
(else (delegate parent msg))))
self)
Virtual Procedures
; staff = a list of employees
(define (print-staff staff)
(define (virtual-print employee)
(send employee 'print))
(map virtual-print staff))
(define wong (make-manager ...))
(define jones (make-secretary ...))
(define morris (make-programmer ... ))
(define team (list wong jones morris))
Appendix 4.2. Expression Blocks
Applications of Expression Blocks
(define (variance scores)
(if (distribution? scores)
(begin
(define mu (mean scores)) ; NO!
(define (deviation^2 score) ; NO!
(square (- score mu)))
(mean (map deviation^2 scores)))
(error "bad input" variance scores)))
(define (variance scores)
(define (unsafe-variance scores) ...)
(if (distribution? scores)
(unsafe-variance scores)
(error "bad input" variance scores)))
(define (variance scores)
(if (distribution? scores)
(let* ((mu (mean scores))
(deviation^2
(lambda (score)
(square (- score mu)))))
(mean (map deviation^2 scores)))
(error "bad input" variance scores)))
Problems