work on oo implementation in scheme

scheme/scheme3.rkt

@@ -0,0 +1,139 @@
+#lang racket
+(define (make-adder n)
+  (lambda (x) (+ x n)))
+
+((make-adder 10) 5)
+(define add10 (make-adder 10))
+(add10 5)
+
+(define (vector-iter vect)
+  (let ((cur 0)
+        (top (vector-length vect)))
+    (lambda ()
+      (if (= cur top)
+          'end
+          (let ((value (vector-ref vect cur)))
+            (set! cur (+ cur 1))
+            value)))))
+(define iter (vector-iter #(1 2 3 4)))
+(iter)
+(iter)
+(iter)
+(iter)
+(iter)
+
+(map (lambda (x) (+ x 1)) '(0 1 2 3 -1))
+(foldl + 0 '(1 2 3 4 5))
+(foldl cons '() '(1 2 3))
+(foldr cons '() '(1 2 3))
+
+(define (make-simple-object)
+  (let ((var 0))
+    (define (init)
+      (set! var 0)
+      var)
+    (define (my-add x)
+      (set! var (+ var x))
+      var)
+    (define (my-get)
+      var)
+    (define (my-display)
+      (newline)
+      (display "The value is: ")
+      (display var)
+      (newline))
+    (lambda (message . args)
+      (apply (case message
+               ((init) init)
+               ((my-add) my-add)
+               ((my-get) my-get)
+               ((my-display) my-display)
+               (else (error "method not defined")))
+             args))))
+(define obj1 (make-simple-object))
+(obj1 'init)
+(obj1 'my-add 3)
+(obj1 'my-display)
+(obj1 'my-get)
+
+(define (make-son)
+  (let ((parent (make-simple-object))
+        (name "an object"))
+    (define (init)
+      (parent 'init))
+    (define (say-hello)
+      (newline)
+      (display "hi, my name is: ")
+      (display name)
+      (newline)
+      (display "and")
+      (parent 'my-display))
+    (lambda (message . args)
+      (case message
+        ((init) (apply init args))
+        ((say-hello) (apply say-hello args))
+        (else (apply parent (cons message args)))))))
+(define obj2 (make-son))
+(obj2 'init)
+(obj2 'say-hello)
+(obj2 'my-add 5)
+(obj2 'my-display)
+(obj2 'say-hello)
+
+(define new-object make-hash)
+
+(define (clone object)
+  (hash-copy object))
+
+(define-syntax !!
+  (syntax-rules ()
+    ((_ object msg new-val)
+     (hash-set! object 'msg new-val))))
+
+(define-syntax ??
+  (syntax-rules ()
+    ((_ object msg)
+     (hash-ref object 'msg))))
+
+(define-syntax ->
+  (syntax-rules ()
+    ((_ object msg arg ...)
+     ((hash-ref object 'msg) object arg ...))))
+
+(define Pino (new-object))
+(!! Pino name "Pino")
+(!! Pino hello
+    (lambda (self x)
+      (display (?? self name))
+      (display " hi: ")
+      (display (?? x name))
+      (newline)))
+(define Pina (clone Pino))
+(!! Pina name "Pina")
+(-> Pina hello Pino)
+(!! Pino set-name
+    (lambda (self x)
+      (!! self name x)))
+(!! Pino set-name-&-age
+    (lambda (self n a)
+      (!! self name n)
+      (!! self age a)))
+(-> Pino hello Pina)
+(-> Pino set-name "Ugo")
+(define Pina2 (clone Pino))
+(-> Pina2 set-name-&-age "Lucia" 25)
+(-> Pina2 hello Pino)
+(?? Pina2 age)
+
+(define (son-of parent)
+  (let ((o (new-object)))
+    (!! o <<parent>> parent)
+    o))
+(define (dispatch object msg)
+  (if (eq? object 'unknown)
+      (error "unknown message" msg)
+      (let ((slot (hash-ref object msg 'unknown)))
+        (if (eq? slot 'unknown)
+            (dispatch (hash-ref object '<<parent>> 'unknown) msg)
+            slot))))
+