plants added, worms better

hex-ornament/hex-ornament.scm

@@ -8,17 +8,17 @@
 ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 ; tweakables
 
-(define num-insects 20)
+(define num-insects 50)
 (define pickup-drop-probability 10)
 
 (define (vec3->vec4 v a)
     (vector (vx v) (vy v) (vz v) a))
 
-(define (bg-colour) (vector 0.2 0.2 0.1))
+(define (bg-colour) (vector 0.9 0.8 0.7))
 (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) (vec3->vec4 (hsv->rgb (vector 0.1 (rndf) 1)) 0.2))
+(define (absorb-colour) (vec3->vec4 (hsv->rgb (vector (rndf) 0.2 (+ 0.6 (rndf)))) 0.2))
 
 ;(define texpath "")
 (define texpath "textures/")
@@ -133,7 +133,7 @@
 (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-struct plant-update (id desc pos))
 
 (define comb-cell%
     (class object%
@@ -244,7 +244,7 @@
         (init-field
             (id 0)
             (cell 0)
-            (t (+ 0.5 (rndf))))
+            (d (+ 5.5 (* 2 (rndf)))))
         
         (field
             (next-update 0))
@@ -265,9 +265,9 @@
                     (let ((m (move cell)))
                         (when (zero? (random pickup-drop-probability))
                             (send cell set-pickup! 'default))
-                        (set! next-update (+ time t))
+                        (set! next-update (+ time d))
                         (set! cell (cadr m))
-                        (make-insect-update id (send cell get-pos) (car m) t)))
+                        (make-insect-update id (send cell get-pos) (car m) d)))
                 (else #f)))
         
         (super-new)))
@@ -282,7 +282,7 @@
         
         (field
             (update-me #t)
-            (desc (make-random-plant 3)))
+            (desc (make-random-plant 0)))
         
         (define/public (get-id)
             id)
@@ -319,7 +319,8 @@
                 (lambda (plant r)
                     (if (send (cadr plant) update-me?)
                         (cons (make-plant-update (car plant) 
-                                (send (cadr plant) get-desc)) r)
+                                (send (cadr plant) get-desc)
+                                (send (cadr plant) get-pos)) r)
                         r))
                 '()
                 plants))
@@ -387,9 +388,6 @@
             
             (append
                 
-                ; get updates from the garden
-                (send garden update)
-                
                 ; look for pickups over roots
                 (foldl
                     (lambda (cell r)
@@ -417,7 +415,10 @@
                                         (if upstream (send upstream get-pos) #f)) r))
                             r))
                     '()
-                    cells)))
+                    cells)
+                
+                ; get updates from the garden
+                (send garden update)))
         
         (super-new)))
 
@@ -428,7 +429,7 @@
 
 (define (direction-normal d) 
     (let ((a (* 2 1.141 60)))
-        (vector (sin (* a d)) (cos (* a d)) 0)))
+        (vmul (vector (sin (* a d)) (cos (* a d)) 0) -1)))
 
 
 (define (build-ngon n)
@@ -584,6 +585,7 @@
                 (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))
+                    ;(printf "~a:~a~n" id (length connections))
                     (destroy tex)
                     connections)))))
 
@@ -606,27 +608,30 @@
                             (build-plane))))
                 (make-component root col '())))
         (else
-            (let* ((connection-list (get-connection-list id))
+            (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)))
+                            (build-plane))))
-                    (comp (make-component root col
+                (when (not (eq? (length connection-list) (length children)))
-                            (map
+                    (printf "something wrong: ~a children:~a connections:~a~n" id (length children) (length connection-list) ))
-                                (lambda (child connection)
+                
-                                    (with-state                                        
+                (let ((comp (make-component root col
-                                        (parent root)
+                                (map
-                                        (translate (vadd connection (vector 0 0 (* 0.01 (rndf)))))
+                                    (lambda (child connection)
-                                        (rotate (vector 0 0 (2dvec->angle 
+                                        (with-state                                        
-                                                    (vx connection) (- (vy connection) 0.5))))
+                                            (parent root)
-                                        (rotate (vector 0 0 0))
+                                            (translate (vadd connection (vector 0 0 (* 0.01 (rndf)))))
-                                        (build-component (car child) col (cadr child))))
+                                            (rotate (vector 0 0 (2dvec->angle 
-                                children
+                                                        (vx connection) (- (vy connection) 0.5))))
-                                connection-list))))
+                                            (rotate (vector 0 0 0))
-                (with-primitive root (apply-transform))
+                                            (build-component (car child) col (cadr child))))
-                comp))))
+                                    children
+                                    connection-list))))
+                    (with-primitive root (apply-transform))
+                    comp)))))
 
 (define (random-leaf component)
     (cond
@@ -652,7 +657,8 @@
     (class object%
         (field
             (root 0)
-            (root2 0)
+            (tile1 0)
+            (tile2 0)
             (pickup-root 0)
             (t 0)
             (pos '(0 0))
@@ -671,6 +677,9 @@
         (define/public (get-root)
             root)
         
+        (define/public (get-tile)
+            tile1)
+        
         (define/public (get-pos)
             pos)
         
@@ -680,14 +689,12 @@
         (define (build-prim code)                        
             (let ((p (with-state    
                             ;(hint-wire)
-                            (parent owner)
+                            (parent root)                
                             (hint-depth-sort)
                             (opacity 0)
                             (colour (root-colour))
                             (hint-unlit)
-                            (when (odd? (cadr pos))
+                            (translate (vector 0 0 (* 0.001 (rndf))))
-                                (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))))
@@ -696,8 +703,15 @@
                 p))
         
         (define/public (build code)            
-            (set! root (build-prim code))
+            (set! root (with-state
-            (set! root2 (build-prim code)))
+                    (parent owner)
+                    (when (odd? (cadr pos))
+                        (translate (vector 0.5 0 0)))
+                    (translate (vector (car pos) (* 0.85 (cadr pos)) 0))
+                    (build-locator)))
+            
+            (set! tile1 (build-prim code))
+            (set! tile2 (build-prim code)))
         
         (define (update-texture code)
             (texture (load-texture (string-append texpath "roots-ornate.png")))
@@ -709,10 +723,10 @@
                 "t" "tref"))
         
         (define/public (new-code code)      
-            (when (not (zero? root2)) 
+            (when (not (zero? tile2)) 
-                (destroy root2)
+                (destroy tile2)
-                (with-primitive root (opacity 1)))
+                (with-primitive tile1 (opacity 1)))
-            (set! root2 (build-prim code))
+            (set! tile2 (build-prim code))
             (set! t 0)) 
         
         (define/public (set-pickup! type)
@@ -725,8 +739,7 @@
                     (set! pickup-root 0))
                 (set! pickup-root (with-state
                         (colour (pickup-colour))
-                        (parent owner)
+                        (parent root)
-                        (translate (with-primitive root (vtransform (vector 0 0 0) (get-transform))))
                         (build-torus 0.03 0.2 10 10)))))
         
         (define/public (update time delta)
@@ -737,19 +750,19 @@
                     (rotate (vector 0 2 0))))
             
             (when (< t 1)
-                (with-primitive root
+                (with-primitive tile1
                     (opacity (- 1 t)))
-                (with-primitive root2
+                (with-primitive tile2
                     (opacity t)))
             
             (when (> t 1) 
-                (with-primitive root
+                (with-primitive tile1
                     (opacity 1))
                 
-                (when (not (zero? root2))
+                (when (not (zero? tile2))
-                    (destroy root)
+                    (destroy tile1)
-                    (set! root root2)
+                    (set! tile1 tile2)
-                    (set! root2 0))))
+                    (set! tile2 0))))
         
         (super-new)))
 
@@ -806,10 +819,24 @@
     (class insect-view%
         (inherit-field root from to from-dir to-dir t d)      
         
-        (field (hidden #t))     
+        (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 50))
+            (set! root (build-ribbon 20))
             (with-primitive root 
                 (hide 1)
                 (translate (vector 0 0 -0.1))
@@ -817,7 +844,7 @@
                 (set! hidden #t)
                 (colour (worm-colour))
                 (texture (load-texture (string-append texpath "worm.png")))
-                (let ((width (+ 0.05 (* 0.1 (rndf)))))
+                (let ((width (+ 0.05 (* 0.05 (rndf)))))
                     (pdata-index-map!
                         (lambda (i w)
                             width #;(+ 0.05 (* (abs (sin (* i 0.5))) 0.1)))
@@ -828,29 +855,30 @@
                     "c")))
         
         (define/override (update time delta)
-            (cond ((or (zero? d) (> t d) (equal? from (vector 0 0 0)))
+            (cond ((or (zero? d) (> t d) (equal? from2 (vector 0 0 0)))
                     (set! hidden #t)
                     (with-primitive root (hide 1)))
                 (else
-                    (with-primitive root
+                    (let ((t (/ t d))) ; normalise time
-                        (when hidden
+                        (with-primitive root
-                            (set! hidden #f)
+                            (when hidden
-                            (pdata-map!
+                                (set! hidden #f)
-                                (lambda (p)
+                                (pdata-map!
-                                    from)
+                                    (lambda (p)
-                                "p"))
+                                        from)
-                        (hide 0)
+                                    "p"))
-                        ;(identity)
+                            (hide 0)
-                        (let ((h (hermite-tangent (/ t d) from to (vmul from-dir 2) (vmul to-dir 2))))
+                            (pdata-index-map!
-                            ;(translate (car h))
+                                (lambda (i p)
-                            (pdata-set! "p" (- (pdata-size) 1) (car h))
+                                    (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)))
     
-                            (for ((i (in-range 0 (- (pdata-size) 1))))
+    (super-new)))
-                                (pdata-set! "p" i (pdata-ref "p" (+ i 1))))))))
-            (set! t (+ t delta)))
-        
-        (super-new)))
 
 ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
@@ -928,14 +956,20 @@
             (root 0)
             (desc '()))
         
-        (define/public (set-desc! s)
+        (define/public (build s)
             (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.3))
+                (build-component "1-1" (vector 1 1 1) (list desc))))
         
         
         (super-new)))
@@ -947,8 +981,12 @@
         (field 
             (plants '()))
         
-        (define/public (add-plant! id plant)
+        (define/public (add-plant! id desc hex)
-            (set! plants (cons (list id plant) plants)))
+            (let ((plant (make-object plant-view%)))
+                (with-state
+                    (parent (send hex get-root))                
+                    (send plant build desc)
+                    (set! plants (cons (list id plant) plants)))))
         
         (super-new)))
 
@@ -961,7 +999,7 @@
             (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-view (make-object garden-view%)))
+            (garden (make-object garden-view%)))
         
         (define/public (init)
             (set! root (build-locator))
@@ -979,7 +1017,7 @@
         (define (get-pos-from-prim p l)
             (cond 
                 ((null? l) #f)
-                ((eq? (send (cadr (car l)) get-root) p) (caar l))
+                ((eq? (send (cadr (car l)) get-tile) p) (caar l))
                 (else (get-pos-from-prim p (cdr l)))))
         
         (define/public (get-cell-from-pos pos)
@@ -1094,7 +1132,10 @@
                                 (send a build root)
                                 (add-absorb! a)))
                         ((plant-update? item)
-                            (printf "got a plant update!~n"))))
+                            (send garden add-plant!
+                                (plant-update-id item)
+                                (plant-update-desc item)
+                                (get-cell-from-pos (plant-update-pos item))))))
                 update-list))
         
         (super-new)))
@@ -1106,7 +1147,7 @@
 (clear-colour (bg-colour))
 (clear-texture-cache)
 (show-axis 0)
-(set-camera-transform (mtranslate (vector -10 -6 -8)))
+(set-camera-transform (mtranslate (vector -10 -7 -8)))
 
 (define hc (make-object honey-comb%))
 (define hcv (make-object honey-comb-view%))