From 24434d5cf753b253481f3d076bab46f23f6c71af Mon Sep 17 00:00:00 2001 From: duboissim Date: Fri, 26 Apr 2024 23:07:23 +0200 Subject: [PATCH] remise --- project-2/step0.bak | 16 ++++ project-2/step0.rkt | 11 ++- project-2/step1.bak | 34 ++++++++ project-2/step1.rkt | 6 ++ project-2/{step3.rkt => step2+3a.rkt} | 13 ++- project-2/step2.bak | 39 +++++++++ project-2/step3b.bak | 114 ++++++++++++++++++++++++++ project-2/step3b.rkt | 4 + project-2/step4.rkt | 5 +- 9 files changed, 239 insertions(+), 3 deletions(-) create mode 100644 project-2/step0.bak create mode 100644 project-2/step1.bak rename project-2/{step3.rkt => step2+3a.rkt} (84%) create mode 100644 project-2/step2.bak create mode 100644 project-2/step3b.bak diff --git a/project-2/step0.bak b/project-2/step0.bak new file mode 100644 index 0000000..6287105 --- /dev/null +++ b/project-2/step0.bak @@ -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 + + diff --git a/project-2/step0.rkt b/project-2/step0.rkt index 6287105..279b160 100644 --- a/project-2/step0.rkt +++ b/project-2/step0.rkt @@ -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 (dispatch m) (cond ((eq? m 'getx) x) @@ -6,11 +13,13 @@ ((eq? m 'info) (list 'point x y)) (else (display (string-append "point as no method: " (symbol->string m) "\n"))))) dispatch) + +;Usage example (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 +(p 'foo) ; display "point as no method: foo" diff --git a/project-2/step1.bak b/project-2/step1.bak new file mode 100644 index 0000000..9667431 --- /dev/null +++ b/project-2/step1.bak @@ -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) + diff --git a/project-2/step1.rkt b/project-2/step1.rkt index 9667431..1b1b06c 100644 --- a/project-2/step1.rkt +++ b/project-2/step1.rkt @@ -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 (self m) (cond ((eq? m 'getx) (lambda () x)) @@ -17,6 +22,7 @@ (else (lambda () (display (string-append "Message not understood: " (symbol->string m) "\n")))))) self) +;Usage example (define p1 (point 1 2)) (define p2 (point 3 4)) ((p1 'getx)) ; returns 1 diff --git a/project-2/step3.rkt b/project-2/step2+3a.rkt similarity index 84% rename from project-2/step3.rkt rename to project-2/step2+3a.rkt index bb863c7..9da4710 100644 --- a/project-2/step3.rkt +++ b/project-2/step2+3a.rkt @@ -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) + ;Method definition (define (getx) (lambda () x)) (define (gety) (lambda () y)) (define (type) (lambda () 'point)) @@ -17,6 +26,7 @@ (point (- x px) (- y py)) ) )) + ;message handeling method (define (self m) (cond ((eq? m 'getx) (getx)) ((eq? m 'gety) (gety)) @@ -30,6 +40,7 @@ self ) + (define (method-lookup reciever message) (if (= (length message) 1) ((reciever (car message))) @@ -43,7 +54,7 @@ ) ) - +;Usage example (define p1 (point 1 2)) (define p2 (point 3 4)) (send p1 'getx) ; 1 diff --git a/project-2/step2.bak b/project-2/step2.bak new file mode 100644 index 0000000..8dd63e7 --- /dev/null +++ b/project-2/step2.bak @@ -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 diff --git a/project-2/step3b.bak b/project-2/step3b.bak new file mode 100644 index 0000000..106b02c --- /dev/null +++ b/project-2/step3b.bak @@ -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 diff --git a/project-2/step3b.rkt b/project-2/step3b.rkt index 106b02c..9050994 100644 --- a/project-2/step3b.rkt +++ b/project-2/step3b.rkt @@ -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 super 'nil) (define (self m) @@ -87,6 +90,7 @@ ) ) +;Usage example (define o (object)) (send o 'type) ; object (send o 'foo) ; should display "Message not understood" diff --git a/project-2/step4.rkt b/project-2/step4.rkt index 038e50a..e646101 100644 --- a/project-2/step4.rkt +++ b/project-2/step4.rkt @@ -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 super 'nil) (define self 'nil) @@ -110,9 +112,10 @@ ) ) +;Usage example (define cp (new 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) ; (color−point 5 6 red +(send cp 'info) ; (color−point 5 6 red)