slime/bin/tests/class_macro.slime

(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))