groworld/hex-ornament/hex-ornament.scm

;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; hex groworld game : fluxus version

(require scheme/class)

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

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

(define (bg-colour) (vector 0.5 0.2 0.1))
(define (worm-colour) (hsv->rgb (vector 0.1 (rndf) 0.5)))
(define (root-colour) (vector 0.6 0.5 0.5))
(define (pickup-colour) (hsv->rgb (vector 0.1 (rndf) 1)))
(define (absorb-colour) (hsv->rgb (vector 0.1 (rndf) 1)))

(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)))

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

; messages passed between the logic and the view
(define-struct cell-update (pos code pickup upstream))
(define-struct insect-update (id pos dir t))
(define-struct absorb-event (cell-pos type))

(define comb-cell%
    (class object%
        (field
            (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 (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)))
                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! 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)
            (t (+ 0.5 (rndf))))
        
        (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 t))
                        (set! cell (cadr m))
                        (make-insect-update id (send cell get-pos) (car m) t)))
                (else #f)))
        
        (super-new)))

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

(define honey-comb%
    (class object%
        (field
            (cells '())
            (width 0)
            (height 0)
            (insects '()))
        
        (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))))))))
        
        (define/public (seed x y)
            (send (get-cell x y) set-connection! SE #t)
            (send (get-cell x (+ y 1)) set-connection! NW #t))
        
        (define/public (get-update-list time delta)
            
            (append
                
                ; 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)))
                                (cons (make-cell-update (send cell get-pos)
                                        (send cell get-connection-num)
                                        (send cell get-pickup)
                                        (if upstream (send upstream get-pos) #f)) r))
                            r))
                    '()
                    cells)))
        
        (super-new)))

;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; graphics and interaction

; more odds and sods...

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


(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-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))

; 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))))

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

(define cell-view%
    (class object%
        (field
            (root 0)
            (root2 0)
            (pickup-root 0)
            (t 0)
            (pos '(0 0))
            (owner 0)
            (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-pos)
            pos)
        
        (define/public (set-pos! s)
            (set! pos s))
        
        (define (build-prim code)
            (let ((p (with-state    
                            ;(hint-wire)
                            (parent owner)
                            (hint-depth-sort)
                            (opacity 0)
                            (colour (root-colour))
                            (hint-unlit)
                            (when (odd? (cadr pos))
                                (translate (vector 0.5 0 0)))
                            (translate (vector (car pos) (* 0.85 (cadr pos)) (* 0.001 (rndf))))
                            (scale 0.57)
                            (rotate (vector 0 0 90))
                            (build-ngon 6))))
                (with-primitive p
                    (update-texture code))
                p))
        
        (define/public (build code)            
            (set! root (build-prim code))
            (set! root2 (build-prim code)))
        
        (define (update-texture code)
            (texture (load-texture (append texpath "roots-ornate.png")))
            (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? root2)) 
                (destroy root2)
                (with-primitive root (opacity 1)))
            (set! root2 (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 owner)
                        (translate (with-primitive root (vtransform (vector 0 0 0) (get-transform))))
                        (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 root
                    (opacity (- 1 t)))
                (with-primitive root2
                    (opacity t)))
            
            (when (> t 1) 
                (with-primitive root
                    (opacity 1))
                
                (when (not (zero? root2))
                    (destroy root)
                    (set! root root2)
                    (set! root2 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))     
        
        (define/override (build)
            (set! root (build-ribbon 50))
            (with-primitive root 
                (hide 1)
                (translate (vector 0 0 -0.1))
                (hint-unlit)
                (set! hidden #t)
                (colour (worm-colour))
                (texture (load-texture (append texpath "worm.png")))
                (let ((width (+ 0.05 (* 0.1 (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? from (vector 0 0 0)))
                    (set! hidden #t)
                    (with-primitive root (hide 1)))
                (else
                    (with-primitive root
                        (when hidden
                            (set! hidden #f)
                            (pdata-map!
                                (lambda (p)
                                    from)
                                "p"))
                        (hide 0)
                        ;(identity)
                        (let ((h (hermite-tangent (/ t d) from to (vmul from-dir 2) (vmul to-dir 2))))
                            ;(translate (car h))
                            (pdata-set! "p" (- (pdata-size) 1) (car h))
                            
                            
                            (for ((i (in-range 0 (- (pdata-size) 1))))
                                (pdata-set! "p" i (pdata-ref "p" (+ i 1))))))))
            (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 (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
                    (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.75 (+ 1 (rndf)))))
                                (vector s s 1 0.3)))
                        "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 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
        
        (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 p l)
            (cond 
                ((null? l) #f)
                ((eq? (send (cadr (car l)) get-root) p) (caar l))
                (else (get-pos-from-prim p (cdr l)))))
        
        (define/public (get-cell-from-pos pos)
            (cadr (assoc pos cells)))
        
        (define/public (deal-with-input)
            (if (mouse-button 1)
                (get-pos-from-prim (mouse-over) cells)
                #f))                                           
        
        (define/public (add-absorb! s)
            (set! absorb-list (cons s absorb-list)))
        
        (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)))
                                    (else
                                        (let ((cell (make-object cell-view%)))
                                            (send cell set-pos! pos)
                                            (send cell set-owner! root)
                                            (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)))))
                update-list))
        
        (super-new)))

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

(clear)
(clear-colour (bg-colour))
(clear-texture-cache)
(show-axis 0)
(set-camera-transform (mtranslate (vector -10 -6 -8)))

(define hc (make-object honey-comb%))
(define hcv (make-object honey-comb-view%))

(send hc init 20 20)

(with-state
    ;    (translate (vector -50 -42.5 0))
    ;    (translate (vector -10 -8.5 0))
    (send hcv init))

(send hc seed 10 10)
;(send (send hc get-cell 50 52) grow)
;(send (send hc get-cell 49 53) grow)

(define t 0)
(define d 0.04)

(define (animate)
;    (set! d (delta))
    (set! t (+ t d))
    (let ((clicked (send hcv deal-with-input)))
        (when clicked
            (send (send hc get-cell (car clicked) (cadr clicked)) grow)))
    (send hcv update (send hc get-update-list t d) t d))

(every-frame (animate))