82 lines
2.1 KiB
Plaintext
82 lines
2.1 KiB
Plaintext
(define (type-wrap obj type)
|
|
(set-type obj type)
|
|
obj)
|
|
|
|
(define-syntax defclass (name members :rest body)
|
|
"Macro for creating classes."
|
|
(define (underscore sym)
|
|
(string->symbol (concat-strings "_" (symbol->string sym))))
|
|
|
|
(define underscored-members (map underscore members))
|
|
|
|
;; the wrapping let environment
|
|
(define let-body `(let ,(zip members underscored-members)))
|
|
|
|
;; the body
|
|
(map (lambda (fun) (append let-body fun)) body)
|
|
|
|
;; the dispatch function
|
|
(append let-body `(type-wrap
|
|
(special-lambda
|
|
(message :rest args)
|
|
"This is the docs for the handle"
|
|
(eval (extend (list message) args))) ,(symbol->keyword name)))
|
|
|
|
;; stuff it all in the constructor function
|
|
`(define
|
|
,(pair (string->symbol (concat-strings "make-" (symbol->string name))) underscored-members)
|
|
,(concat-strings "This is the handle to an object of the class " (symbol->string name))
|
|
,let-body))
|
|
|
|
|
|
(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 (print)
|
|
(printf :sep "" "[vector3] (" x y z ")"))
|
|
)
|
|
|
|
(define v1 (make-vector3 1 2 3))
|
|
(define v2 (make-vector3 3 2 1))
|
|
|
|
(assert (= (type v1) (type v2) :vector3))
|
|
(assert (= (v1 scalar-product v2) 10))
|