groworld/hex-ornament/hex-ornament.scm

;#lang scheme/base
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; hex ornament/groworld game : fluxus version

;(require fluxus-016/drflux)
(require scheme/class)

;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; tweakables

(define hex-width 40)
(define hex-height 40)

(define num-insects 50)
(define pickup-drop-probability 10)

(define surface-start 34)
(define surface-upper 39)
(define surface-lower 30)

(define (vec3->vec4 v a)
  (vector (vx v) (vy v) (vz v) a))

(define (bg-colour) (vmul (vector 0.9 0.8 0.7) 0.2))
(define (sky-colour) (vector 0.7 0.8 1))
(define (worm-colour) (hsv->rgb (vector 0.1 (rndf) 1)))
(define (root-colour) (vector 0.6 0.5 0.5))
(define (pickup-colour) (hsv->rgb (vector 0.1 (rndf) 1)))
(define (absorb-colour) (vec3->vec4 (hsv->rgb (vector (rndf) 0.2 (+ 0.6 (rndf)))) 0.2))

(define (type->colour type)
  (cond 
    ((string=? type "knobbly") (vector 1 0.6 0.6))
    ((string=? type "lollypop") (vector 0.6 0.6 1))    
    ((string=? type "nik") (vector 0.6 1 0.6))
    (else (vector 1 1 1))))

;(define texpath "")
(define texpath "textures/")

;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; odds and sods

; return a version of list l with v inserted at the nth
; position and with c as a counter
(define (insert l n v c)
  (cond 
    ((null? l) l)
    ((eq? c n) (cons v (insert (cdr l) n v (+ c 1))))
    (else (cons (car l) (insert (cdr l) n v (+ c 1))))))

(define (list-remove l i)
  (if (zero? i)
      (cdr l)
      (cons (car l) (list-remove (cdr l) (- i 1)))))

(define (shuffle l)
  (if (null? l)
      '()
      (let ((i (random (length l))))
        (cons (list-ref l i)
              (shuffle (list-remove l i))))))

(define (choose l)
  (list-ref l (random (length l))))

; convert a list of bools into a number, treating the
; list as a binary sequence
(define (bool-list->num l n c)
  (cond 
    ((null? l) n)
    ((car l) (bitwise-ior (arithmetic-shift 1 c)
                          (bool-list->num (cdr l) n (+ c 1))))
    (else (bool-list->num (cdr l) n (+ c 1)))))

; how to find your way around a hexagon
;           .
;  5 (NW) /   \  0 (NE)
;       /       \
; 4 (W)|         | 1 (E)
;      |         |
;       \       /
; 3 (SW)  \   /  2 (SE)
;           `

(define NE 0)
(define E  1)
(define SE 2)
(define SW 3)
(define W  4)
(define NW 5)

(define directions (list NE E SE SW W NW))

(define (rdirection d) 
  (cond
    ((eq? d NE) SW)
    ((eq? d E) W) 
    ((eq? d SE) NW)
    ((eq? d SW) NE)
    ((eq? d W) E)
    ((eq? d NW) SE)))

;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; util for building random plants

(define (make-random-plant depth)        
  (let ((num-children (cond ((> depth 2) 0)
                            ((< depth 1) (choose (list 2 3)))
                            (else (choose (list 0 1 2 3))))))
    (cond 
      ((eq? num-children 0) (list (choose (list "0" "1")) (list)))
      ((eq? num-children 1) (list "1-0" (list (make-random-plant (+ depth 1)))))
      ((eq? num-children 2) (list "2-0" (list (make-random-plant (+ depth 1))
                                              (make-random-plant (+ depth 1)))))
      ((eq? num-children 3) (list "3-0" (list (make-random-plant (+ depth 1))
                                              (make-random-plant (+ depth 1)) (make-random-plant (+ depth 1)))))
      ((eq? num-children 4) (list "4-0" (list (make-random-plant (+ depth 1))
                                              (make-random-plant (+ depth 1)) (make-random-plant (+ depth 1)) 
                                              (make-random-plant (+ depth 1)))))
      ((eq? num-children 5) (list "5-0" (list (make-random-plant (+ depth 1))
                                              (make-random-plant (+ depth 1)) (make-random-plant (+ depth 1))
                                              (make-random-plant (+ depth 1)) (make-random-plant (+ depth 1))))))))

;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; how this works
;
;     logic side                    rendering side
;     ----------                    --------------
; (no fluxus code allowed)  |    (no game code allowed)
;                           |
;     comb-cell             |       comb-cell-view
;          \                |          /
;  insect   \               |         /   insect-view
;        \   \          messages     /       /
;         honey-comb  ===========> honey-comb-view
;           /               |           \
;     garden                |         garden-view
;      /                    |               \
;   plant                   |               plant-view
;
;

;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; logic

; messages passed between the honey-comb logic and the view
(define-struct init-update (surface-pos-list))
(define-struct cell-update (pos code pickup upstream type))
(define-struct insect-update (id pos dir t))
(define-struct absorb-event (cell-pos type))
(define-struct plant-update (id desc pos type))
(define-struct controller-update (grow-pos))

(define comb-cell%
  (class object%
    (field
     (plant #f)   ; the owner plant
     (pos '())
     (neighbours '(#f #f #f #f #f #f))
     (pickup #f)
     (connections '(#f #f #f #f #f #f))
     (visible #f)
     (update-me #f)
     (upstream #f)) ; the cell we are connected to (if we are)
    
    (define/public (get-plant)
      plant)
    
    (define/public (set-plant! s)
      (set! plant s))
    
    (define/public (update-me?)
      (let ((r update-me))
        (set! update-me #f)
        r))
    
    (define/public (get-upstream)
      upstream)
    
    (define/public (set-visible! s)
      (set! update-me #t)
      (set! visible s))
    
    (define/public (visible?)
      visible)
    
    (define/public (get-pos)
      pos)
    
    (define/public (set-pos! s)
      (set! pos s))
    
    (define/public (get-neighbours)
      neighbours)
    
    (define/public (get-neighbour d)
      (list-ref neighbours d))
    
    (define/public (set-neighbour! d n)
      (set! neighbours (insert neighbours d n 0)))
    
    (define/public (get-pickup)
      pickup)
    
    (define/public (set-pickup! s)
      (when visible (set! update-me #t))
      (set! pickup s))
    
    (define/public (get-connections)
      connections)
    
    (define/public (no-connections?)
      (equal? connections (list #f #f #f #f #f #f)))
    
    (define/public (set-connection! d n)
      (set! update-me #t)
      (set! visible #t)
      (set! connections (insert connections d n 0))
      ; tell all our neighbours to become visible
      (for-each
       (lambda (n)
         (when n 
           (send n set-visible! #t)
           (send n set-plant! plant)))
       neighbours))
    
    (define/public (get-connection d)
      (list-ref connections d))
    
    (define/public (get-connection-num)
      (bool-list->num connections 0 0))
    
    ; returns the first attachable neighbour found, and sets it's connection
    (define (search/attach-to-neighbour l dirs)
      (cond 
                ((null? l) dirs)
                ((not (send (get-neighbour (car l)) no-connections?))
                    (send (get-neighbour (car l)) set-connection! (rdirection (car l)) #t)
                    (set! plant (send (get-neighbour (car l)) get-plant))
                    (set! upstream (get-neighbour (car l)))
                    #;(search/attach-to-neighbour (cdr l) (cons (car l) dirs))
                    (car l))
                (else (search/attach-to-neighbour (cdr l) dirs))))
        
        (define/public (grow)
            ; only possible to grow when we are a clear cell
            (when (equal? connections (list #f #f #f #f #f #f))
                (let ((dir (search/attach-to-neighbour (shuffle directions) '())))
                    (when dir
                        (set-connection! dir #t))
                    #;(for-each
                        (lambda (d)
                            (set-connection! d #t))
                        dir))))
        
        (super-new)))

;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

(define insect%
    (class object%
        (init-field
            (id 0)
            (cell 0)
            (d (+ 5.5 (* 2 (rndf))))) ; time to get from one cell to another
        
        (field
            (next-update 0))
        
        (define/public (get-id)
            id)
        
        (define/public (get-cell)
            cell)
        
        (define (move cell)
            (let* ((i (random (length (send cell get-neighbours))))
                    (n (list-ref (send cell get-neighbours) i)))
                (if n (list i n) (move cell))))
        
        (define/public (update time delta)
            (cond ((> time next-update)
                    (let ((m (move cell)))
                        (when (zero? (random pickup-drop-probability))
                            (send cell set-pickup! 'default))
                        (set! next-update (+ time d))
                        (set! cell (cadr m))
                        (make-insect-update id (send cell get-pos) (car m) d)))
                (else #f)))
        
        (super-new)))

;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

(define plant%
    (class object%
        (init-field
            (id "none")
            (type "none")
            (pos '())) ; the seed position
        
        (field
            (update-me #t)
            (desc (make-random-plant 0)))
        
        (define/public (get-id)
            id)
        
        (define/public (get-type)
            type)
        
        (define/public (update-me?)
            (let ((r update-me))
                (set! update-me #f)
                r))
        
        (define/public (get-desc)
            desc)
        
        (define/public (get-pos)
            pos)
        
        (define/public (init x y)
            (set! pos (list x y)))
        
        (super-new)))

;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

(define garden%
    (class object%
        (field
            (plants '()))
        
        (define/public (add-plant plant)
            (set! plants (cons (list (send plant get-id) plant) plants)))
        
        ; returns a list of plant descriptions needing updating by the view
        (define/public (update)
            (foldl
                (lambda (plant r)
                    (if (send (cadr plant) update-me?)
                        (cons (make-plant-update (car plant) 
                                (send (cadr plant) get-desc)
                                (send (cadr plant) get-pos)
                                (send (cadr plant) get-type)) r)
                        r))
                '()
                plants))
        
        (super-new)))

;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

(define honey-comb%
    (class object%
        (field
            (cells '())
            (width 0)
            (height 0)
            (insects '())
            (garden (make-object garden%))
            (surface-cells '())
            (first-time #t))
        
        (define/public (get-cell x y)
            (list-ref cells (+ (* y height) x)))
        
        (define/public (init w h)
            (set! width w)
            (set! height h)
            
            ; first build the cells
            (set! cells (build-list (* w h) (lambda (_) (make-object comb-cell%))))
            
            ; now build the insects
            (set! insects (build-list num-insects (lambda (id) (make-object insect% id (choose cells)))))
            
            ; then stitch them together like this:
            
            ; o o o o o o o o o o o
            ;  o o o o o o o o o o o 
            ; o o o o o o o o o o o
            ;  o o o o o o o o o o o
            
            (for ((x (in-range 0 width)))
                (for ((y (in-range 0 height)))
                    (let ((cell (get-cell x y)))
                        (send cell set-pos! (list x y))
                        (when (and (< x (- width 1)) (> y 0))
                            (send cell set-neighbour! NE (get-cell (if (odd? y) (+ x 1) x) (- y 1))))
                        (when (< x (- width 1))
                            (send cell set-neighbour! E (get-cell (+ x 1) y)))
                        (when (and (< x (- width 1)) (< y (- height 1)))
                            (send cell set-neighbour! SE (get-cell (if (odd? y) (+ x 1) x) (+ y 1))))
                        
                        (when (and (> x 0) (> y 0))
                            (send cell set-neighbour! NW (get-cell (if (odd? y) x (- x 1)) (- y 1))))
                        (when (> x 0)
                            (send cell set-neighbour! W (get-cell (- x 1) y)))
                        (when (and (> x 0) (< y (- height 1)))
                            (send cell set-neighbour! SW (get-cell (if (odd? y) x (- x 1)) (+ y 1)))))))
          (set! surface-cells (calc-surface-cells 0 surface-start surface-upper surface-lower '())))
          
        ; we need to calculate the surface cells here, as we have the information
        ; to calculate an unbroken line of hexes
      (define/public (calc-surface-cells x y upper lower l)
        ; calculate the surface hexes
        (let* ((direction (choose (cond 
                                    ((> y (- upper 1)) (list E NE))
                                    ((< y lower) (list E SE))
                                    (else (list SE E NE)))))
               (next-cell (send (get-cell x y) get-neighbour direction)))
          (cond ((not next-cell) l)
                (else
                 (let ((pos (send next-cell get-pos)))
                   (calc-surface-cells (car pos) (cadr pos) upper lower 
                                       (cons (list (list x y) direction) l)))))))
        
      (define/public (seed id type i)
        (let* ((x (car (car (list-ref surface-cells i))))
              (y (cadr (car (list-ref surface-cells i))))
              (plant (make-object plant% id type (list x y))))
          (send garden add-plant plant)
          (send (get-cell x (- y 1)) set-plant! plant)
          (send (get-cell x (- y 1)) set-connection! SE #t)
          #;(send (get-cell x (- y 1)) set-plant! plant)
          #;(send (get-cell x (- y 1)) set-connection! NW #t)))
        
        (define/public (update time delta)
            
            (append
             
             ; first frame, send the cells that represent the surface, so they can be drawn
             (cond (first-time (set! first-time #f) (list (make-init-update surface-cells)))
                   (else '()))
                           
             ; look for pickups over roots
             (foldl
              (lambda (cell r)
                (let ((pickup (send cell get-pickup)))
                  (cond ((and (not (send cell no-connections?)) pickup)
                         (send cell set-pickup! #f)
                         (cons (make-absorb-event (send cell get-pos) pickup) r))
                        (else r))))
              '()
              cells)
                
                (foldl
                    (lambda (insect r)
                        (let ((l (send insect update time delta)))
                            (if l (cons l r) r)))
                    '()
                    insects)
                
                (foldl
                 (lambda (cell r)
                   (if (send cell update-me?)
                       (let ((upstream (send cell get-upstream))
                             (plant (send cell get-plant)))
                         (cons (make-cell-update (send cell get-pos)
                                                 (send cell get-connection-num)
                                        (send cell get-pickup)
                                        (if upstream (send upstream get-pos) #f)
                                        (if plant (send plant get-type) #f)) r))
                            r))
                    '()
                    cells)
                
                ; get updates from the garden
                (send garden update)))
        
        (super-new)))

;======================================================================
; graphics and interaction

; more odds and sods...

(define (direction-normal d) 
    (let ((a (* 2 1.141 60)))
        (vmul (vector (sin (* a d)) (cos (* a d)) 0) -1)))

(define (build-ngon n)
    (let ((p (build-polygons n 'polygon)))
        (with-primitive p
            (pdata-index-map!
                (lambda (i p)
                    (let ((a (* (/ i n) (* 2 3.141))))
                        (vector (cos a) (sin a) 0)))
                "p")
            (pdata-map! 
                (lambda (t p) 
                    (let ((p (vtransform p (mmul 
                                        (mrotate (vector 0 0 -90))
                                        (mscale (vector -1 1 1))))))
                        (vsub (vmul p 0.45) (vector 0.5 0.5 0))))
                "t" "p")
            (pdata-copy "t" "tref")
            (pdata-map! (lambda (n) (vector 0 0 1)) "n"))
        p))

(define (build-hex x y root)
  (with-state    
   ;(hint-wire)
   (parent root)
   (hint-unlit)
   (when (odd? y)
     (translate (vector 0.5 0 0)))
   (translate (vector x (* 0.85 y) (* 0.001 (rndf))))
   (scale (vector 0.58 0.57 1))
   (rotate (vector 0 0 90))
   (build-ngon 6)))

; slow implementation of hermite curves for animation
(define (hermite s p1 p2 t1 t2)
    ; the bernstein polynomials
    (define (h1 s)
        (+ (- (* 2 (expt s 3))
                (* 3 (expt s 2))) 1))
    
    (define (h2 s)
        (+ (* -2 (expt s 3))
            (* 3 (expt s 2))))
    
    (define (h3 s)
        (+ (- (expt s 3) (* 2 (expt s 2))) s))
    
    (define (h4 s)
        (- (expt s 3) (expt s 2)))
    
    (vadd
        (vadd 
            (vmul p1 (h1 s))
            (vmul p2 (h2 s)))
        (vadd
            (vmul t1 (h3 s))
            (vmul t2 (h4 s)))))

; slow, stupid version for getting the tangent - not in the mood for
; maths today to see how you derive it directly, must be pretty simple
(define (hermite-tangent t p1 p2 t1 t2)
    (let ((p (hermite t p1 p2 t1 t2)))
        (list p (vsub (hermite (- t 0.01) p1 p2 t1 t2) p))))

(define (lerp t p1 p2)
    (vadd (vmul p1 (- 1 t)) (vmul p2 t)))

(define (lerp-tangent t p1 p2)
    (let ((p (lerp t p1 p2)))
        (list p (vsub (lerp (- t 0.01) p1 p2) p))))

;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; pluggable plants code follows

; pixel primitive things for getting connection points

; converts a 2D vector into an angle, with some dodgy dave maths
(define (2dvec->angle x y)
    (let ((q (/ 3.141 2)))
        (when (zero? y) (set! y 0.0001))
        (cond 
            ((>= y 0)
                (fmod (* (+ q q q (- q (atan (/ x y)))) 57.2957795) 360))
            (else
                (fmod (* (+ q (- q (atan (/ x y)))) 57.2957795) 360)))))

(define (i->pos i)
    (vector (modulo i (pixels-width)) 
        (quotient i (pixels-width)) 0))

(define (pos->i pos)
    (+ (* (round (vy pos)) (pixels-width)) (round (vx pos))))

(define (pixels-ref name pos)
    (pdata-ref name (pos->i pos)))

(define (pixels-set! name pos s)
    (pdata-set! name (pos->i pos) s))

(define (search i)
    (cond
        ((eq? i (pdata-size)) i)
        ((< (vr (pdata-ref "c" i)) 0.5) i)
        (else (search (+ i 1)))))

(define (flood pos tc av)
    (define (rec-flood pos)
        (pixels-set! "c" pos (vector 1 0 1))
        (set! tc (+ tc 1))
        (set! av (vadd av pos))
        (when (< (vr (pixels-ref "c" (vadd pos (vector -1 0 0)))) 0.5)
            (rec-flood (vadd pos (vector -1 0 0))))
        (when (< (vr (pixels-ref "c" (vadd pos (vector 1 0 0)))) 0.5)
            (rec-flood (vadd pos (vector 1 0 0))))
        (when (< (vr (pixels-ref "c" (vadd pos (vector 0 1 0)))) 0.5)
            (rec-flood (vadd pos (vector 0 1 0))))
        (when (< (vr (pixels-ref "c" (vadd pos (vector 0 -1 0)))) 0.5)
            (rec-flood (vadd pos (vector 0 -1 0)))))
    (rec-flood pos)
    (vmul av (/ 1 tc)))

(define (find-centroids pos l)
    (let ((i (search pos)))
        (cond ((eq? i (pdata-size)) l)
            (else
                (find-centroids i 
                    (cons (flood (i->pos i) 0 (vector 0 0 0)) l))))))

(define (convert-to-pos l)
    (map 
        (lambda (cp)
            (vector (- (- (/ (vx cp) (pixels-width)) 0.5))
                (/ (vy cp) (pixels-height)) 0))
        l))

;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; a cache for the connection points - should save this out 

(define connection-cache '())

(define (get-connection-list id type)
    (let ((ret (assoc (list id type) connection-cache)))
        (cond 
            (ret (cdr ret))
            (else
                (let* ((tex (load-primitive (string-append "plants/" type "/branches/comp-cp-" id ".png")))
                        (connections (with-primitive tex (convert-to-pos (find-centroids 0 '())))))
                    (set! connection-cache (cons (cons (list id type) connections) connection-cache))
                    ;(printf "~a:~a~n" id (length connections))
                    (destroy tex)
                    connections)))))


;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; a plant component

(define-struct component (root (col #:mutable) children))

(define (build-component id type col children)
  (cond 
    ((null? children) 
     (let ((root (with-state
                  (colour col)
                  (hint-unlit)
                  (hint-depth-sort)
                  (translate (vector 0 0.5 0))
                  (texture (load-texture (string-append "plants/" type "/leaves/comp-" id ".png")))
                  (build-plane))))
       (make-component root col '())))
    (else
     (let ((connection-list (get-connection-list id type))
           (root (with-state
                  (colour col)
                  (hint-unlit)
                  (hint-depth-sort)
                  (translate (vector 0 0.5 0))
                  (texture (load-texture (string-append "plants/" type "/branches/comp-" id ".png")))
                  (build-plane))))
       (when (not (eq? (length connection-list) (length children)))
         (printf "something wrong: ~a children:~a connections:~a~n" id (length children) (length connection-list) ))
       
       (let ((comp (make-component root col
                                   (map
                                    (lambda (child connection)
                                      (with-state                                        
                                       (parent root)
                                       (translate (vadd connection (vector 0 0 (* 0.001 (rndf)))))
                                       (rotate (vector 0 0 (2dvec->angle 
                                                            (vx connection) (- (vy connection) 0.5))))
                                       ;(scale 0.9)
                                       (build-component (car child) type col (cadr child))))
                                    children
                                    connection-list))))
         (with-primitive root (apply-transform))
         comp)))))

(define (random-leaf component)
    (cond
        ((null? (component-children component)) component)
        (else (random-leaf (choose (component-children component))))))

(define (component-leaves component)
    (cond
        ((null? (component-children component)) (list component))
        (else 
            (foldl
                (lambda (child r)
                    (append (component-leaves child) r))
                '()
                (component-children component)))))

(define (component-print component)
    (printf "~a~n" (component-children component)))

;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

(define cell-view%
    (class object%
        (field
            (root 0)
            (tile1 0)
            (tile2 0)
            (bgtile 0)
            (pickup-root 0)
            (t 0)
            (pos '(0 0))
            (owner 0)
            (type #f) ; the plant type of the owner of the roots, if any
            (upstream-pos '()))
        
        (define/public (get-upstream-pos)
            upstream-pos)
        
        (define/public (set-upstream-pos! s)
            (set! upstream-pos s))
        
        (define/public (set-owner! s)
            (set! owner s))
        
        (define/public (get-root)
            root)
        
        (define/public (get-tile)
            tile1)
        
        (define/public (get-pos)
            pos)
        
        (define/public (set-pos! s)
            (set! pos s))

        (define/public (set-type! s)
            (set! type s))
        
        (define (build-prim code)                        
            (let ((p (build-hex 0 0 root)))
                (with-primitive p
                                (hint-depth-sort)
                                (colour (root-colour))           
                                (opacity 0)
                                (update-texture code))
                p))
        
        (define/public (build code)            
            (set! root (with-state
                    (parent owner)
                    (when (odd? (cadr pos))
                        (translate (vector 0.5 0 0)))
                    (translate (vector (car pos) (* 0.85 (cadr pos)) 0))
                    (build-locator)))
          
          (when (zero? bgtile)
            (set! bgtile (build-hex 0 0 root))
            (with-primitive bgtile
                            (hint-depth-sort)
                            (texture (load-texture (string-append texpath "stones.png")))
                            (translate (vector 0 0 -0.1))
                            (rotate (vector 0 0 (* (random 6) 60))))
            (let ((code (random 4)))
              (with-primitive bgtile
                            (pdata-map!
                             (lambda (t)
                               (let ((size (/ 1 2)))
                                 (vadd (vmul t size) (vector (* 1 size (+ 1 (modulo code 2)))
                                                             (* size 1 (+ 1 (quotient code 2))) 0))))
                             "t"))))
            
            (set! tile1 (build-prim code))
            (set! tile2 (build-prim code)))
        
        (define (update-texture code)
          ; todo: variations
          (when type
            (texture (load-texture (string-append "plants/" type "/roots/roots.png")))
            (colour (type->colour type)))
          (pdata-map!
           (lambda (t tref)
             (let ((size (/ 1 8)))
               (vadd (vmul tref size) (vector (* 1 size (+ 1 (modulo code 8)))
                                              (* size 1 (+ 1 (quotient code 8))) 0))))
           "t" "tref"))
        
        (define/public (new-code code)      
            (when (not (zero? tile2)) 
                (destroy tile2)
                (with-primitive tile1 (opacity 1)))
            (set! tile2 (build-prim code))
            (set! t 0)) 
        
        (define/public (set-pickup! type)
            (when (and (not type) (not (zero? pickup-root)))
                (destroy pickup-root)
                (set! pickup-root 0))
            (when type
                (when (not (zero? pickup-root))
                    (destroy pickup-root)
                    (set! pickup-root 0))
                (set! pickup-root (with-state
                        (colour (pickup-colour))
                        (parent root)
                        (build-torus 0.03 0.2 10 10)))))
        
        (define/public (update time delta)
            (set! t (+ t delta))
            
            (when (not (zero? pickup-root))
                (with-primitive pickup-root
                    (rotate (vector 0 2 0))))
            
            (when (< t 1)
                (with-primitive tile1
                    (opacity (- 1 t)))
                (with-primitive tile2
                    (opacity t)))
            
            (when (> t 1) 
                (with-primitive tile1
                    (opacity 1))
                
                (when (not (zero? tile2))
                    (destroy tile1)
                    (set! tile1 tile2)
                    (set! tile2 0))))
        
        (super-new)))


;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

(define insect-view%
    (class object%
        (field
            (root 0)
            (from (vector 0 0 0))
            (to (vector 0 0 0))
            (from-dir (vector 1 0 0))
            (to-dir (vector 1 0 0))
            (t 0)
            (d 0))
        
        (define/public (build)
            (set! root (build-cube))
            (with-primitive root (hide 1)))
        
        (define/public (goto-cell cell dir dur)
            (set! from to)
            (set! from-dir to-dir)
            (set! to (with-primitive (send cell get-root) 
                    (vtransform (vector 0 0 0) (get-transform))))
            (set! to-dir (direction-normal dir))
            (set! t 0)
            (set! d dur))
        
        (define/public (update time delta)
            (cond ((or (zero? d) (> t d) (equal? from (vector 0 0 0)))
                    (with-primitive root (hide 1))
                    (set! from (vector 0 0 0)))
                (else
                    (with-primitive root
                        (hide 0)
                        (identity)
                        
                        (let ((h (hermite-tangent (/ t d) from to (vmul from-dir 2) (vmul to-dir 2))
                                    #;(lerp-tangent (/ t d) from to)))
                            
                            (translate (car h))
                            (concat (maim (vector 0 0 1) (vnormalise (cadr h)))))
                        
                        (scale 0.2))))
            (set! t (+ t delta)))
        
        (super-new)))

;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

(define worm-view%
    (class insect-view%
        (inherit-field root from to from-dir to-dir t d)      
        
        (field 
            (hidden #t)
            (from2 (vector 0 0 0))
            (from-dir2 (vector 0 0 0)))     

        (define/override (goto-cell cell dir dur)
            (set! from2 from)
            (set! from to)
            (set! from-dir2 from-dir)
            (set! from-dir to-dir)
            (set! to (with-primitive (send cell get-root) 
                    (vtransform (vector 0 0 0) (get-transform))))
            (set! to-dir (direction-normal dir))
            (set! t 0)
            (set! d dur))
        
        (define/override (build)
            (set! root (build-ribbon 20))
            (with-primitive root 
                (hide 1)
                (translate (vector 0 0 -0.1))
                (hint-unlit)
                (set! hidden #t)
                (colour (worm-colour))
                (texture (load-texture (string-append texpath "worm.png")))
                (let ((width (+ 0.05 (* 0.05 (rndf)))))
                    (pdata-index-map!
                        (lambda (i w)
                            width #;(+ 0.05 (* (abs (sin (* i 0.5))) 0.1)))
                        "w"))
                #;(pdata-map!
                    (lambda (c)
                        (vector 1 1 1))
                    "c")))
        
        (define/override (update time delta)
            (cond ((or (zero? d) (> t d) (equal? from2 (vector 0 0 0)))
                    (set! hidden #t)
                    (with-primitive root (hide 1)))
                (else
                    (let ((t (/ t d))) ; normalise time
                        (with-primitive root
                            (when hidden
                                (set! hidden #f)
                                (pdata-map!
                                    (lambda (p)
                                        from)
                                    "p"))
                            (hide 0)
                            (pdata-index-map!
                                (lambda (i p)
                                    (let ((st (- t (* i 0.05))))
                                        (if (< st 0) 
                                            (hermite (+ st 1) from2 from (vmul from-dir2 2) (vmul from-dir 2))
                                            (hermite st from to (vmul from-dir 2) (vmul to-dir 2)))))
                            "p")))))
        
        (set! t (+ t delta)))
    
    (super-new)))

;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

(define absorb-view%
    (class object%
        (field
            (cell #f)
            (root 0)
            (next-time 0)
            (target (vector 0 0 0))
            (speed 0.5)
            (alive #t)
            (t 0))
        
        (define/public (set-cell! s)
            (set! cell s))
        
        (define/public (alive?) 
            alive)
        
        (define/public (build p)
            (set! root (with-state
                    (texture (load-texture (string-append texpath "particle.png")))
                    (parent p)
                    (build-particles 20)))
            
            (let ((pos (with-primitive (send cell get-root) 
                            (vtransform (vector 0 0 0) (get-transform)))))
                (with-primitive root
                    (translate (vector 0 0 0.2))
                    (hint-depth-sort)
                    (pdata-map! 
                        (lambda (p)
                            (vadd pos (vmul (srndvec) 0.3)))
                        "p")
                    (pdata-map! 
                        (lambda (c)
                            (absorb-colour))
                        "c")
                    (pdata-map! 
                        (lambda (s)
                            (let ((s (* 0.2 (+ 0.1 (rndf)))))
                                (vector s s 1)))
                        "s"))))
        
        
        (define/public (update time delta hcv)
            (set! t (+ t delta))
            
            (with-primitive root
                (pdata-map!
                    (lambda (p)
                        (vadd p (vadd (vmul (vsub target p) 0.05) (vmul (srndvec) 0.06))))
                    "p"))
            
            (when (> time next-time)
                (set! next-time (+ time speed))
                (let ((upstream-pos (send cell get-upstream-pos)))
                    (cond (upstream-pos
                            (set! cell (send hcv get-cell-from-pos (send cell get-upstream-pos)))
                            (set! target (with-primitive (send cell get-root) 
                                    (vtransform (vector 0 0 0) (get-transform)))))
                        
                        (else 
                            (set! alive #f)
                            (destroy root))))))
        
        (super-new)))

;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

(define plant-view%
    (class object%
        (field 
            (root 0)
            (desc '()))
        
        (define/public (build s type)
            (set! desc s)
            
            (when (not (zero? root))
                (destroy root))
            
            (set! root (build-locator))
            
            ; build the plant
            (with-state
                (parent root)
                (hint-depth-sort)
                (translate (vector 0.2 0.3 0.1))
                (build-component "1-0" type (type->colour type) (list desc))))
        
        
        (super-new)))

;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

(define garden-view%
    (class object%
        (field 
            (plants '()))
        
        (define/public (add-plant! id desc hex type)
            (let ((plant (make-object plant-view%)))
                (with-state
                    (parent (send hex get-root))                
                    (send plant build desc type)
                    (set! plants (cons (list id plant) plants)))))
        
        (super-new)))

;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

(define honey-comb-view%
    (class object%
        (field
            (root 0)
            (cells '()) ; an associative list mapping position to cell-views
            (insects '()) ; an associative list mapping id to insect-views
            (absorb-list '()) ; just a list of absorb effects
            (garden (make-object garden-view%)))
        
        (define/public (init)
            (set! root (build-locator))
            (set! insects (build-list num-insects 
                    (lambda (id) 
                        (list id (make-object worm-view%)))))
            (with-state
                (parent root)    
                (for-each 
                    (lambda (insect)
                        (send (cadr insect) build))
                    insects)))
        
        (define (get-pos-from-prim-impl p l)
            (cond 
                ((null? l) #f)
                ((eq? (send (cadr (car l)) get-tile) p) (caar l))
                (else (get-pos-from-prim-impl p (cdr l)))))
        
      (define/public (get-pos-from-prim p)
        (get-pos-from-prim-impl p cells))
      
        (define/public (get-cell-from-pos pos)
            (cadr (assoc pos cells)))
        
       
        
        (define/public (add-absorb! s)
            (set! absorb-list (cons s absorb-list)))
        
        (define (surface-texture x y)
            (pdata-map!
                (lambda (t)
                    (let ((size (/ 1 3)))
                        (vadd (vmul t size) 
                            (vector (* size (+ x 1)) (* size (+ y 1)) 0))))
                "t")
            (texture (load-texture (string-append texpath "surface3.png"))))
        
      (define (surface-contains? pos l)
        (cond 
          ((null? l) #f)
          ((equal? (car (car l)) pos) #t)
          (else (surface-contains? pos (cdr l)))))
      
        (define/public (build-surface l)
          (let ((s (reverse l)))
            (for ((i (in-range 1 (- (length s) 1))))
                 (let ((x (caar (list-ref s i)))
                       (y (cadr (car (list-ref s i))))
                       (d (car (cdr (list-ref s i))))
                       (ld (car (cdr (list-ref s (- i 1))))))
                   (let ((p (with-state 
                             (colour (sky-colour)) 
                             (build-hex x y root))))
                     (with-primitive p
                                     (surface-texture 
                                      (cond 
                                        ((eq? ld NE) 0)
                                        ((eq? ld E) 1)
                                        ((eq? ld SE) 2))
                                      (cond 
                                        ((eq? d NE) 2)
                                        ((eq? d E) 1)
                                        ((eq? d SE) 0)))))
                   (for ((i (in-range (+ y 1) (+ surface-upper 1))))
                        (when (not (surface-contains? (list x i) s))
                          (with-state 
                           (colour (sky-colour)) 
                           (build-hex x i root))))))))
                         
        (define/public (update update-list time delta)
            ; do the per-frame update on all the things
            (set! absorb-list
                (filter
                    (lambda (absorb)
                        (send absorb update time delta this)
                        (send absorb alive?))
                    absorb-list))
            
            (for-each 
                (lambda (cell)
                    (send (cadr cell) update time delta))
                cells)
            (for-each 
                (lambda (insect)
                    (send (cadr insect) update time delta))
                insects)
            
            ; read the update list, and dispatch based on type
            (for-each
                (lambda (item)
                    (cond
                        ((cell-update? item)
                            (let* 
                                ((pos (cell-update-pos item))
                                    (code (cell-update-code item))
                                    (s (assoc pos cells)))
                                
                                (cond 
                                    (s 
                                        (send (cadr s) new-code code)
                                        (send (cadr s) set-pickup! (cell-update-pickup item))
                                        (send (cadr s) set-upstream-pos! (cell-update-upstream item))
                                        (send (cadr s) set-type! (cell-update-type item)))
                                    (else
                                        (let ((cell (make-object cell-view%)))
                                            (send cell set-pos! pos)
                                            (send cell set-owner! root)
                                            (send cell set-type! (cell-update-type item))
                                            (send cell build code)
                                            (set! cells (cons (list pos cell) cells)))))))
                        
                        ((insect-update? item)
                            (let* ((pos (insect-update-pos item))
                                    (c (assoc pos cells))
                                    (insect (cadr (assoc (insect-update-id item) insects))))
                                ; only need to update if we can see the cell
                                (when c (send insect goto-cell
                                        (cadr c) 
                                        (insect-update-dir item)
                                        (insect-update-t item)))))
                        
                        ((absorb-event? item)
                            (let ((a (make-object absorb-view%)))
                                (send a set-cell! (get-cell-from-pos (absorb-event-cell-pos item)))
                                (send a build root)
                                (add-absorb! a)))
                        
                        ((plant-update? item)
                            (send garden add-plant!
                                (plant-update-id item)
                                (plant-update-desc item)
                                (get-cell-from-pos (plant-update-pos item))
                                (plant-update-type item)))
                        
                        ((init-update? item)
                         (build-surface (init-update-surface-pos-list item)))))
                         
                         
                         
                update-list))
        
        (super-new)))

;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

(define controller%
  (class object%
    (field
     (camera-pos (vector -13 -27 -5)))
    
    (define/public (update)
      (when (key-pressed "a") 
        (set! camera-pos (vadd camera-pos (vector 0.1 0 0))))
      (when (key-pressed "d") 
        (set! camera-pos (vadd camera-pos (vector -0.1 0 0))))
      (when (key-pressed "s") 
        (set! camera-pos (vadd camera-pos (vector 0 0.1 0))))
      (when (key-pressed "w") 
        (set! camera-pos (vadd camera-pos (vector 0 -0.1 0))))
      (when (key-pressed "z") 
        (set! camera-pos (vadd camera-pos (vector 0 0 0.1))))
      (when (key-pressed "x") 
        (set! camera-pos (vadd camera-pos (vector 0 0 -0.1))))
      (set-camera-transform (mtranslate camera-pos))
      (if (mouse-button 1)
          (mouse-over)
          0))
    
   (super-new)))

;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    
(clear)
(clear-colour (bg-colour))
(define hc (make-object honey-comb%))
(define hcv (make-object honey-comb-view%))
(define g (make-object garden%))
(define con (make-object controller%))

(send hc init hex-width hex-height)
(send hcv init)

(send hc seed "dave@fo.am" "knobbly" 45)
(send hc seed "plant00002@fo.am" "lollypop" 30)
(send hc seed "plant00003@fo.am" "nik" 15)

(with-state
 (colour (sky-colour))
 (hint-unlit)
 (translate (vector 0 (- surface-upper 0.6) 0))
 (scale (vector 100 10 1))
 (build-plane))

(define t 0)
(define d 0.04)

(define (animate)
  ;    (set! d (delta))
  (set! t (+ t d))
  (let ((clicked (send con update)))
    (when (not (zero? clicked))
      (let ((pos (send hcv get-pos-from-prim clicked)))
        (when pos 
          (send (send hc get-cell (car pos) (cadr pos)) grow)))))
  (send hcv update (send hc update t d) t d))


;(for ((i (in-range 0 10))) (animate))
(every-frame (animate))