nutrient absorbing and twig shrinking, with bugs

plant-eyes/logic.ss

@@ -6,7 +6,7 @@
 (define branch-width-reduction 0.5)
 (define twig-jitter 0.1)
 (define branch-jitter 0.5)
-(define max-twig-points 15)
+(define max-twig-points 10)
 (define start-twig-dist 0.05)
 (define start-twig-width 0.1)
 (define default-max-twigs 10)
@@ -43,11 +43,12 @@
         (else (cons (car l) (flatten (cdr l))))))
 
     (define/pubment (update) ; need to augement this if we have child logic objects, 
-      (let ((m messages))    ; and call update on them too.
+      (let ((l (inner '() update)) ; and call update on them too.
+	        (m messages))    
         (set! messages '())        
          (append
           m
-          (flatten (inner '() update))))) ; the augmented method gets called here
+          (flatten l)))) ; the augmented method gets called here
     
     (super-new)))
 
@@ -85,6 +86,9 @@
     
     (define/public (set-id! s)
       (set! id s))
+
+    (define/public (get-energy-level)
+      energy-level)
     
     (define/public (get-type)
       type)
@@ -248,14 +252,22 @@
     ; returns true if it's succeded
     (define/public (check-nutrient nutrient) 
       ; check each point in our twig      
-      (let* ((found (foldl
+      (let* ((i -1) (found (foldl
                     (lambda (point found)
+					  (set! i (+ i 1))
                       ; if we havent found anything yet and it's intersecting
                       (cond ((and (not found) (< (vdist (vadd (send plant get-pos) point) 
                                                   (send nutrient get-pos))
                                                  (+ width (send nutrient get-size))))
                              (set! energy-level (+ energy-level 1))
                              (send nutrient deplete)
+							 (send-message 'deplete-nutrient
+         						(list 
+								  (list 'plant-id (send plant get-id))
+          					      (list 'nutrient-id (send nutrient get-id))
+ 		                          (list 'amount nutrient-field-deplete-loss)
+								  (list 'twig-id id)
+								  (list 'twig-point i)))
                              #t)
                             (else #f)))
                     #f
@@ -273,6 +285,13 @@
      
     (define/augment (update)
 	  (set! energy-level (- energy-level twig-energy-loss))
+	  (printf "~a~n" energy-level)
+	  (when (< energy-level 0) 
+	    (printf "sending~n")
+	    (send-message 'shrink-twig
+		   	(list (list 'plant-id (send plant get-id))
+			      (list 'twig-id id))))
+
       (append
        (map
         (lambda (ornament)
@@ -345,13 +364,17 @@
 ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 ; nutrient fields are areas where nutrients exist
 
-(define nutrient-field-logic%
+(define nutrient-logic%
   (class game-logic-object%
     (init-field
+	 (id #f)
      (pos (vector 0 0 0))
 	 (size 0))
     
-    (define/public (get-pos)
+    (define/public (get-id)
+      id)
+    
+	(define/public (get-pos)
       pos)
     
 	(define/public (deplete)
@@ -428,26 +451,19 @@
       (foldl
        (lambda (twig found)
          (if (not found)
-             (send twig check-pickup pickup)
+             (send (cadr twig) check-pickup pickup)
              #f))
        #f
        twigs))
-    
+ 
-    (define/public (destroy-twig twig)
+    (define/public (check-nutrient nutrient) 
-      (send-message 'destroy-branch-twig (list
+      (foldl
-                                   (list 'plant-id id)
+       (lambda (twig found)
-                                   (list 'twig-id (send twig get-id))
+         (if (not found)
-                                   )))
+             (send (cadr twig) check-nutrient nutrient)
-
+             #f))
-    ; a util to keep a fixed size list of twigs, calling destroy twig when needed.
+       #f
-    (define (cons-twig thing in count out)
+       twigs))  
-      (cond 
-        ((null? in) 
-         (cons thing out))
-        ((zero? count)
-         (destroy-twig (car in))
-         (cons thing out))
-        (else (cons-twig thing (cdr in) (- count 1) (append out (list (car in)))))))
     
     (define/public (add-twig twig)
       (send twig set-id! (get-next-twig-id))
@@ -458,7 +474,7 @@
                                 (list 'plant-id id)
                                 (list 'amount grow-amount)))
       (send-message 'new-twig (send twig get-desc-list))      
-      (set! twigs (cons-twig twig twigs max-twigs '())))
+      (set! twigs (cons (list (send twig get-id) twig) twigs)))
 
     (define/public (add-sub-twig ptwig point-index dir)
           (set! leader-twig (send ptwig add-twig point-index dir))
@@ -466,16 +482,16 @@
     
     (define/public (get-random-twig)
       (if (not (null? twigs))
-          (send (choose twigs) get-random-twig)
+          (send (cadr (choose twigs)) get-random-twig)
           #f))
     
     (define/public (get-twig-from-dir dir)
       (let ((dir (vnormalise dir)))
       (cadr (foldl
              (lambda (twig l)
-               (let ((d (vdot (vnormalise (send twig get-dir)) dir)))
+               (let ((d (vdot (vnormalise (send (cadr twig) get-dir)) dir)))
                  (if (> d (car l))
-                     (list d twig)
+                     (list d (cadr twig))
                      l)))
              (list -99 #f)
              twigs))))
@@ -491,7 +507,7 @@
               (append
                (map
                 (lambda (twig)
-                  (send twig serialise))
+                  (send (cadr twig) serialise))
                 twigs))))
     
     (define/augment (update)      
@@ -519,9 +535,17 @@
                                         point-index))
                                      (else
                                       (error "property not understood " property)))))))))
+									  
+									  
+	   (for-each
+	     (lambda (twig)
+		 	(when (< (send (cadr twig) get-energy-level) 0)
+			   (set! twigs (assoc-remove (car twig) twigs))))
+		    twigs)
+			 
        (map
         (lambda (twig)
-          (send twig update))
+          (send (cadr twig) update))
         twigs))
     
     (super-new)))
@@ -533,6 +557,7 @@
     (field
      (plants '())
      (pickups '())
+	 (nutrients '())
      (player #f))
    
     (inherit send-message)
@@ -545,7 +570,15 @@
            (add-pickup (make-object pickup-logic% i (list-ref pickup 0)
                                      (list-ref pickup 2)))
            (set! i (+ i 1)))
-        pickups))))
+        pickups)))
+		
+      (let ((i 0))
+      (for-each
+          (lambda (nutrient)
+           (add-nutrient (make-object nutrient-logic% i (list-ref nutrient 2)
+                                     (list-ref nutrient 3)))
+           (set! i (+ i 1)))
+		   (list-ref world-list 2))))
         
     (define/public (add-player plant)
       (printf "new player plant added ~a~n" (send plant get-id))
@@ -574,6 +607,14 @@
                                        (list 'type (send pickup get-type))
                                        (list 'pos (send pickup get-pos))))
       (set! pickups (cons pickup pickups)))
+
+    (define/public (add-nutrient nutrient)
+                            (send-message 'new-nutrient
+                                      (list
+                                       (list 'nutrient-id (send nutrient get-id))
+                                       (list 'pos (send nutrient get-pos))
+                                       (list 'size (send nutrient get-size))))
+      (set! nutrients (cons nutrient nutrients)))
    
     (define/public (serialise)
       (send player serialise))
@@ -588,7 +629,15 @@
           (lambda (plant)
             (send plant check-pickup pickup))
           plants))
-       pickups)      
+       pickups)
+	   
+	  (for-each
+       (lambda (nutrient)
+         (for-each 
+          (lambda (plant)
+            (send plant check-nutrient nutrient))
+          plants))
+       nutrients)
       
       ; remove the pickups that have been 'picked up'
       (set! pickups (filter 
@@ -596,9 +645,14 @@
                        (not (send pickup picked-up?)))
                      pickups))
       
-       (map
+       (append
+	    (map
         (lambda (plant)
           (send plant update))
-        plants))
+        plants)
+		(map
+        (lambda (nutrient)
+          (send nutrient update))
+        nutrients)))
     
     (super-new)))

plant-eyes/plant-eyes.scm

@@ -36,10 +36,12 @@
 ;   side - eg. lsystem, or different methods per plant (or per twig even)
 
 (define world-list (let* ((f (open-input-file "world.txt"))                            
-                               (o (list (read f)(read f)(read f))))
+                               (o (list (read f)(read f)(read f)(read f))))
                       (close-input-port f)
                       o))
 
+(printf "~a~n" (length world-list))
+
 (clear)
 (clear-shader-cache)
 

plant-eyes/view.ss

@@ -4,7 +4,7 @@
 
 ; the fluxus code to make things look the way they do
 
-(define debug-messages #f) ; prints out all the messages sent to the renderer
+(define debug-messages #t) ; prints out all the messages sent to the renderer
 (define audio-on #t)
 
 (define (ornament-colour) (vector 0.5 1 0.4))
@@ -245,6 +245,34 @@
 
 ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
+(define nutrient-view%
+  (class object%
+    (init-field
+     (id -1)
+     (pos (vector 0 0 0))
+	 (size 0))
+    
+    (field
+     (root (with-state
+            (translate pos)
+			(scale size)
+            (build-sphere 10 10))))
+    
+	(define/public (deplete amount)
+      (when (> size 0)
+        (set! size (- size amount))
+	    (with-primitive root
+	       (identity)
+		   (translate pos)
+	       (scale size))))
+	
+    (define/public (update t d)
+      0)
+    
+    (super-new)))
+
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
 (define twig-view%
     (class object%
       (init-field
@@ -265,11 +293,16 @@
        (markers '())
        (grow-t -1)
        (marker-destroy-t 0)
-       (grow-speed default-grow-speed))
+       (grow-speed default-grow-speed)
+	   (shrink-t 0)
+	   (delme #f))
       
       (define/public (get-id)
         id)
       
+	  (define/public (delme?)
+	    delme)
+	  
       (define/public (get-dir)
         dir)
       
@@ -315,6 +348,9 @@
       (define/public (start-growing)
         (set! grow-t 0)
         (set! markers (cons (build-locator) markers)))
+		
+	  (define/public (start-shrinking)
+	    (set! shrink-t (if (growing?) grow-t grow-overshoot)))
         
       (define/pubment (add-point point width)
 	  			(play-sound "snd/event01.wav" point (+ 0.1 (rndf)) 0.3) 
@@ -355,7 +391,13 @@
          (lambda (ornament)
            (send (cadr ornament) update t d))
          ornaments)
-                
+        
+		(when (> shrink-t 0) 
+			(set! shrink-t (- shrink-t (* d grow-speed))))
+			
+		(when (< shrink-t 0)
+		    (set! delme #t))
+		
         (inner (void) update t d)
         
         (when (and (not (eq? grow-t -1)) (< grow-t (+ num-points grow-overshoot)))
@@ -434,7 +476,7 @@
     (class twig-view%
       
 	  (inherit growing?)
-      (inherit-field index radius num-points pos dir col tex grow-t)
+      (inherit-field index radius num-points pos dir col tex grow-t shrink-t)
       
       (field
        (profile '())
@@ -483,6 +525,10 @@
         (when (and (not (eq? grow-t -1)) (not (eq? grow-t 999)))
           (with-primitive root
             (partial-extrude grow-t profile path widths (vector 1 0 0) 0.05)))
+		
+		(when (> shrink-t 0)
+          (with-primitive root
+            (partial-extrude shrink-t profile path widths (vector 1 0 0) 0.05)))		
 		   
 		#;(when (not (growing?))
 			(with-primitive root
@@ -578,11 +624,12 @@
               #f)))
       
       (define/public (destroy-branch-twig twig-id)
-        (for-each
+	    (when (get-twig twig-id) ; might have destroyed itself already
-         (lambda (twig-id)
+          (for-each
-           (destroy-branch-twig twig-id))
+           (lambda (twig-id)
-         (send (get-twig twig-id) get-child-twig-ids))
+             (destroy-branch-twig twig-id))
-        (send (get-twig twig-id) destroy-twig)
+           (send (get-twig twig-id) get-child-twig-ids))
+          (send (get-twig twig-id) destroy-twig))
         (set! twigs (assoc-remove twig-id twigs)))
       
       (define/public (destroy-plant)
@@ -591,6 +638,13 @@
          (lambda (twig)
            (destroy-branch-twig (car twig)))
          twigs))
+   
+      (define/public (shrink-twig twig-id)
+        (send (get-twig twig-id) start-shrinking)
+		(for-each
+         (lambda (twig-id)
+           (shrink-twig twig-id))
+         (send (get-twig twig-id) get-child-twig-ids)))
       
       (define/public (add-twig parent-twig-id point-index twig)
         (let ((ptwig (get-twig parent-twig-id)))
@@ -630,6 +684,15 @@
            (send (cadr twig) set-excitations! a b))
          twigs))
       
+	  (define/public (nutrient-absorb twig-id twig-point)
+	    (with-primitive nutrients
+	  	(let ((p (random (pdata-size))))
+		  (pdata-set! "twig" p twig-id)
+		  (pdata-set! "point" p twig-point)
+		  (pdata-set! "p" p (send (get-twig twig-id) get-point twig-point))
+		  (pdata-set! "offset" p (vmul (srndvec) (
+		     send (get-twig twig-id) get-width twig-point))))))
+	  
       (define/public (update-nutrients t d)
        (when (not (null? twigs))
           (with-primitive nutrients
@@ -638,27 +701,27 @@
                              (let* ((twig-id (inexact->exact twig-id))
                                     (twig (get-twig twig-id))
                                     (point (inexact->exact point)))
+							 (if twig
                              (cond 
-                               ((or (< point 1) (not twig))
+							   ((< point 1) (pdata-set! "twig" i -1) (vector 0 0 0)) 
-                                (let* ((new-twig (choose twigs))
-                                       (num-points (send (cadr new-twig) get-num-points))
-                                       (new-point (if (zero? num-points) 0 (random num-points))))
-                                  (pdata-set! "twig" i (car new-twig))
-                                  (pdata-set! "point" i new-point)
-                                  (pdata-set! "offset" i (vmix offset (vmul (srndvec) (send (cadr new-twig) get-width new-point)) 0.2))
-                                  (send (cadr new-twig) get-point new-point)))
                                ((< (vdist (vadd (send twig get-point point) offset) p) 0.1)
                                 (pdata-set! "point" i (- point 1))                               
                                 (vadd p (vmul (vnormalise (vsub (vadd (send twig get-point (- point 1)) offset) p)) (* speed d))))
                                (else
-                                (vadd p (vmul (vnormalise (vsub (vadd (send twig get-point point) offset) p)) (* speed d)))))))
+                                (vadd p (vmul (vnormalise (vsub (vadd (send twig get-point point) offset) p)) (* speed d)))))
+							(vector 0 0 0))))
                            "p" "twig" "point" "offset" "speed"))))
               
       (define/public (update t d)
         (update-nutrients t d)
         (with-primitive seed
                         (scale (+ 1 (* 0.001 (sin (* 2 t))))))                       
-        
+        (for-each 
+         (lambda (twig)
+           (when (send (cadr twig) delme?)
+		   	  (destroy-branch-twig (car twig))))
+         twigs)
+		 
         (for-each 
          (lambda (twig)
            (send (cadr twig) update t d))
@@ -726,6 +789,7 @@
     (field
      (plants '()) ; map of ids -> plants     
      (pickups '()) ; map of ids -> pickups
+     (nutrients '()) ; map of ids -> nutrients
      (camera-dist 1)
      (env-root (with-state (scale 1000) (build-locator)))
      (root-camera-t 0)
@@ -789,7 +853,7 @@
                  (load-primitive (list-ref stone 1)))))
                   (with-primitive p (apply-transform) (recalc-bb)) ; apply the transform to speed up the ray tracing, don't have to tranform the ray into object space
                   p))
-              (list-ref world-list 2))))
+              (list-ref world-list 3))))
 
     (define/public (get-stones)
       stones)
@@ -820,18 +884,33 @@
     
     (define/public (get-pickup pickup-id)
       (cadr (assq pickup-id pickups)))
+
+    (define/public (get-nutrient nutrient-id)
+      (cadr (assq nutrient-id nutrients)))
     
     (define/public (add-pickup pickup-id type pos)
       (set! pickups (cons (list pickup-id (make-object pickup-view% pickup-id type pos)) pickups)))
+
+    (define/public (add-nutrient nutrient-id pos size)
+      (set! nutrients (cons (list nutrient-id (make-object nutrient-view% nutrient-id pos size)) nutrients)))
     
     (define/public (pick-up-pickup pickup-id)
       (send (get-pickup pickup-id) pick-up)
       (set! pickups (assoc-remove pickup-id pickups)))
     
+	(define/public (deplete-nutrient nutrient-id amount plant-id twig-id twig-point)
+	  (send (get-nutrient nutrient-id) deplete amount)
+	  (when (get-plant plant-id)
+		(send (get-plant plant-id) nutrient-absorb twig-id twig-point)))
+	
     (define/public (add-ornament plant-id twig-id point-index property)
       (when (get-plant plant-id)
         (send (get-plant plant-id) add-ornament twig-id point-index property)))
-                         
+  
+    (define/public (shrink-twig plant-id twig-id)
+      (when (get-plant plant-id)
+        (send (get-plant plant-id) shrink-twig twig-id)))
+                        
 	(define/public (set-excitations! a b)
 	  (for-each 
        (lambda (plant)
@@ -922,11 +1001,31 @@
              (send msg get-data 'pickup-id) 
              (send msg get-data 'type) 
              (send msg get-data 'pos)))
+			 
+           ((eq? (send msg get-name) 'new-nutrient)
+            (add-nutrient 
+			 (send msg get-data 'nutrient-id) 
+             (send msg get-data 'pos) 
+             (send msg get-data 'size)))
            
            ((eq? (send msg get-name) 'pick-up-pickup)
             (pick-up-pickup 
              (send msg get-data 'pickup-id)))
 
+           ((eq? (send msg get-name) 'deplete-nutrient)
+            (deplete-nutrient
+             (send msg get-data 'nutrient-id)
+			 (send msg get-data 'amount)
+			 (send msg get-data 'plant-id)
+			 (send msg get-data 'twig-id)
+			 (send msg get-data 'twig-point)))
+
+           ((eq? (send msg get-name) 'shrink-twig)
+		   (printf "hello~n")
+            (shrink-twig
+			 (send msg get-data 'plant-id)
+			 (send msg get-data 'twig-id)))
+
           ((eq? (send msg get-name) 'new-ornament)
 		   (add-ornament 
 			(send msg get-data 'plant-id)

plant-eyes/world-build.scm

@@ -28,6 +28,7 @@
     (let ((f (open-output-file fn)))
         (write (extract-list 'seed s) f)
         (write (extract-list 'pickup s) f)
+        (write (extract-list 'nutrients s) f)
         (write (extract-list 'stone s) f)
         (close-output-port f)))
 
@@ -35,7 +36,7 @@
     (list-ref l (random (length l))))
 
 
-(define (init num-seeds num-pickups num-stones area size)
+(define (init num-seeds num-pickups num-nutrients num-stones area size)
     (append
         (build-list num-seeds 
             (lambda (_)
@@ -51,6 +52,13 @@
                     (vmul (srndvec) (* 150 area))
                     0.5
                     (vmul (rndvec) 360) 0))))
+
+        (build-list num-nutrients
+            (lambda (_)
+                (make-ob 'nutrients 'nutrients "meshes/seed.obj"
+                    (vmul (srndvec) (* 150 area))
+                    (* (rndf) 10)
+                    (vmul (rndvec) 0) 0)))
         
         
         (build-list num-stones 
@@ -68,8 +76,9 @@
                     (cond 
                         ((eq? (ob-type ob) 'seed) (colour (vector 0 1 0)))
                         ((eq? (ob-type ob) 'pickup) (backfacecull 0) (hint-unlit) (colour (vector 1 1 0)))
-                        ((eq? (ob-type ob) 'stone) (colour (vector 1 0.5 0))))
+                        ((eq? (ob-type ob) 'stone) (colour (vector 1 0.5 0)))
-                    (load-primitive (ob-mesh ob))))
+                        ((eq? (ob-type ob) 'nutrients) (hint-unlit) (colour (vector 1 1 1))))
+                   (load-primitive (ob-mesh ob))))
             (when (eq? (ob-type ob) 'stone) (with-primitive (ob-root ob) (hide 1))))
         l))
 
@@ -100,7 +109,7 @@
 
 (clear)
 (clear-colour 0)
-(define s (init 5 200 200 1 10))
+(define s (init 5 200 100 100 1 10))
 (build s)
 
 (define l (make-light 'spot 'free))