blob: d1aa17434933ea5568a0491e2e2b20b6c52b5afb (
plain)
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
|
(define (to-string thing)
(let ([format-pair-tail
(lambda (tail)
(apply string-append (cond [(null? tail) (list "")]
[(pair? tail) (list " " (to-string tail))]
[else (list " . " (to-string tail))])))
])
(cond [(number? thing) (number->string thing)]
[(symbol? thing) (symbol->string thing)]
[(null? thing) "()"]
[(procedure? thing) "#function#"]
[(pair? thing) (string-append
(to-string (car thing))
(format-pair-tail (cdr thing)))]
[(string? thing) thing]
[else "?"]
)))
(define (create-dispatch methods not-found)
(lambda (msg)
(cdr (or (assoc msg methods) (not-found msg)))
))
(define (send obj msg . para)
(let ((method (obj msg)))
(apply method para)))
(define (new-instance class . para)
(apply class (cons #f para)))
;; TODO implement str
(define (object self)
(letrec ([whoami 'object]
[dispatch
(lambda (msg)
(let ([self (or self dispatch)])
(cond [(eq? msg 'pretty-str) (lambda () (to-string (send self 'pretty)))]
[(eq? msg 'pretty) (lambda () (list whoami))]
[(eq? msg 'type-of) (lambda () whoami)]
[(eq? msg 'class-of) (lambda () object)]
[else (errorf object "msg ~a not found" msg)])
))]) dispatch))
(define (point self x y)
(letrec ([whoami 'point]
[dispatch
(lambda (msg)
(let* ([self (or self dispatch)]
[super (object self)])
(cond [(eq? msg 'getx) (lambda () x)]
[(eq? msg 'gety) (lambda () y)]
[(eq? msg 'add) (lambda (other)
(new-instance (send self 'class-of)
(+ x (send other 'getx))
(+ y (send other 'gety))
))]
[(eq? msg 'pretty) (lambda () (list whoami x y))]
[(eq? msg 'move) (lambda (dx dy)
(send self 'add (new-instance point dx dy)))]
[(eq? msg 'type-of) (lambda () whoami)]
[(eq? msg 'class-of) (lambda () point)]
[(eq? msg 'with-color) (lambda (color)
(new-instance color-point
(send self 'getx)
(send self 'gety)
color))]
[else (super msg)])))]
) dispatch))
(define p1 (new-instance point 10 20))
(define p2 (new-instance point 1 1))
(define (color-point self x y . color)
(let ((color (if (null? color) 'green (car color))))
(letrec ([whoami 'color-point]
[dispatch
(lambda (msg)
(let* ([self (or self dispatch)]
[super (point self x y)])
(cond [(eq? msg 'get-color) (lambda () color)]
[(eq? msg 'type-of) (lambda () whoami)]
[(eq? msg 'pretty) (lambda ()
(list whoami
(send self 'getx)
(send self 'gety)
(send self 'get-color)))]
[(eq? msg 'class-of) (lambda () color-point)]
[else (super msg)])))]
) dispatch)))
;;# Exercise 3.7
;;? What is the value of the expression
(let ((x 1)
(y 2)
(z 3)
(v 5))
(cons x
(call/cc (lambda (e)
(cons y
(cons z
(if (even? v) v (e (+ v 1)))))))))
;; Okay lets start by looking at it:
;; Okay, we define x y z and v
;; Then we create a cons with x and the continuations, so the result must be
;; something like (1 . ???)
;; If v is even, it will do some cons stuff with the other guys, but it's not.
;; Therefore the result of (call/cc ...) is (e (+ v 1)) which is 6.
;; Therefore the result must be (1 . 6)
;; Okay when running it is (1 . 6).
;;# Exercise 3.4
;;? Program (lambda (a b c) (- (* b b) (* 4 a c))) in CPS
(define (sub a b k)
(k (- a b)))
(define (mult a b k)
(k (* a b)))
(define (dist a b c k)
(mult a c (lambda (v)
(mult 4 v (lambda (v1)
(mult b b (lambda (v2)
(sub v2 v1 k))))))))
(define dist-old (lambda (a b c) (- (* b b) (* 4 a c))))
|
