|
- (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 `(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 (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))
- (assert (= (type v1) :vector3))
|
