From 9c140071e8160548ef64c4f911f965422578f43a Mon Sep 17 00:00:00 2001
From: Julian T <julian@jtle.dk>
Date: Wed, 29 Sep 2021 11:32:48 +0200
Subject: Make pp lec3 nicer again

---
 sem7/pp/lec3.scm | 110 +++++++++++++++++++++++++------------------------------
 1 file changed, 50 insertions(+), 60 deletions(-)

(limited to 'sem7/pp/lec3.scm')

diff --git a/sem7/pp/lec3.scm b/sem7/pp/lec3.scm
index d1aa174..42b30e1 100644
--- a/sem7/pp/lec3.scm
+++ b/sem7/pp/lec3.scm
@@ -16,77 +16,67 @@
 	  [else "?"]
 	  )))
 
-(define (create-dispatch methods not-found)
-  (lambda (msg)
-    (cdr (or (assoc msg methods) (not-found msg)))
-    ))
-
 (define (send obj msg . para)
-  (let ((method (obj msg)))
+  (let ((method (obj obj msg)))
     (apply method para)))
 
 (define (new-instance class . para)
-  (apply class (cons #f para)))
+  (apply class para))
 
 ;; TODO implement str 
-(define (object self)
-  (letrec ([whoami 'object]
-	   [dispatch
-	    (lambda (msg)
-	      (let ([self (or self dispatch)])
-		(cond [(eq? msg 'pretty-str) (lambda () (to-string (send self 'pretty)))]
-		      [(eq? msg 'pretty) (lambda () (list whoami))]
-		      [(eq? msg 'type-of) (lambda () whoami)]
-		      [(eq? msg 'class-of) (lambda () object)]
-		      [else (errorf object "msg ~a not found" msg)])
-		))]) dispatch))
+(define (object)
+  (let ([whoami 'object])
+    (lambda (self msg)
+      (cond [(eq? msg 'pretty-str) (lambda () (to-string (send self 'pretty)))]
+	    [(eq? msg 'pretty) (lambda () (list whoami))]
+	    [(eq? msg 'type-of) (lambda () whoami)]
+	    [(eq? msg 'class-of) (lambda () object)]
+	    [else (errorf object "msg ~a not found" msg)])
+      )))
+
+(define (point x y)
+  (let ([whoami 'point]
+	[super (object)])
+    (lambda (self msg)
+      (cond [(eq? msg 'getx) (lambda () x)]
+	    [(eq? msg 'gety) (lambda () y)]
+	    [(eq? msg 'add) (lambda (other)
+			      (new-instance (send self 'class-of)
+					    (+ x (send other 'getx))
+					    (+ y (send other 'gety))
+					    ))]
+	    [(eq? msg 'pretty) (lambda () (list whoami x y))]
+	    [(eq? msg 'move) (lambda (dx dy)
+			       (send self 'add (new-instance point dx dy)))]
+	    [(eq? msg 'type-of) (lambda () whoami)]
+	    [(eq? msg 'class-of) (lambda () point)]
+	    [(eq? msg 'with-color) (lambda (color)
+				     (new-instance color-point
+						   (send self 'getx)
+						   (send self 'gety)
+						   color))]
+	    [else (super self msg)]))
+    ))
 
-(define (point self x y)
-  (letrec ([whoami 'point]
-	   [dispatch
-	    (lambda (msg)
-	      (let* ([self (or self dispatch)]
-		     [super (object self)])
-		(cond [(eq? msg 'getx) (lambda () x)]
-		      [(eq? msg 'gety) (lambda () y)]
-		      [(eq? msg 'add) (lambda (other)
-					(new-instance (send self 'class-of)
-						      (+ x (send other 'getx))
-						      (+ y (send other 'gety))
-						      ))]
-		      [(eq? msg 'pretty) (lambda () (list whoami x y))]
-		      [(eq? msg 'move) (lambda (dx dy)
-					 (send self 'add (new-instance point dx dy)))]
-		      [(eq? msg 'type-of) (lambda () whoami)]
-		      [(eq? msg 'class-of) (lambda () point)]
-		      [(eq? msg 'with-color) (lambda (color)
-					       (new-instance color-point
-							     (send self 'getx)
-							     (send self 'gety)
-							     color))]
-		      [else (super msg)])))]
-	   ) dispatch))
 
 (define p1 (new-instance point 10 20))
 (define p2 (new-instance point 1 1))
 
-(define (color-point self x y . color)
-  (let ((color (if (null? color) 'green (car color))))
-    (letrec ([whoami 'color-point]
-	     [dispatch
-	      (lambda (msg)
-		(let* ([self (or self dispatch)]
-		       [super (point self x y)])
-		  (cond [(eq? msg 'get-color) (lambda () color)]
-			[(eq? msg 'type-of) (lambda () whoami)]
-			[(eq? msg 'pretty) (lambda ()
-					     (list whoami
-						   (send self 'getx)
-						   (send self 'gety)
-						   (send self 'get-color)))]
-			[(eq? msg 'class-of) (lambda () color-point)]
-			[else (super msg)])))]
-	     ) dispatch)))
+(define (color-point x y . color)
+  (let ([color (if (null? color) 'green (car color))]
+	[whoami 'color-point]
+	[super (point x y)])
+    (lambda (self msg)
+      (cond [(eq? msg 'get-color) (lambda () color)]
+	    [(eq? msg 'type-of) (lambda () whoami)]
+	    [(eq? msg 'pretty) (lambda ()
+				 (list whoami
+				       (send self 'getx)
+				       (send self 'gety)
+				       (send self 'get-color)))]
+	    [(eq? msg 'class-of) (lambda () color-point)]
+	    [else (super self msg)]))
+    ))
 
 ;;# Exercise 3.7
 ;;? What is the value of the expression
-- 
cgit v1.2.3