Skip to content
Extraits de code Groupes Projets
Valider 8e4dd9f2 rédigé par Nicolas Verbois's avatar Nicolas Verbois
Parcourir les fichiers

Replace step_4.rkt

parent 9690a535
Aucune branche associée trouvée
Aucune étiquette associée trouvée
Aucune requête de fusion associée trouvée
......@@ -19,16 +19,16 @@
))
(define (getcolor) color)
(define (gettype) 'color-point)
(define (getinfo) (append (super 'info) (list (self 'get-color))))
(define (getinfo) (append (send super 'info) (list (getcolor))))
(define (add cp)
(color-point (+ (super 'getx) (cp 'getx)) (+ (super 'gety) (cp 'gety)) (getcolor)))
(define (self m)
(cond ((eq? m 'get-color) (getcolor))
((eq? m 'info) (getinfo))
((eq? m 'type) (gettype))
(cond ((eq? m 'get-color) getcolor)
((eq? m 'info) getinfo)
((eq? m 'type) gettype)
((eq? m 'add) add)
((eq? m 'set-self!) set-self!)
(else (send super m))))
(else (super m))))
self)
;POINT
......@@ -43,28 +43,28 @@
(define (getx) x )
(define (gety) y )
(define (gettype) 'point )
(define (getinfo)(list (self_ref 'type) (self 'getx) (self 'gety)))
(define (getinfo)(list (send self_ref 'type) (getx) (gety)))
(define (setx value)(set! x value))
(define (sety value)(set! y value))
(define (add p)
(point (+ (getx) (p 'getx)) (+ (gety) (p 'gety))))
(point (+ (getx) (send p 'getx)) (+ (gety) (send p 'gety))))
(define (self m)
(cond ((eq? m 'getx) (getx))
((eq? m 'gety) (gety))
((eq? m 'type) (gettype))
((eq? m 'info) (getinfo))
(cond ((eq? m 'getx) getx)
((eq? m 'gety) gety)
((eq? m 'type) gettype)
((eq? m 'info) getinfo)
((eq? m 'setx!) setx)
((eq? m 'sety!) sety)
((eq? m 'add) add)
((eq? m 'child) (send self 'getcolor))
((eq? m 'set-self!) set-self!)
(else (send super m))))
(else (super m))))
self)
(define (send p m . args)
(if (procedure? p)
(cond
((null? args) (p m))
((null? args) ((p m)))
(else
((p m) (car args))
......@@ -74,43 +74,18 @@
(define (new object-class . class-args)
(cond ((eq? object-class color-point)
(if (eq? (length class-args) 3)
(let ((temp (color-point (car class-args) (cadr class-args) (caddr class-args)))); apply for arguments
(begin
(send temp 'set-self! temp)
temp
)
)
(display "SON PERE")
))
((eq? object-class point)
(if (eq? (length class-args) 2)
(let ((temp (point (car class-args) (cadr class-args)))); apply for arguments
(begin
(send temp 'set-self! temp)
temp
)
)
(display "SON PERE")
))
((eq? object-class object)
(if (eq? (length class-args) 0)
(let ((temp (object))); apply for arguments
(begin
(send temp 'set-self! temp)
temp
)
)
(display "SON PERE")
))
)
(let ((temp (apply object-class class-args)))
(begin
(send temp 'set-self! temp)
temp
)
)
)
(eq? color-point point)
( define cp ( new color-point 5 6 'red ) )
( cp 'type ) ; c o l o r - p o i n t
( cp 'getx ) ; 5
( cp 'gety ) ; 6
( cp 'get-color ) ; red
( cp 'info ) ; ( c o l o r - p o i n t 5 6 red )
( send cp 'type ) ; c o l o r - p o i n t
( send cp 'getx ) ; 5
( send cp 'gety ) ; 6
( send cp 'get-color ) ; red
( send cp 'info ) ; ( c o l o r - p o i n t 5 6 red )
0% Chargement en cours ou .
You are about to add 0 people to the discussion. Proceed with caution.
Terminez d'abord l'édition de ce message.
Veuillez vous inscrire ou vous pour commenter