fixed let not coying the initial value nodes

2019-03-15 01:14:45 +01:00
parent 6734ee2258
commit 31a833b5c9
10 changed files with 237 additions and 34 deletions
@@ -0,0 +1,111 @@
+(define (type-wrap obj type)
+  (set-type obj type)
+  obj)
+
+(define-syntax defclass (name members :rest body)
+  "Macro for creatating classes."
+  (define (underscore sym)
+    (string->symbol (concat-strings "_" (symbol->string sym))))
+
+  (define underscored-members (map underscore members))
+
+  ;; the wrapping let environment
+  (define let-body (list 'let (zip members underscored-members)))
+
+  ;; the body
+  (map (lambda (fun) (append let-body fun)) body)
+
+  ;; the dispatch function
+  (append let-body '(special-lambda
+                     (message :rest args)
+                     "This is the docs for the handle"
+                     (eval (extend (list message) args))))
+
+  ;; stuff it all in the constructor function
+  (list 'define
+        (pair (string->symbol (concat-strings "make-" (symbol->string name))) underscored-members)
+        "This is the handle to an object of the class "
+        let-body))
+
+(define (make-vector3 _x _y _z)
+  "This is the handle to an object of the class "
+  (let ((x _x)
+        (y _y)
+        (z _z))
+
+    (define (get-x) x)
+    (define (get-y) y)
+    (define (get-z) z)
+
+    (define (set-x new-x) (mutate x new-x))
+    (define (set-y new-y) (mutate y new-y))
+    (define (set-z new-z) (mutate z new-z))
+
+    (define (length) (** (+ (* x x) (* y y) (* z z)) 0.500000))
+    (define (scale fac) (mutate x (* fac x)) (mutate y (* fac y)) (mutate z (* fac z)) fac)
+    (define (add other) (make-vector3 (+ x (other get-x)) (+ y (other get-y)) (+ z (other get-z))))
+    (define (subtract other) (make-vector3 (- x (other get-x)) (- y (other get-y)) (- z (other get-z))))
+    (define (scalar-product other) (+ (* x (other get-x)) (* y (other get-y)) (* z (other get-z))))
+    (define (cross-product other) (make-vector3 (- (* y (other get-z)) (* z (other get-y))) (- (* z (other get-x)) (* x (other get-z))) (- (* x (other get-y)) (* y (other get-x)))))
+    (define (printout) (printf "[vector3] (" x y z ")"))
+
+    (special-lambda
+     (message :rest args)
+     "This is the docs for the handle"
+     (eval (extend (list message) args)))))
+
+
+;; (v1 print)
+;; (v1 length)
+;; (v1 get-x)
+;; (v1 set-x 10)
+
+(defclass vector3 (x y z)
+  (define (get-x) x)
+  (define (get-y) y)
+  (define (get-z) z)
+
+  (define (set-x new-x) (mutate x new-x))
+  (define (set-y new-y) (mutate y new-y))
+  (define (set-z new-z) (mutate z new-z))
+
+  (define (length)
+    (** (+ (* x x) (* y y) (* z z)) 0.5))
+
+  (define (scale fac)
+    (mutate x (* fac x))
+    (mutate y (* fac y))
+    (mutate z (* fac z))
+    fac)
+
+  (define (add other)
+    (make-vector3
+     (+ x (other get-x))
+     (+ y (other get-y))
+     (+ z (other get-z))))
+
+  (define (subtract other)
+    (make-vector3
+     (- x (other get-x))
+     (- y (other get-y))
+     (- z (other get-z))))
+
+  (define (scalar-product other)
+    (+ (* x (other get-x))
+       (* y (other get-y))
+       (* z (other get-z))))
+
+  (define (cross-product other)
+    (make-vector3
+     (- (* y (other get-z)) (* z (other get-y)))
+     (- (* z (other get-x)) (* x (other get-z)))
+     (- (* x (other get-y)) (* y (other get-x)))))
+
+  (define (printout)
+    (printf "[vector3] (" x  y  z ")"))
+  )
+
+(define v1 (make-vector3 1 2 3))
+(define v2 (make-vector3 3 2 1))
+
+(assert (= (v1 scalar-product v2) 10))