; A program to illustrate perspective and depth illusion
; Click the left mouse button or drag to move the eye
; Click the middle mouse button to switch to the noncube
; Click the right mouse button to switch to the cube

(print-struct #t)
(define-struct point (x y z) (make-inspector))

(define view (make-point 400 300 -700))

(define put-in-perspective
  (lambda (eye depth)
    (lambda (point)
      (let ((scale (/ depth (- (point-z point) (point-z eye))))
            (x-offset (- (point-x point) (point-x eye)))
            (y-offset (- (point-y point) (point-y eye))))
        (make-point (+ (point-x view) (* scale x-offset))
                    (+ (point-y view) (* scale y-offset))
                    depth)))))

(define square
  (lambda (dx dy z)
    (list (make-point (- (point-x view) dx) (- (point-y view) dy) z)
          (make-point (- (point-x view) dx) (+ (point-y view) dy) z)
          (make-point (+ (point-x view) dx) (- (point-y view) dy) z)
          (make-point (+ (point-x view) dx) (+ (point-y view) dy) z))))

(define cube-vertices
  (append (square 100 100 -100) (square 100 100 100)))

(define noncube-vertices
  (append (square 150 150 200) (square 100 100 100)))

(define lines
  '((0 1) (2 3) (4 5) (6 7)
    (0 2) (1 3) (4 6) (5 7)
    (0 4) (1 5) (2 6) (3 7)))

(define draw-segment
  (lambda (elts dc)
    (lambda (vs)
      (let ((first (list-ref elts (car vs)))
            (second (list-ref elts (car (cdr vs)))))
        (send dc draw-line (point-x first) (point-y first)
              (point-x second) (point-y second))))))

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

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

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

(define (draw-cube canvas dc)
  (send dc set-pen my-pen)
  (send dc set-brush no-brush)
  (let ((vertices (map (put-in-perspective (send canvas get-eye-pt) 700)
                       (send canvas get-vertices))))
    (for-each (draw-vertex dc) vertices)
    (for-each (draw-segment vertices dc) lines)))

(define frame
  (instantiate frame% ("perspective cube")
    (width  (* 2 (point-x view)))
    (height (* 2 (point-y view)))))

(define my-canvas%
  (class canvas%
    (override on-event)
    (inherit refresh)
    (public get-eye-pt get-vertices)
    (define eye-pt view)
    (define get-eye-pt (lambda () eye-pt))
    (define vertices cube-vertices)
    (define get-vertices (lambda () vertices))
    (define on-event
      (lambda (event)
        (cond
          [(or (send event button-down? 'left) (send event dragging?))
           (set! eye-pt (make-point (send event get-x)
                                    (send event get-y)
                                    (point-z view)))
           (refresh)]
          [(send event button-down? 'middle)
           (display 'noncube-vertices) (newline)
           (set! vertices noncube-vertices)
           (refresh)]
          [(send event button-down? 'right)
           (display 'cube-vertices) (newline)
           (set! vertices cube-vertices)
           (refresh)])))
    (super-instantiate ())))

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

(send frame show #t)