|
|
|
@@ -0,0 +1,81 @@ |
|
|
|
(defun type-wrap (obj type) |
|
|
|
(set-type obj type) |
|
|
|
obj) |
|
|
|
|
|
|
|
(define-syntax defclass (name members :rest body) |
|
|
|
"Macro for creatating classes." |
|
|
|
(defun 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 |
|
|
|
(eval (list defun (string->symbol (concat-strings "make-" (symbol->string name))) underscored-members |
|
|
|
"This is the handle to an object of the class " |
|
|
|
let-body))) |
|
|
|
|
|
|
|
;; (v1 print) |
|
|
|
;; (v1 length) |
|
|
|
;; (v1 get-x) |
|
|
|
;; (v1 set-x 10) |
|
|
|
|
|
|
|
(defclass vector3 (x y z) |
|
|
|
(defun get-x () x) |
|
|
|
(defun get-y () y) |
|
|
|
(defun get-z () z) |
|
|
|
|
|
|
|
(defun set-x (new-x) (mutate x new-x)) |
|
|
|
(defun set-y (new-y) (mutate y new-y)) |
|
|
|
(defun set-z (new-z) (mutate z new-z)) |
|
|
|
|
|
|
|
(defun length () |
|
|
|
(** (+ (* x x) (* y y) (* z z)) 0.5)) |
|
|
|
|
|
|
|
(defun scale (fac) |
|
|
|
(mutate x (* fac x)) |
|
|
|
(mutate y (* fac y)) |
|
|
|
(mutate z (* fac z)) |
|
|
|
fac) |
|
|
|
|
|
|
|
(defun add (other) |
|
|
|
(make-vector3 |
|
|
|
(+ x (other get-x)) |
|
|
|
(+ y (other get-y)) |
|
|
|
(+ z (other get-z)))) |
|
|
|
|
|
|
|
(defun subtract (other) |
|
|
|
(make-vector3 |
|
|
|
(- x (other get-x)) |
|
|
|
(- y (other get-y)) |
|
|
|
(- z (other get-z)))) |
|
|
|
|
|
|
|
(defun scalar-product (other) |
|
|
|
(+ (* x (other get-x)) |
|
|
|
(* y (other get-y)) |
|
|
|
(* z (other get-z)))) |
|
|
|
|
|
|
|
(defun 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))))) |
|
|
|
|
|
|
|
(defun printout () |
|
|
|
(printf "[vector3] (" x y z ")")) |
|
|
|
) |
|
|
|
|
|
|
|
(define v1 (make-vector3 1 2 3)) |
|
|
|
(define v2 (make-vector3 3 2 1)) |
|
|
|
|
|
|
|
(v1 scalar-product v2) |