This commit is contained in:
duboissim 2024-04-26 23:07:23 +02:00
parent 0a286a00a6
commit 24434d5cf7
9 changed files with 239 additions and 3 deletions

16
project-2/step0.bak Normal file
View File

@ -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

View File

@ -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"

34
project-2/step1.bak Normal file
View File

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

View File

@ -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

View File

@ -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

39
project-2/step2.bak Normal file
View File

@ -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

114
project-2/step3b.bak Normal file
View File

@ -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) ; colorpoint
(send cp 'getx) ; 5
(send cp 'gety) ; 6
(send cp 'get-color) ; red
(send cp 'info)
(define cp1 (send cp 'add (color-point 1 2 'green)))
(send cp1 'type) ; colorpoint
(send cp1 'getx) ; 6
(send cp1 'gety) ; 8
(send cp1 'get-color) ; red

View File

@ -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"

View File

@ -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) ; colorpoint (send cp 'type) ; colorpoint
(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) ; (colorpoint 5 6 red (send cp 'info) ; (colorpoint 5 6 red)