3d racket drawing

3d.rkt

#lang racket/gui

(require racket/flonum racket/fixnum)
;(require racket/require)
;(require (filtered-in
;          (λ (name) (regexp-replace #rx"unsafe-" name ""))
;          racket/unsafe/ops))
;(require (only-in racket/flonum flvector))

(define-syntax-rule (define-bin-op-stx name oper id)
  (define-syntax name
    (syntax-rules ()
      [(name) id]
      [(name a) (name id a)]
      [(name a b) (oper a b)]
      [(name a b . rst) (name (name a b) . rst)])))

(define-bin-op-stx f+ fl+ 0.0)
(define-bin-op-stx f- fl- 0.0)
(define-bin-op-stx f* fl* 1.0)
(define-bin-op-stx f/ fl/ 1.0)
(define-syntax-rule (sq x) (f* x x))

(define vec flvector)
(define-syntax-rule (v.x v) (flvector-ref v 0))
(define-syntax-rule (v.y v) (flvector-ref v 1))
(define-syntax-rule (v.z v) (flvector-ref v 2))

(define phi (f/ (f+ 1.0 (flsqrt 5.0)) 2.0))
(define -phi (f- 0.0 phi))

(define (icosahedron-faces v)
  (vector (vector (vector-ref v 0)  (vector-ref v 4)  (vector-ref v 1))
          (vector (vector-ref v 0)  (vector-ref v 9)  (vector-ref v 4))
          (vector (vector-ref v 9)  (vector-ref v 5)  (vector-ref v 4))
          (vector (vector-ref v 4)  (vector-ref v 5)  (vector-ref v 8))
          (vector (vector-ref v 4)  (vector-ref v 8)  (vector-ref v 1))
          (vector (vector-ref v 8)  (vector-ref v 10) (vector-ref v 1))
          (vector (vector-ref v 8)  (vector-ref v 3)  (vector-ref v 10))
          (vector (vector-ref v 5)  (vector-ref v 3)  (vector-ref v 8))
          (vector (vector-ref v 5)  (vector-ref v 2)  (vector-ref v 3))
          (vector (vector-ref v 2)  (vector-ref v 7)  (vector-ref v 3))
          (vector (vector-ref v 7)  (vector-ref v 10) (vector-ref v 3))
          (vector (vector-ref v 7)  (vector-ref v 6)  (vector-ref v 10))
          (vector (vector-ref v 7)  (vector-ref v 11) (vector-ref v 6))
          (vector (vector-ref v 11) (vector-ref v 0)  (vector-ref v 6))
          (vector (vector-ref v 0)  (vector-ref v 1)  (vector-ref v 6))
          (vector (vector-ref v 6)  (vector-ref v 1)  (vector-ref v 10))
          (vector (vector-ref v 9)  (vector-ref v 0)  (vector-ref v 11))
          (vector (vector-ref v 9)  (vector-ref v 11) (vector-ref v 2))
          (vector (vector-ref v 9)  (vector-ref v 2)  (vector-ref v 5))
          (vector (vector-ref v 7)  (vector-ref v 2)  (vector-ref v 11))))

(define icosahedron 
  (vector
   (flvector -1.0  0.0  phi)
   (flvector  1.0  0.0  phi)
   (flvector -1.0  0.0 -phi)
   (flvector  1.0  0.0 -phi)
   (flvector  0.0  phi  1.0)
   (flvector  0.0  phi -1.0)
   (flvector  0.0 -phi  1.0)
   (flvector  0.0 -phi -1.0)
   (flvector  phi  1.0  0.0)
   (flvector -phi  1.0  0.0)
   (flvector  phi -1.0  0.0)
   (flvector -phi -1.0  0.0)))


(define pi 3.141592653589793238462643383279)

(define *size*         600.0)
(define *x-rot-speed*  (f/ pi 240.0))
(define *y-rot-speed*  (f/ pi 360.0))
(define *scale*        120.0) 
(define *camera-angle* (vec 0.0   0.0  0.0))
(define *camera-pos*   (vec 0.0   0.0 15.0))
(define *view-pos*     (vec 0.0   0.0 10.0))
(define *light-point*  (vec 0.0   0.0 15.0))
(define *face-color*   (vec 200.0 0.0  0.0))

(define (offset-polyhedron v x y z)
  (vector-map (lambda (n) 
                (vec (f+ (v.x n) x) (f+ (v.y n) y) (f+ (v.z n) z)))
              v))

(define (rotate-3d p theta phi psi)
  (let ([x (v.x p)] 
        [y (v.y p)] 
        [z (v.z p)]
        [sint (flsin theta)]
        [cost (flcos theta)]
        [sinph (flsin phi)]
        [cosph (flcos phi)]
        [sinps (flsin psi)]
        [cosps (flcos psi)])
    (vec (f+ (f* cost cosps x)
             (f* (f- (f* sinph sint cosps) (f* cosph sinps)) y)
             (f* (f+ (f* cosph sint cosps) (f* sinph sinps)) z))
         (f+ (f* cost sinps x)
             (f* (f+ (f* sinph sint sinps) (f* cosph cosps)) y)
             (f* (f- (f* cosph sint sinps) (f* sinph cosps)) z))
         (f+ (f* (f- sint) x)
             (f* sinph cost y)
             (f* cosph cost z)))))

(define (vector- v1 v2)
  (vec (f- (v.x v1) (v.y v2)) (f- (v.y v1) (v.y v2)) (f- (v.z v1) (v.z v2))))

(define (dot v1 v2)
  (f+ (f* (v.x v1) (v.x v2)) (f* (v.y v1) (v.y v2)) (f* (v.z v1) (v.z v2))))

(define (vector-abs v)
  (let ([x (v.x v)] [y (v.y v)] [z (v.z v)])
    (flsqrt (f+ (sq x) (sq y) (sq z)))))

(define (normal f)
  (let ([p1 (vector-ref f 0)] [p2 (vector-ref f 1)] [p3 (vector-ref f 2)])
    (let ([p1x (v.x p1)] [p1y (v.y p1)] [p1z (v.z p1)]
          [p2x (v.x p2)] [p2y (v.y p2)] [p2z (v.z p2)]
          [p3x (v.x p3)] [p3y (v.y p3)] [p3z (v.z p3)])
      (let ([v1x (f- p2x p1x)] [v1y (f- p2y p1y)] [v1z (f- p2z p1z)]
            [v2x (f- p3x p1x)] [v2y (f- p3y p1y)] [v2z (f- p3z p1z)])
        (vec (f- (f* v1y v2z) (f* v1z v2y))
             (f- (f* v1z v2x) (f* v1x v2z))
             (f- (f* v1x v2y) (f* v1y v2x)))))))

(define (unitize v) 
  (let ((dis (vector-abs v)))
    (vec (f/ (v.x v) dis) (f/ (v.y v) dis) (f/ (v.z v) dis))))


(define (face-shade f)
  (let ([dif (dot (unitize (normal f))
                  (unitize (vector- (barycenter f) *light-point*)))]
        [facer (v.x *face-color*)]
        [faceg (v.y *face-color*)]
        [faceb (v.z *face-color*)])
    (make-object color% 
      (fxabs (exact-round (f* facer dif)))
      (fxabs (exact-round (f* faceb dif)))
      (fxabs (exact-round (f* faceg dif))))))


(define (3d-project p)
  (define (perspectiveproj a c thetv e)
    (let ([cosx (flcos (v.x thetv))]  [cosy (flcos (v.y thetv))]  [cosz (flcos (v.z thetv))]
          [sinx (flsin (v.x thetv))]  [siny (flsin (v.y thetv))]  [sinz (flsin (v.z thetv))]
          [amcx (f- (v.x a) (v.x c))] [amcy (f- (v.y a) (v.y c))] [amcz (f- (v.z a) (v.z c))])
      (let ([dx (f- (f* cosy (f+ (f* sinz amcy) (f* cosz amcx))) (f* sinz amcz))]
            [dy (f+ (f* sinx (f+ (f* cosy amcz) (f* siny (f+ (f* sinz amcy) (f* cosz amcx)))))
                    (f* cosx (f- (f* cosz amcy) (f* sinz amcx))))]
            [dz (f- (f* cosx (f+ (f* cosy amcz) (f* siny (f+ (f* sinz amcy) (f* cosz amcx)))))
                    (f* sinx (f- (f* cosz amcy) (f* sinz amcx))))])
        (make-object point%
          (f* (f- dx (v.x e)) (f/ (v.z e) dz) *scale*)
          (f* (f- dy (v.y e)) (f/ (v.z e) dz) *scale*)))))
  (perspectiveproj p *camera-pos* *camera-angle* *view-pos*))

(define (barycenter f)
  (let-values ([(ll) (fx->fl (vector-length f))]
               [(vx vy vz)
                (for/fold ([xx 0.0] [yy 0.0] [zz 0.0]) ([p (in-vector f)])
                  (values (f+ xx (v.x p)) (f+ yy (v.y p)) (f+ zz (v.z p))))])
    (vec (f/ vx ll) (f/ vy ll) (f/ vz ll))))

(define (prepare faces)
  (for/vector ([face (in-vector faces)]
               #:when (fl>= (dot (unitize (normal face))
                                 (unitize (vector- (barycenter face) *camera-pos*)))
                            0.0))
    (cons (face-shade face) 
          (for/list ([v (in-vector face)]) (3d-project v)))))

(define (do-rotate vs thetaz thetay thetax)
  (for/vector #:length (vector-length vs) ([e (in-vector vs)])
    (rotate-3d e thetaz thetay thetax)))

(define cvs%
  (class canvas% (super-new)
    (inherit get-dc refresh suspend-flush resume-flush)
    (define dc (get-dc))
    (define ctr 0.0)
    (define last-print (current-inexact-milliseconds))
    (define last-print-ticks 0)
    (define/public (tick)
      (set! last-print-ticks (fx+ last-print-ticks 1))
      (set! ctr (f+ ctr 1.0)))
    (define/override (on-paint)
      (when (fl> (f- (current-inexact-milliseconds) last-print) 1000.0)
        (set! last-print (current-inexact-milliseconds))
        (printf "~a fps~n" last-print-ticks)
        (set! last-print-ticks 0))
      (suspend-flush)
      (send dc erase)
      (let ([drawable
             (prepare
              (icosahedron-faces
               (offset-polyhedron
                (do-rotate 
                 icosahedron
                 (f* (f- *x-rot-speed*) ctr) 
                 (f* *y-rot-speed* ctr) 
                 (f* (f- *x-rot-speed*) ctr))
                (flsin (f/ ctr 23.0)) (fltan (f/ ctr 33.0)) (flcos (f/ ctr 17.0)))))])
        (for ([f (in-vector drawable)])
          (send dc set-brush (new brush% [color (car f)]))
          (send dc draw-polygon (cdr f) (f/ *size* 2.0) (f/ *size* 2.0))))
      (resume-flush))))


(define sema (make-semaphore 0))
(define timer #f)
(define frame 
  (make-object 
      (class frame% 
        (define/augment (on-close) 
          (semaphore-post sema)
          (send timer stop)
          (inner (void) on-close))
        (super-new)) "asdf"))

(define cvs (make-object cvs% frame))

(send* cvs 
  (min-width (exact-round *size*))
  (min-height (exact-round *size*)))

(send frame show #t)

(set! timer
      (make-object timer% 
        (lambda _ (send cvs tick) (send cvs refresh))
        16))

(void (yield sema))