added pluggables code, refactored the structure and first pass garden + plants

hex-ornament/hex-ornament.scm

@@ -1,6 +1,8 @@
+;#lang scheme
 ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 ; hex ornament/groworld game : fluxus version
 
+;(require fluxus-016/drflux.ss)
 (require scheme/class)
 
 ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -12,7 +14,7 @@
 (define (vec3->vec4 v a)
     (vector (vx v) (vy v) (vz v) a))
 
-(define (bg-colour) (vector 0.5 0.2 0.1))
+(define (bg-colour) (vector 0.2 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)))
@@ -84,17 +86,59 @@
         ((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 "11")) (list)))
+            ((eq? num-children 1) (list "1-1" (list (make-random-plant (+ depth 1)))))
+            ((eq? num-children 2) (list "2-1" (list (make-random-plant (+ depth 1))
+                        (make-random-plant (+ depth 1)))))
+            ((eq? num-children 3) (list "3-1" (list (make-random-plant (+ depth 1))
+                        (make-random-plant (+ depth 1)) (make-random-plant (+ depth 1)))))
+            ((eq? num-children 4) (list "4-1" (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-1" (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                    view side
+;     ----------                    ---------
+;   * no fluxus code        |     * no game code
+;                           |
+;     comb-cell             |       comb-cell-view
+;          \                |          /
+;  insect   \               |         /   insect-view
+;        \   \          messages     /       /
+;         honey-comb  ===========> honey-comb-view
+;           /               |           \
+;     garden                |         garden-view
+;
+;   
+;
+;
+
 ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 ; logic
 
-; messages passed between the logic and the view
+; messages passed between the honey-comb 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-struct plant-update (id desc))
 
 (define comb-cell%
     (class object%
         (field
+            (id #f)   ; id of the owner plant
             (pos '())
             (neighbours '(#f #f #f #f #f #f))
             (pickup #f)
@@ -103,6 +147,12 @@
             (update-me #f)
             (upstream #f)) ; the cell we are connected to (if we are)
         
+        (define/public (get-id)
+            id)
+        
+        (define/public (set-id! s)
+            (set! id s))
+        
         (define/public (update-me?)
             (let ((r update-me))
                 (set! update-me #f)
@@ -168,6 +218,7 @@
                 ((null? l) dirs)
                 ((not (send (get-neighbour (car l)) no-connections?))
                     (send (get-neighbour (car l)) set-connection! (rdirection (car l)) #t)
+                    (send (get-neighbour (car l)) set-id! id)
                     (set! upstream (get-neighbour (car l)))
                     #;(search/attach-to-neighbour (cdr l) (cons (car l) dirs))
                     (car l))
@@ -221,6 +272,60 @@
         
         (super-new)))
 
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+(define plant%
+    (class object%
+        (init-field
+            (id "default")
+            (pos '())) ; the seed position
+        
+        (field
+            (update-me #t)
+            (desc (make-random-plant 3)))
+        
+        (define/public (get-id)
+            id)
+        
+        (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)) r)
+                        r))
+                '()
+                plants))
+        
+        (super-new)))
+
 ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
 (define honey-comb%
@@ -229,7 +334,8 @@
             (cells '())
             (width 0)
             (height 0)
-            (insects '()))
+            (insects '())
+            (garden (make-object garden%)))
         
         (define/public (get-cell x y)
             (list-ref cells (+ (* y height) x)))
@@ -269,14 +375,21 @@
                         (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)
+        (define/public (seed id x y)
+            (send garden add-plant (make-object plant% id (list x y)))
+            (send (get-cell x y) set-connection! SE #t)
+            (send (get-cell x y) set-id! id)
+            (send (get-cell x (+ y 1)) set-connection! NW #t)
+            (send (get-cell x (+ y 1)) set-id! id))
+        
+        (define/public (update time delta)
             
             (append
                 
+                ; get updates from the garden
+                (send garden update)
+                
                 ; look for pickups over roots
                 (foldl
                     (lambda (cell r)
@@ -308,7 +421,7 @@
         
         (super-new)))
 
-;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+;======================================================================
 ; graphics and interaction
 
 ; more odds and sods...
@@ -394,6 +507,145 @@
     (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)
+    (let ((ret (assoc id connection-cache)))
+        (cond 
+            (ret (cdr ret))
+            (else
+                (let* ((tex (load-primitive (string-append "textures/comp-cp-" id ".png")))
+                        (connections (with-primitive tex (convert-to-pos (find-centroids 0 '())))))
+                    (set! connection-cache (cons (cons id connections) connection-cache))
+                    (destroy tex)
+                    connections)))))
+
+
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+; a plant component
+
+(define-struct component (root (col #:mutable) children))
+
+(define (build-component id col children)
+    (cond 
+        ((null? children) 
+            (let ((root (with-state
+                            (translate (vector 0 0.5 (* 0.01 (rndf))))
+                            (hint-none)
+                            (hint-solid)
+                            (hint-unlit)
+                            (hint-depth-sort)
+                            (texture (load-texture (string-append "textures/comp-" id ".png")))
+                            (build-plane))))
+                (make-component root col '())))
+        (else
+            (let* ((connection-list (get-connection-list id))
+                    (root (with-state
+                            (hint-depth-sort)
+                            (translate (vector 0 0.5 (* 0.01 (rndf))))
+                            ;                            (rotate (vector 0 0 90))
+                            (texture (load-texture (string-append "textures/comp-" id ".png")))
+                            (build-plane)))
+                    (comp (make-component root col
+                            (map
+                                (lambda (child connection)
+                                    (with-state                                        
+                                        (parent root)
+                                        (translate (vadd connection (vector 0 0 (* 0.01 (rndf)))))
+                                        (rotate (vector 0 0 (2dvec->angle 
+                                                    (vx connection) (- (vy connection) 0.5))))
+                                        (rotate (vector 0 0 0))
+                                        (build-component (car child) 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%
@@ -668,6 +920,37 @@
         
         (super-new)))
 
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+(define plant-view%
+    (class object%
+        (field 
+            (root 0)
+            (desc '()))
+        
+        (define/public (set-desc! s)
+            (set! desc s)
+            
+            (when (not (zero? root))
+                (destroy root))
+            
+            ; build the plant
+            )
+        
+        
+        (super-new)))
+
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+(define garden-view%
+    (class object%
+        (field 
+            (plants '()))
+        
+        (define/public (add-plant! id plant)
+            (set! plants (cons (list id plant) plants)))
+        
+        (super-new)))
 
 ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
@@ -677,7 +960,8 @@
             (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
+            (absorb-list '()) ; just a list of absorb effects
+            (garden-view (make-object garden-view%)))
         
         (define/public (init)
             (set! root (build-locator))
@@ -689,7 +973,8 @@
                 (for-each 
                     (lambda (insect)
                         (send (cadr insect) build))
-                    insects)))
+                    insects))
+            (build-surface))
         
         (define (get-pos-from-prim p l)
             (cond 
@@ -708,6 +993,52 @@
         (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 "surface2.png"))))
+        
+        (define (make-surface lev top len l)
+            (cond 
+                ((zero? len) l)
+                (else (make-surface 
+                        (if (zero? (random 2)) 
+                            (if (< lev top) (+ lev 1) lev)
+                            (if (> lev (- top 1)) (- lev 1) lev))
+                        top (- len 1) (cons lev l)))))
+        
+        (define/public (build-surface)
+            (let ((s (make-surface 12 13 20 '())))
+                (for ((i (in-range 1 (- (length s) 1))))
+                    (let ((x i) (y (list-ref s i)) 
+                            (yb (list-ref s (- i 1))) 
+                            (ya (list-ref s (+ i 1))))
+                        
+                        (let ((p (with-state    
+                                        (parent root)
+                                        (hint-unlit)
+                                        (when (odd? y)
+                                            (translate (vector 0.5 0 0)))
+                                        (translate (vector x (* 0.85 y) (* 0.001 (rndf))))
+                                        (scale 0.57)
+                                        (rotate (vector 0 0 90))
+                                        (build-ngon 6))))
+                            (with-primitive p
+                                (surface-texture 
+                                    (cond 
+                                        ((> yb y) 0)
+                                        ((< yb y) 2)
+                                        (else 1))
+                                    (cond 
+                                        ((> ya y) 0)
+                                        ((< ya y) 2)
+                                        (else 1)))))))))
+        
+        
         (define/public (update update-list time delta)
             
             ; do the per-frame update on all the things
@@ -761,13 +1092,16 @@
                             (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)))))
+                                (add-absorb! a)))
+                        ((plant-update? item)
+                            (printf "got a plant update!~n"))))
                 update-list))
         
         (super-new)))
 
 ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
+
 (clear)
 (clear-colour (bg-colour))
 (clear-texture-cache)
@@ -776,6 +1110,7 @@
 
 (define hc (make-object honey-comb%))
 (define hcv (make-object honey-comb-view%))
+(define g (make-object garden%))
 
 (send hc init 20 20)
 
@@ -784,7 +1119,7 @@
     ;    (translate (vector -10 -8.5 0))
     (send hcv init))
 
-(send hc seed 10 10)
+(send hc seed "dave@fo.am" 10 10)
 ;(send (send hc get-cell 50 52) grow)
 ;(send (send hc get-cell 49 53) grow)
 
@@ -792,11 +1127,11 @@
 (define d 0.04)
 
 (define (animate)
-;    (set! d (delta))
+    ;    (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))
+    (send hcv update (send hc update t d) t d))
 
 (every-frame (animate))