turm.rkt

#lang racket
(require (except-in 2htdp/universe left right up down)
         2htdp/image
         lang/posn
         (only-in racket (struct struckt)))

(define-syntax-rule (struct (name params ...))
  (struckt name (params ...) #:transparent))

;; column vector for position in 3D space
;; / x \
;; | y |
;; \ z /
(struct (v3 x y z))

;; rotation matrix
;; / a b c \
;; | p q r |
;; \ u v w /
(struct (rt a b c p q r u v w))

(define-syntax-rule (rot (a b c) (p q r) (u v w))
  (rt a b c p q r u v w))

;; multiply rotation matrix by position column vector
;; / a b c \ / x \
;; | p q r | | y |
;; \ u v w / \ z /
(define (rotatev v rot)
  (match (cons v rot)
    [(cons (v3 x y z) (rt a b c p q r u v w))
     (v3 (+ (* a x) (* b y) (* c z))
         (+ (* p x) (* q y) (* r z))
         (+ (* u x) (* v y) (* w z)))]))


;; sin and cos functions
;; we only rotate by multiple of 90 degrees
;; l is lookup-table: first 4 values of l used for sin, last 4 for cos
(match-define (cons sin cos)
  (let ([l (list 0 1 0 -1 0)])
    (define ((ref l) θ)
      (define th (remainder θ 4))
      (list-ref l (if (< th 0) (+ th 4) th)))
    (cons (ref l)
          (ref (cdr l)))))

;; roll
(define (rotx θ)
  (rot (1 0 0)
       (0 (cos θ) (- (sin θ)))
       (0 (sin θ) (cos θ))))

;; pitch (up/down)
(define (roty θ)
  (rot ((cos θ) 0 (sin θ))
       (0 1 0)
       ((- (sin θ)) 0 (cos θ))))

;; yaw (left/right)
(define (rotz θ)
  (rot ((cos θ) (- (sin θ)) 0)
       ((sin θ) (cos θ) 0)
       (0 0 1)))

(define norot (rotx 0))
(define left (rotz 1))
(define right (rotz -1))
(define up (roty -1))
(define down (roty 1))

;; multiply two rotation matrices
;; result rotates by r1, then by r2
;; / a1 b1 c1 \ / a2 b2 c2 \ 
;; | p1 q1 r1 | | p2 q2 r2 |
;; \ u1 v1 w1 / \ u2 v2 w2 /
(define (add-rot r1 r2)
  (match (cons r1 r2)
    [(cons (rt a1 b1 c1 p1 q1 r1 u1 v1 w1)
           (rt a2 b2 c2 p2 q2 r2 u2 v2 w2))
     (rt (+ (* a1 a2) (* b1 p2) (* c1 u2))
         (+ (* a1 b2) (* b1 q2) (* c1 v2))
         (+ (* a1 c2) (* b1 r2) (* c1 w2))
         (+ (* p1 a2) (* q1 p2) (* r1 u2))
         (+ (* p1 b2) (* q1 q2) (* r1 v2))
         (+ (* p1 c2) (* q1 r2) (* r1 w2))
         (+ (* u1 a2) (* v1 p2) (* w1 u2))
         (+ (* u1 b2) (* v1 q2) (* w1 v2))
         (+ (* u1 c2) (* v1 r2) (* w1 w2)))]))

;; move 1 unit along x-axis, rotated by r, from pos
(define (move1 pos r)
  (match (cons pos (rotatev (v3 1 0 0) r))
    [(cons (v3 x y z) (v3 dx dy dz))
     (v3 (+ x dx) (+ y dy) (+ z dz))]))

(struct (mite pos rot shape))
(struct (world mite stuff shapes/dirs))

;; makes colored box
(define (box r g b)
  (polygon (list (make-posn 0 0)
                 (make-posn 10 0)
                 (make-posn 16 6)
                 (make-posn 16 16)
                 (make-posn 6 16)
                 (make-posn 0 10))
           'solid
           (color r g b 255)))

;; makes colored, transparent circle
(define (circ r g b)
  (circle 8 'solid (color r g b 20)))

;; makes list of shapes and corresponding rotation matrices
;; use with box or circ
(define (shapes/dirs box)
  (let* ([ph (make-placeholder #f)]
         [l `((#f . ,left)
              (,(box 255 0 0) .  ,right)
              (,(box 0 255 0) . ,up)
              (,(box 0 0 255) . ,down)
              . ,ph)])
    (placeholder-set! ph l)
    (make-reader-graph l)))

;; moves mite one unit in current direction
;; rotates mite according to color of its position
;; changes color on its position
(define (step w)
  (match w
    [(world (mite p d sh) w dirs)
     (define pos (move1 p d))
     (define old-color (cdr (hash-ref w pos (cons #f dirs))))
     (define dir (add-rot d (cdar old-color)))
     (define new-color (cdr old-color))
     (define new-colors (hash-set w pos (cons pos new-color)))
     (world (mite pos dir sh) new-colors dirs)]))

;; #t if p1 should be drawn behind/before p2
(define (behind p1 p2)
  (match (cons p1 p2)
    [(cons (v3 x1 y1 z1) (v3 x2 y2 z2))
     (cond [(< y1 y2) #t]
           [(> y1 y2) #f]
           [(< z1 z2) #t]
           [(> z1 z2) #f]
           [(> x1 x2) #t]
           [else #f])]))

(define (draw w)
  (match w
    [(world (mite (v3 x y z) _ sh) c _)
     (place-image sh
                  (+ 200 (* x 10) (+ (* y 6)))
                  (+ 200 (- (* z 10)) (* y 6))
                  (for/fold ([scene (empty-scene 400 400)])
                            ([x (sort (hash-values c) (λ (a b) (behind (car a) (car b))))])
                    (match x
                      [(cons (v3 x y z) col)
                       (if (caar col)
                           (place-image (caar col)
                                        (+ 200 (* x 10) (+ (* y 6)))
                                        (+ 200 (- (* z 10)) (* y 6))
                                        scene)
                           scene)])))]))

(big-bang (world (mite (v3 0 0 0) norot (circle 5 'solid (color 128 0 128 255)))
                 (hash)
                 (shapes/dirs box))
          (on-tick step 1/100)
          (to-draw draw))

;; artsy
#;(big-bang (world (mite (v3 0 0 0) norot (circle 5 'solid (color 128 0 128 20)))
                 (hash)
                 (shapes/dirs circ))
          (on-tick step 1/100)
          (to-draw draw))

;; testing
#;(let* ([red (cdr (shapes/dirs box))]
       [green (cdr red)]
       [blue (cdr green)])
  (define-syntax-rule (whash (pos c) ...)
    (make-immutable-hash (list (cons pos (cons pos c)) ...)))
  (draw (world (mite (v3 10 10 10) norot (circle 5 'solid (color 128 0 128 255)))
               (whash ((v3 0 0 0) red)
                      ((v3 1 0 0) green)
                      ((v3 0 0 1) green)
                      ((v3 1 0 1) red)
                      ((v3 0 1 0) green)
                      ((v3 1 1 0) red)
                      ((v3 0 1 1) red)
                      ((v3 1 1 1) green)
                      ((v3 -1 0 1) blue))
               (shapes/dirs box))))