remise
This commit is contained in:
parent
0a286a00a6
commit
24434d5cf7
|
@ -0,0 +1,16 @@
|
||||||
|
(define (point x y)
|
||||||
|
(define (dispatch m)
|
||||||
|
(cond ((eq? m 'getx) x)
|
||||||
|
((eq? m 'gety) y)
|
||||||
|
((eq? m 'type) 'point)
|
||||||
|
((eq? m 'info) (list 'point x y))
|
||||||
|
(else (display (string-append "point as no method: " (symbol->string m) "\n")))))
|
||||||
|
dispatch)
|
||||||
|
(define p (point 1 2))
|
||||||
|
(p 'getx) ; 1
|
||||||
|
(p 'gety) ; 2
|
||||||
|
(p 'type) ; point
|
||||||
|
(p 'info) ; (point 1 2)
|
||||||
|
(p 'foo) ; display "point as no method: foo
|
||||||
|
|
||||||
|
|
|
@ -1,3 +1,10 @@
|
||||||
|
;Auhors:Dubois Brieuc, Dubois Simon
|
||||||
|
;Addapted from the example given in the assignment. Major change are:
|
||||||
|
; function directly defined in dispatch
|
||||||
|
; = changed to eq? to take symbol as input
|
||||||
|
; eror message added
|
||||||
|
|
||||||
|
;Class definition
|
||||||
(define (point x y)
|
(define (point x y)
|
||||||
(define (dispatch m)
|
(define (dispatch m)
|
||||||
(cond ((eq? m 'getx) x)
|
(cond ((eq? m 'getx) x)
|
||||||
|
@ -6,11 +13,13 @@
|
||||||
((eq? m 'info) (list 'point x y))
|
((eq? m 'info) (list 'point x y))
|
||||||
(else (display (string-append "point as no method: " (symbol->string m) "\n")))))
|
(else (display (string-append "point as no method: " (symbol->string m) "\n")))))
|
||||||
dispatch)
|
dispatch)
|
||||||
|
|
||||||
|
;Usage example
|
||||||
(define p (point 1 2))
|
(define p (point 1 2))
|
||||||
(p 'getx) ; 1
|
(p 'getx) ; 1
|
||||||
(p 'gety) ; 2
|
(p 'gety) ; 2
|
||||||
(p 'type) ; point
|
(p 'type) ; point
|
||||||
(p 'info) ; (point 1 2)
|
(p 'info) ; (point 1 2)
|
||||||
(p 'foo) ; display "point as no method: foo
|
(p 'foo) ; display "point as no method: foo"
|
||||||
|
|
||||||
|
|
||||||
|
|
|
@ -0,0 +1,34 @@
|
||||||
|
(define (point x y)
|
||||||
|
(define (self m)
|
||||||
|
(cond ((eq? m 'getx) (lambda () x))
|
||||||
|
((eq? m 'gety) (lambda () y))
|
||||||
|
((eq? m 'type) (lambda () 'point))
|
||||||
|
((eq? m 'setx!) (lambda (nx) (set! x nx)))
|
||||||
|
((eq? m 'sety!) (lambda (ny) (set! y ny)))
|
||||||
|
((eq? m 'info) (lambda () (list 'point x y)))
|
||||||
|
((eq? m 'add) (lambda (p)
|
||||||
|
(let ((px ((p 'getx)))
|
||||||
|
(py ((p 'gety))))
|
||||||
|
(point (+ x px) (+ y py)))))
|
||||||
|
((eq? m 'sub) (lambda (p)
|
||||||
|
(let ((px ((p 'getx)))
|
||||||
|
(py ((p 'gety))))
|
||||||
|
(point (- x px) (- y py)))))
|
||||||
|
(else (lambda () (display (string-append "Message not understood: " (symbol->string m) "\n"))))))
|
||||||
|
self)
|
||||||
|
|
||||||
|
(define p1 (point 1 2))
|
||||||
|
(define p2 (point 3 4))
|
||||||
|
((p1 'getx)) ; returns 1
|
||||||
|
((p1 'gety)) ; returns 2
|
||||||
|
((p2 'getx)) ; returns 3
|
||||||
|
((p2 'gety)) ; returns 4
|
||||||
|
(define pp ((p1 'add) p2)) ; returns a new point pp
|
||||||
|
((pp 'info)) ; returns (point 4 6)
|
||||||
|
(define pn ((p1 'sub) p2)) ; returns a new point pn
|
||||||
|
((pn 'info)) ; returns (point -2 -2)
|
||||||
|
((pp 'foo)) ; should display "Message not understood" error
|
||||||
|
((p1 'setx!) 5)
|
||||||
|
((p1 'sety!) 5)
|
||||||
|
((p1 'info)) ; returns (point 5 5)
|
||||||
|
|
|
@ -1,3 +1,8 @@
|
||||||
|
;Auhors:Dubois Brieuc, Dubois Simon
|
||||||
|
;Added lambda function to allow for aguments in methodes
|
||||||
|
;We renamed dispatch as self
|
||||||
|
|
||||||
|
;Class definition
|
||||||
(define (point x y)
|
(define (point x y)
|
||||||
(define (self m)
|
(define (self m)
|
||||||
(cond ((eq? m 'getx) (lambda () x))
|
(cond ((eq? m 'getx) (lambda () x))
|
||||||
|
@ -17,6 +22,7 @@
|
||||||
(else (lambda () (display (string-append "Message not understood: " (symbol->string m) "\n"))))))
|
(else (lambda () (display (string-append "Message not understood: " (symbol->string m) "\n"))))))
|
||||||
self)
|
self)
|
||||||
|
|
||||||
|
;Usage example
|
||||||
(define p1 (point 1 2))
|
(define p1 (point 1 2))
|
||||||
(define p2 (point 3 4))
|
(define p2 (point 3 4))
|
||||||
((p1 'getx)) ; returns 1
|
((p1 'getx)) ; returns 1
|
||||||
|
|
|
@ -1,4 +1,13 @@
|
||||||
|
;Auhors:Dubois Brieuc, Dubois Simon
|
||||||
|
;This is the step 2 and step 3a combined
|
||||||
|
;Here we extracted the method definitons from the
|
||||||
|
;dispatch(self) function. We also implented a send
|
||||||
|
;function that allow to request a method from an object
|
||||||
|
;an pass it argument.
|
||||||
|
|
||||||
|
;Class definition
|
||||||
(define (point x y)
|
(define (point x y)
|
||||||
|
;Method definition
|
||||||
(define (getx) (lambda () x))
|
(define (getx) (lambda () x))
|
||||||
(define (gety) (lambda () y))
|
(define (gety) (lambda () y))
|
||||||
(define (type) (lambda () 'point))
|
(define (type) (lambda () 'point))
|
||||||
|
@ -17,6 +26,7 @@
|
||||||
(point (- x px) (- y py))
|
(point (- x px) (- y py))
|
||||||
)
|
)
|
||||||
))
|
))
|
||||||
|
;message handeling method
|
||||||
(define (self m)
|
(define (self m)
|
||||||
(cond ((eq? m 'getx) (getx))
|
(cond ((eq? m 'getx) (getx))
|
||||||
((eq? m 'gety) (gety))
|
((eq? m 'gety) (gety))
|
||||||
|
@ -30,6 +40,7 @@
|
||||||
self
|
self
|
||||||
)
|
)
|
||||||
|
|
||||||
|
|
||||||
(define (method-lookup reciever message)
|
(define (method-lookup reciever message)
|
||||||
(if (= (length message) 1)
|
(if (= (length message) 1)
|
||||||
((reciever (car message)))
|
((reciever (car message)))
|
||||||
|
@ -43,7 +54,7 @@
|
||||||
)
|
)
|
||||||
)
|
)
|
||||||
|
|
||||||
|
;Usage example
|
||||||
(define p1 (point 1 2))
|
(define p1 (point 1 2))
|
||||||
(define p2 (point 3 4))
|
(define p2 (point 3 4))
|
||||||
(send p1 'getx) ; 1
|
(send p1 'getx) ; 1
|
|
@ -0,0 +1,39 @@
|
||||||
|
(define (point x y)
|
||||||
|
(define (self m)
|
||||||
|
(cond ((eq? m 'getx) (lambda () x))
|
||||||
|
((eq? m 'gety) (lambda () y))
|
||||||
|
((eq? m 'type) (lambda () 'point))
|
||||||
|
((eq? m 'setx!) (lambda (nx) (set! x nx)))
|
||||||
|
((eq? m 'sety!) (lambda (ny) (set! y ny)))
|
||||||
|
((eq? m 'info) (lambda () (list 'point x y)))
|
||||||
|
((eq? m 'add) (lambda (p)
|
||||||
|
(let ((px ((p 'getx)))
|
||||||
|
(py ((p 'gety))))
|
||||||
|
(point (+ x px) (+ y py)))))
|
||||||
|
((eq? m 'sub) (lambda (p)
|
||||||
|
(let ((px ((p 'getx)))
|
||||||
|
(py ((p 'gety))))
|
||||||
|
(point (- x px) (- y py)))))
|
||||||
|
(else (lambda () (display (string-append "Message not understood: " (symbol->string m) "\n"))))))
|
||||||
|
self)
|
||||||
|
|
||||||
|
(define (send obj . args)
|
||||||
|
(if (procedure? obj)
|
||||||
|
(if (= (length args) 1)
|
||||||
|
((obj (car args)))
|
||||||
|
((obj (car args)) (car (cdr args)))) ; Extracting the second argument
|
||||||
|
(display (string-append "Inappropriate receiver object: " (symbol->string obj) "\n"))))
|
||||||
|
|
||||||
|
(define p1 (point 1 2))
|
||||||
|
(define p2 (point 3 4))
|
||||||
|
(send p1 'getx) ; 1
|
||||||
|
(send p1 'gety) ; 2
|
||||||
|
(send p2 'getx) ; 3
|
||||||
|
(send p2 'gety) ; 4
|
||||||
|
(define p (send p1 'add p2))
|
||||||
|
(send p 'info) ; (point 4 6)
|
||||||
|
(send 'not-a-point 'info) ; should display "Inappropriate receiver object"
|
||||||
|
(send p 'foo) ; should display "Message not understood"
|
||||||
|
(send p 'bar 2) ; should display "Message not understood"
|
||||||
|
(send p1 'setx! 5)
|
||||||
|
(send p1 'getx) ; returns 5
|
|
@ -0,0 +1,114 @@
|
||||||
|
(define (object)
|
||||||
|
(define super 'nil)
|
||||||
|
(define (self m)
|
||||||
|
(cond
|
||||||
|
((eq? m 'type) (lambda () 'object))
|
||||||
|
(else (lambda args (display (string-append "Message not understood: " (symbol->string m) "\n"))))
|
||||||
|
)
|
||||||
|
)
|
||||||
|
self
|
||||||
|
)
|
||||||
|
|
||||||
|
(define (point x y)
|
||||||
|
(define super (object))
|
||||||
|
(define (getx) (lambda () x))
|
||||||
|
(define (gety) (lambda () y))
|
||||||
|
(define (type) (lambda () 'point))
|
||||||
|
(define (setx!) (lambda (nx) (set! x nx)))
|
||||||
|
(define (sety!) (lambda (ny) (set! y ny)))
|
||||||
|
(define (info) (lambda () (list 'point x y)))
|
||||||
|
(define (add) (lambda (p)
|
||||||
|
(let ((px ((p 'getx)))
|
||||||
|
(py ((p 'gety))))
|
||||||
|
(point (+ x px) (+ y py))
|
||||||
|
)
|
||||||
|
))
|
||||||
|
(define (sub) (lambda (p)
|
||||||
|
(let ((px ((p 'getx)))
|
||||||
|
(py ((p 'gety))))
|
||||||
|
(point (- x px) (- y py))
|
||||||
|
)
|
||||||
|
))
|
||||||
|
|
||||||
|
(define (self m)
|
||||||
|
(cond ((eq? m 'getx) (getx))
|
||||||
|
((eq? m 'gety) (gety))
|
||||||
|
((eq? m 'type) (type))
|
||||||
|
((eq? m 'setx!) (setx!))
|
||||||
|
((eq? m 'sety!) (sety!))
|
||||||
|
((eq? m 'info) (info))
|
||||||
|
((eq? m 'add) (add))
|
||||||
|
((eq? m 'sub) (sub))
|
||||||
|
(else (lambda args (method-lookup super (cons m args))))
|
||||||
|
)
|
||||||
|
)
|
||||||
|
self
|
||||||
|
)
|
||||||
|
|
||||||
|
(define (color-point x y color)
|
||||||
|
(define super (point x y))
|
||||||
|
(define (type) (lambda () 'color-point))
|
||||||
|
(define (get-color) (lambda () color))
|
||||||
|
(define (info) (lambda () (append ((super 'info)) (list color))))
|
||||||
|
(define (add) (lambda (p)
|
||||||
|
(let ((px ((p 'getx)))
|
||||||
|
(py ((p 'gety))))
|
||||||
|
(color-point (+ x px) (+ y py) color)
|
||||||
|
)
|
||||||
|
))
|
||||||
|
(define (sub) (lambda (p)
|
||||||
|
(let ((px ((p 'getx)))
|
||||||
|
(py ((p 'gety))))
|
||||||
|
(color-point (- x px) (- y py) color)
|
||||||
|
)
|
||||||
|
))
|
||||||
|
|
||||||
|
(define (self m)
|
||||||
|
(cond ((eq? m 'type) (type))
|
||||||
|
((eq? m 'get-color) (get-color))
|
||||||
|
((eq? m 'info) (info))
|
||||||
|
((eq? m 'add) (add))
|
||||||
|
(else (lambda args (method-lookup super (cons m args))))
|
||||||
|
)
|
||||||
|
)
|
||||||
|
self
|
||||||
|
)
|
||||||
|
|
||||||
|
(define (method-lookup reciever message)
|
||||||
|
(if (= (length message) 1)
|
||||||
|
((reciever (car message)))
|
||||||
|
((reciever (car message)) (car (cdr message)))
|
||||||
|
))
|
||||||
|
|
||||||
|
(define (send reciever . message)
|
||||||
|
(if (procedure? reciever)
|
||||||
|
(method-lookup reciever message)
|
||||||
|
(display (string-append "Inappropriate receiver object: " (symbol->string reciever) "\n"))
|
||||||
|
)
|
||||||
|
)
|
||||||
|
|
||||||
|
(define o (object))
|
||||||
|
(send o 'type) ; object
|
||||||
|
(send o 'foo) ; should display "Message not understood"
|
||||||
|
|
||||||
|
(define p1 (point 1 2))
|
||||||
|
(define p2 (point 3 4))
|
||||||
|
(send p1 'getx) ; 1
|
||||||
|
(send p1 'gety) ; 2
|
||||||
|
(send p2 'getx) ; 3
|
||||||
|
(send p2 'gety) ; 4
|
||||||
|
(define p (send p1 'add p2))
|
||||||
|
(send p 'info) ; (point 4 6)
|
||||||
|
|
||||||
|
(define cp (color-point 5 6 'red))
|
||||||
|
(send cp 'type) ; color−point
|
||||||
|
(send cp 'getx) ; 5
|
||||||
|
(send cp 'gety) ; 6
|
||||||
|
(send cp 'get-color) ; red
|
||||||
|
(send cp 'info)
|
||||||
|
|
||||||
|
(define cp−1 (send cp 'add (color-point 1 2 'green)))
|
||||||
|
(send cp−1 'type) ; color−point
|
||||||
|
(send cp−1 'getx) ; 6
|
||||||
|
(send cp−1 'gety) ; 8
|
||||||
|
(send cp−1 'get-color) ; red
|
|
@ -1,3 +1,6 @@
|
||||||
|
;Auhors:Dubois Brieuc, Dubois Simon
|
||||||
|
;Here we intoduced inheritance by creating a basic object class that work as parent class for all other class
|
||||||
|
;We also created the class color point inheriting from the class point
|
||||||
(define (object)
|
(define (object)
|
||||||
(define super 'nil)
|
(define super 'nil)
|
||||||
(define (self m)
|
(define (self m)
|
||||||
|
@ -87,6 +90,7 @@
|
||||||
)
|
)
|
||||||
)
|
)
|
||||||
|
|
||||||
|
;Usage example
|
||||||
(define o (object))
|
(define o (object))
|
||||||
(send o 'type) ; object
|
(send o 'type) ; object
|
||||||
(send o 'foo) ; should display "Message not understood"
|
(send o 'foo) ; should display "Message not understood"
|
||||||
|
|
|
@ -1,3 +1,5 @@
|
||||||
|
;Auhors:Dubois Brieuc, Dubois Simon
|
||||||
|
;Here we intoduced the dynamic binding of self. We added the new method allowing to create new instance of a class.
|
||||||
(define (object)
|
(define (object)
|
||||||
(define super 'nil)
|
(define super 'nil)
|
||||||
(define self 'nil)
|
(define self 'nil)
|
||||||
|
@ -110,9 +112,10 @@
|
||||||
)
|
)
|
||||||
)
|
)
|
||||||
|
|
||||||
|
;Usage example
|
||||||
(define cp (new color-point 5 6 'red))
|
(define cp (new color-point 5 6 'red))
|
||||||
(send cp 'type) ; color−point
|
(send cp 'type) ; color−point
|
||||||
(send cp 'getx) ; 5
|
(send cp 'getx) ; 5
|
||||||
(send cp 'gety) ; 6
|
(send cp 'gety) ; 6
|
||||||
(send cp 'get-color) ; red
|
(send cp 'get-color) ; red
|
||||||
(send cp 'info) ; (color−point 5 6 red
|
(send cp 'info) ; (color−point 5 6 red)
|
||||||
|
|
Loading…
Reference in New Issue