added nutrients (pickups) and worms

hex-ornament/hex-ornament.scm

@@ -1,5 +1,22 @@
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+; 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
 
@@ -23,6 +40,9 @@
             (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)
@@ -63,20 +83,30 @@
 ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 ; 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))
-            (contents '())
+            (pickup #f)
             (connections '(#f #f #f #f #f #f))
             (visible #f)
-            (update-me #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))
@@ -84,6 +114,12 @@
         (define/public (visible?)
             visible)
         
+        (define/public (get-pos)
+            pos)
+        
+        (define/public (set-pos! s)
+            (set! pos s))
+        
         (define/public (get-neighbours)
             neighbours)
         
@@ -93,8 +129,12 @@
         (define/public (set-neighbour! d n)
             (set! neighbours (insert neighbours d n 0)))
         
-        (define/public (get-contents)
+        (define/public (get-pickup)
-            contents)
+            pickup)
+        
+        (define/public (set-pickup! s)
+            (when visible (set! update-me #t))
+            (set! pickup s))
         
         (define/public (get-connections)
             connections)
@@ -119,22 +159,61 @@
             (bool-list->num connections 0 0))
         
         ; returns the first attachable neighbour found, and sets it's connection
-        (define (search/attach-to-neighbour l)
+        (define (search/attach-to-neighbour l dirs)
             (cond 
-                ((null? l) #f)
+                ((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)))))
+                (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))))
+                (let ((dir (search/attach-to-neighbour (shuffle directions) '())))
                     (when dir
-                        ; it's dir is false if we have nothing around us to 
+                        (set-connection! dir #t))
-                        ; connect to, probably shouldn't happen, haven't decided yet
+                    #;(for-each
-                        (set-connection! dir #t)))))
+                        (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)))
 
@@ -145,7 +224,8 @@
         (field
             (cells '())
             (width 0)
-            (height 0))
+            (height 0)
+            (insects '()))
         
         (define/public (get-cell x y)
             (list-ref cells (+ (* y height) x)))
@@ -157,6 +237,9 @@
             ; 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
@@ -167,6 +250,7 @@
             (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))
@@ -182,32 +266,38 @@
                             (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)
+            (send (get-cell x (+ y 1)) set-connection! NW #t))
         
-            #;(let ((seed (get-cell x y)))
+        (define/public (get-update-list time delta)
-                ; set all directions to be connected
-                (for-each
-                    (lambda (d)
-                        (send seed set-connection! d #t))
-                    directions)
             
-                (for-each
+            (append
-                    (lambda (n d)
-                        (send n set-connection! (rdirection d) #t))
-                    (send seed get-neighbours)
-                    directions)))
                 
-        (define/public (get-update-list)
+                ; look for pickups over roots
-            (let ((i -1))
+                (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)
-                        (set! i (+ i 1))
                         (if (send cell update-me?)
-                            (cons (list
+                            (let ((upstream (send cell get-upstream)))
-                                    (list (modulo i width) (quotient i height))
+                                (cons (make-cell-update (send cell get-pos)
-                                    (send cell get-connection-num)) r)
+                                        (send cell get-connection-num)
+                                        (send cell get-pickup)
+                                        (if upstream (send upstream get-pos) #f)) r))
                             r))
                     '()
                     cells)))
@@ -217,6 +307,13 @@
 ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 ; 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
@@ -236,14 +333,81 @@
             (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))
+            (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))
@@ -263,7 +427,7 @@
                             (parent owner)
                             (hint-depth-sort)
                             (opacity 0)
-                            (colour (vector 0.9 1 0.5))
+                            (colour (root-colour))
                             (hint-unlit)
                             (when (odd? (cadr pos))
                                 (translate (vector 0.5 0 0)))
@@ -280,7 +444,7 @@
             (set! root2 (build-prim code)))
         
         (define (update-texture code)
-            (texture (load-texture "textures/roots-ornate.png"))
+            (texture (load-texture (append texpath "roots-ornate.png")))
             (pdata-map!
                 (lambda (t tref)
                     (let ((size (/ 1 8)))
@@ -295,8 +459,26 @@
             (set! root2 (build-prim code))
             (set! t 0)) 
         
-        (define/public (update)
+        (define/public (set-pickup! type)
-            (set! t (+ t 0.04))
+            (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
@@ -316,14 +498,193 @@
         (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 array mapping position to cell-view obs
+            (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! 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 
@@ -331,30 +692,71 @@
                 ((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 (update update-list)
+        (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))
+                    (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)
-                    (let* 
-                        ((pos (car item))
-                            (code (cadr item))
-                            (s (assoc pos cells)))
                     (cond
-                            (s (send (cadr s) new-code code))
+                        ((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)))
@@ -362,28 +764,34 @@
 ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
 (clear)
-(clear-colour (vector 0.5 0.2 0.1))
+(clear-colour (bg-colour))
 (clear-texture-cache)
 (show-axis 0)
-(set-camera-transform (mtranslate (vector 0 0 -8)))
+(set-camera-transform (mtranslate (vector -10 -6 -8)))
 
 (define hc (make-object honey-comb%))
 (define hcv (make-object honey-comb-view%))
 
-(send hc init 100 100)
+(send hc init 20 20)
 
 (with-state
-    (translate (vector -50 -42.5 0))
+    ;    (translate (vector -50 -42.5 0))
+    ;    (translate (vector -10 -8.5 0))
     (send hcv init))
 
-(send hc seed 50 50)
+(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)))
+    (send hcv update (send hc get-update-list t d) t d))
 
 (every-frame (animate))