-
Notifications
You must be signed in to change notification settings - Fork 1
/
final.scm
129 lines (112 loc) · 3.92 KB
/
final.scm
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
(define (send message object . args)
(let ((method (method-lookup object message)))
(cond ((procedure? method) (apply method args))
((null? method) (error "send" "Message not understood: " message))
(else (error "send" "Inappropriate result of method lookup: " method)))))
(define (virtual-operations object)
(send 'set-self! object object))
(define (new-instance class . parameters)
(let ((instance (apply class parameters)))
(virtual-operations instance)
instance))
(define (new-part class . parameters)
(apply class parameters))
(define (method-lookup object selector)
(cond ((procedure? object) (object selector))
(else (error "method-lookup" "Inappropriate object in method-lookup: " object))))
(define (object)
(let ((super '())
(self 'nil))
(define (set-self! object-part)
(set! self object-part))
(define (self message)
(cond ((eqv? message 'set-self!) set-self!)
(else '())))
self))
(define (point x y)
(let ((super (new-part object))
(self 'nil)
(x x)
(y y))
(define (getx) x)
(define (gety) y)
(define (add p)
(point
(+ x (send 'getx p))
(+ y (send 'gety p))))
(define (type-of) 'point)
(define (set-self! object-part)
(set! self object-part)
(send 'set-self! super object-part))
(define (self message)
(cond ((eqv? message 'getx) getx)
((eqv? message 'gety) gety)
((eqv? message 'add) add)
((eqv? message 'type-of) type-of)
((eqv? message 'set-self!) set-self!)
(else (method-lookup super message))))
self))
(define (color-point x y color)
(let ((super (new-part point x y))
(self 'nil))
(let ((color color))
(define (get-color) color)
(define (type-of) 'color-point)
(define (set-self! object-part)
(set! self object-part)
(send 'set-self! super object-part))
(define (self message)
(cond ((eqv? message 'get-color) get-color)
((eqv? message 'type-of) type-of)
((eqv? message 'set-self!) set-self!)
(else (method-lookup super message))))
self)))
(define (x)
(let ((super (new-part object))
(self 'nil))
(let ((x-state 1))
(define (get-state) x-state)
(define (res)
(send 'get-state self))
(define (set-self! object-part)
(set! self object-part)
(send 'set-self! super object-part))
(define (self message)
(cond ((eqv? message 'get-state) get-state)
((eqv? message 'res) res)
((eqv? message 'set-self!) set-self!)
(else (method-lookup super message))))
self)))
(define (y)
(let ((super (new-part x))
(self 'nil))
(let ((y-state 2))
(define (get-state) y-state)
(define (set-self! object-part)
(set! self object-part)
(send 'set-self! super object-part))
(define (self message)
(cond ((eqv? message 'get-state) get-state)
((eqv? message 'set-self!) set-self!)
(else (method-lookup super message))))
self)))
(define a (new-instance x))
(define b (new-instance y))
(format #t "a: ~a~%" (send 'res a))
(format #t "b: ~a~%" (send 'res b))
(define p (new-instance point 2 3))
(define q (new-instance point 4 5))
(define p+q (send 'add p q))
(format #t "p x: ~a y: ~a~%" (send 'getx p) (send 'gety p))
(format #t "p+q x: ~a y: ~a~%" (send 'getx p+q) (send 'gety p+q))
(define cp (new-instance color-point 5 6 'red))
(format #t "cp color: ~a x: ~a y: ~a~%"
(send 'get-color cp)
(send 'getx cp)
(send 'gety cp))
(define cp-1 (send 'add cp (new-instance color-point 1 2 'green)))
(format #t "cp-1 type: ~a x: ~a y: ~a~%"
(send 'type-of cp-1)
(send 'getx cp-1)
(send 'gety cp-1))
(format #t "cp-1 color: ~a~%" (send 'get-color cp-1)) ;; Error: "Message not understood: " get-color