(define make-point
  (lambda (x y z)
    (list (quote point) x y z)))

(define x-coord
  (lambda (point)
    (car (cdr point))))

(define y-coord
  (lambda (point)
    (car (cdr (cdr point)))))

(define z-coord
  (lambda (point)
    (car (cdr (cdr (cdr point))))))

(define put-in-perspective
  (lambda (eye img-z)
    (lambda (pt)
      (let (
            (img-eye-z  (- img-z        (z-coord eye)))
            (pt-eye-x   (- (x-coord pt) (x-coord eye)))
            (pt-eye-y   (- (y-coord pt) (y-coord eye)))
            (pt-eye-z   (- (z-coord pt) (z-coord eye)))
            )
        (make-point
         (+ (x-coord eye) (* pt-eye-x (/ img-eye-z pt-eye-z)))
         (+ (y-coord eye) (* pt-eye-y (/ img-eye-z pt-eye-z)))
         img-z)))))
    
(define cube-vertices 
  (list (make-point 100 100 200)
        (make-point 100 300 200)
        (make-point 300 100 200)
        (make-point 300 300 200)
        (make-point 100 100 400)
        (make-point 100 300 400)
        (make-point 300 100 400)
        (make-point 300 300 400)))

(define cube-lines
  (list '(1 2)
        '(1 3)
        '(3 4)
        '(2 4)
        '(5 6)
        '(5 7)
        '(6 8)
        '(7 8)
        '(1 5)
        '(2 6)
        '(3 7)
        '(4 8)))
(define (pick n l)
  (if (<= n 1) 
      (car l)
      (pick (- n 1) (cdr l))))

(define draw-segment
  (lambda (elts dc)
    (lambda (vs)
      (let ((first (pick (car vs) elts))
            (second (pick (car (cdr vs)) elts)))
        (send dc draw-line (x-coord first) (y-coord first)
              (x-coord second) (y-coord second))))))

(define draw-vertex
  (lambda (dc)
    (lambda (p)
      (send dc draw-arc
            (- (x-coord p) 3)
            (- (y-coord p) 3)
            6 6 0 0))))

(define transform
  (lambda (f)
    (lambda (l)
      (if (null? l)
          '()
          (cons (f (car l)) ((transform f) (cdr l)))))))

(define app
  (lambda (f)
    (lambda (l)
      (if (null? l)
          #t
          (begin
            (f (car l))
            ((app f) (cdr l)))))))

(define my-pen 
  (instantiate pen% ("BLACK" 2 'solid)))

(define no-brush
  (instantiate brush% ("BLACK" 'transparent)))

(define clear-pen 
  (instantiate pen% ("WHITE" 1 'solid)))

(define clear-brush
  (instantiate brush% ("WHITE" 'solid)))

(define (draw-cube canvas dc)
  (send dc set-pen clear-pen)
  (send dc set-brush clear-brush)
  (send dc draw-rectangle 0 0 400 400)
  (send dc set-pen my-pen)
  (send dc set-brush no-brush)
  (let ((vertices ((transform (put-in-perspective
                               (send canvas get-eye-pt)
                               0))
                   cube-vertices))) 
    ((app (draw-vertex dc)) vertices)
    ((app (draw-segment vertices dc)) cube-lines)))

(define frame
  (instantiate frame% ("perspective cube")
    (width 400) (height 400)))

(define my-canvas%
  (class canvas%
    (override on-event)
    (inherit refresh)
    (public get-eye-pt)
    (define eye-pt (make-point 200 200 -500))
    (define get-eye-pt (lambda () eye-pt))
    (define on-event
      (lambda (event)
        (if (or (send event button-down? 'any)
                (send event dragging?))
            (begin
              (refresh)
              (set! eye-pt (make-point (send event get-x) (send event get-y) -500))
              ))))
    (super-instantiate ())))

(define canvas
  (instantiate my-canvas% (frame)
    (paint-callback (lambda (canvas dc) 
                      (draw-cube canvas dc)))))

(send frame show #t)