; =====================================
; Object Oriented Programming in Fluxus
; =====================================
;
; Author:
;  Claude Heiland-Allen
;  claudiusmaximus@goto10.org
;
; Inspired by:
;  http://www.pawfal.org/index.php?page=SchemeThinking
;
; Features:
;  + inheritance
;  + polymorphism
;  + dynamic method dispatch
;  + named instance variables
;  + chainable constructors
;
; Example class heirarchy
;  + object
;     + container
;     + shape
;        + cube
;        + sphere
;
; =====================================

; =====================================
; object
; =====================================
(define object
  (lambda args
    (let ((class object) (super '()))
      (define (make) (assoc-set! '() 'class class))
      (let ((self (car args)))
        (define (get-class) (assoc-ref self 'class))
        (cond ; must declare methods
          ((eq? (car args) 'make) (apply make (cdr args)))
          ((eq? (cadr args) 'get-class) (apply get-class (cddr args)))
          (else (display "no method: ") (display args) (newline))
        )
      )
    )
  )
)

; =====================================
; dynamic method dispatcher
; =====================================
(define oo
  (lambda args
    (apply (object (car args) 'get-class) args)
  )
)

; =====================================
; container
; =====================================
(define container
  (lambda args
    (let ((class container) (super object))
      (define (make) ; must construct parent then set class to ourself
        (assoc-set! (assoc-set! (super 'make) 'class class) 'contents '())
      )
      (let ((self (car args)))
        (define (add! x)
          (assoc-set! self 'contents (cons   x (assoc-ref self 'contents)))
        )
        (define (foreach f)
          (map f (assoc-ref self 'contents))
        )
        (define (map! f)
          (assoc-set! self 'contents (map    f (assoc-ref self 'contents)))
        )
        (define (filter! f)
          (assoc-set! self 'contents (filter f (assoc-ref self 'contents)))
        )
        (cond ; declare methods
          ((eq? (car  args) 'make) (apply make (cdr args)))
          ((eq? (cadr args) 'add!) (apply add! (cddr args)))
          ((eq? (cadr args) 'foreach) (apply foreach (cddr args)))
          ((eq? (cadr args) 'map!) (apply map! (cddr args)))
          ((eq? (cadr args) 'filter!) (apply filter! (cddr args)))
          (else (apply super args)) ; delegate to super-class
        )
      )
    )
  )
)

; =====================================
; shape
;  + descendents define (do-draw)
; =====================================
(define shape
  (lambda args
    (let ((class shape) (super object))
      (define (make s r t)
        (assoc-set! (assoc-set! (assoc-set!
          (assoc-set! (super 'make) 'class class)
          'scale s) 'rotate r) 'translate t)
      )
      (let ((self (car args)))
        (define (scale! v)
          (assoc-set! self 'scale (vmul v (assoc-ref self 'scale)))
        )
        (define (rotate! v) ; this is probably incorrect w.r.t. composition...
          (assoc-set! self 'rotate (vadd v (assoc-ref self 'rotate)))
        )
        (define (translate! v)
          (assoc-set! self 'translate (vadd v (assoc-ref self 'translate)))
        )
        (define (draw)
          (push)
            (translate (assoc-ref self 'translate))
            (rotate (assoc-ref self 'rotate))
            (scale (assoc-ref self 'scale))
            (oo self 'do-draw)
          (pop)
        )
        (cond ; declare methods
          ((eq? (car  args) 'make) (apply make (cdr args)))
          ((eq? (cadr args) 'scale!) (apply scale! (cddr args)))
          ((eq? (cadr args) 'rotate!) (apply rotate! (cddr args)))
          ((eq? (cadr args) 'translate!) (apply translate! (cddr args)))
          ((eq? (cadr args) 'draw) (apply draw (cddr args)))
          (else (apply super args)) ; delegate to super-class
        )
      )
    )
  )
)

; =====================================
; cube
; =====================================
(define cube
  (lambda args
    (let ((class cube) (super shape))
      (define (make s r t c)
        (assoc-set!
          (assoc-set! (super 'make s r t) 'class class)
          'colour c)
      )
      (let ((self (car args)))
        (define (do-draw)
          (push)
            (colour (assoc-ref self 'colour))
            (draw-cube)
          (pop)
        )
        (cond ; declare methods
          ((eq? (car  args) 'make) (apply make (cdr args)))
          ((eq? (cadr args) 'do-draw) (apply do-draw (cddr args)))
          (else (apply super args)) ; delegate to super-class
        )
      )
    )
  )
)

; =====================================
; sphere
; =====================================
(define sphere
  (lambda args
    (let ((class sphere) (super shape))
      (define (make s r t c)
        (assoc-set!
          (assoc-set! (super 'make s r t) 'class class)
          'colour c)
      )
      (let ((self (car args)))
        (define (do-draw)
          (push)
            (colour (assoc-ref self 'colour))
            (draw-sphere)
          (pop)
        )
        (cond ; declare methods
          ((eq? (car  args) 'make) (apply make (cdr args)))
          ((eq? (cadr args) 'do-draw) (apply do-draw (cddr args)))
          (else (apply super args)) ; delegate to super-class
        )
      )
    )
  )
)

; =====================================
; example
; =====================================

(newline)

(define myobject (object 'make))
(display "object: ")(display myobject)(newline)
(define mycontainer (container 'make))
(display "container: ")(display mycontainer)(newline)

(oo mycontainer 'add! 1)
(oo mycontainer 'add! 2)
(oo mycontainer 'add! 3)
(display "container: ")(display mycontainer)(newline)

(oo mycontainer 'map! (lambda (x) (* x 3)))
(display "container: ")(display mycontainer)(newline)

(oo mycontainer 'filter! (lambda (x) (> x 5)))
(display "container: ")(display mycontainer)(newline)

(newline)

; =====================================
; shape example
;  + shows polymorphism
; =====================================

(define myshapes (container 'make))
(oo myshapes 'add!
  (cube 'make (vector 1 1 1) (vector 45 0 0) (vector 2 0 0) (vector 1 0 0 ))
)
(oo myshapes 'add!
  (sphere 'make (vector 1 1 1) (vector 0 0 0) (vector 0 2 0) (vector 0 1 0 ))
)
(oo myshapes 'add!
  (cube 'make (vector 1 1 1) (vector 0 45 0) (vector 0 0 2) (vector 0 0 1 ))
)

(display "shapes: ") (display myshapes) (newline)

(define (render) (oo myshapes 'foreach (lambda (x) (oo x 'draw))))

(every-frame (render))

; =====================================
; EOF
; =====================================