twiglets fixed, moved stuff around...

plant-eyes/README

@@ -1,2 +1,28 @@
-i've split off the logic code while I work on it - it will eventually replace
+notes:
-plant-eyes.scm
+
+* keeping with a view/logic separation, although this is quite different to 
+  the hexagon game. the main advantages:
+	- just a divide and conquer strategy for staying sane 
+	- able to debug the logic without the view, or vice versa
+	- the logic can be ticked at a lower frequency - or even different 
+	  parts at different rates, whereas the view needs ticking every frame
+
+* need to try to keep all the intensive 'every thing vs every thing' checking 
+  in the logic side, where it can be done over many frames (i'm thinking the
+  lags involved with things like nutrients getting absorbed may not matter 
+  too much in this game)
+
+* using a message passing system to formalise the passing of information on 
+  the logic side. this makes it possible to have objects sending messages
+  at any point, and have them automatically collected up and dispatched to 
+  the view
+
+* these messages are also converted to xmpp messages and sent out over the 
+  network
+
+* line segments are computed in the logic side, and can be represented any
+  way by the view - maybe the players plant will be geometry and everyone
+  elses will be ribbons (stoopid LOD)
+
+* in the same way, the line segments can be created in any way by the logic 
+  side - eg. lsystem, or different methods per plant (or per twig even)

plant-eyes/plant-eyes.scm

@@ -1,39 +1,15 @@
+;; p l a n t   e y e s  [ copyright (c) 2009 foam vzw : gpl v3 ]
+
 ;#lang scheme/base
 ;(require fluxus-016/drflux)
-(require scheme/class "game-modes.ss" "logic.ss" "view.ss" "controller.ss" "client.ss" "jabberer.ss" "list-utils.ss")
+(require scheme/class 
-
+  "scripts/game-modes.ss" 
-;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+  "scripts/logic.ss" 
-; p l a n t   e y e s   
+  "scripts/view.ss" 
-;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+  "scripts/controller.ss" 
-
+  "scripts/client.ss" 
-; notes:
+  "scripts/jabberer.ss" 
-;
+  "scripts/list-utils.ss")
-; * keeping with a view/logic separation, although this is quite different to 
-;   the hexagon game. the main advantages:
-;     - just a divide and conquer strategy for staying sane 
-;     - able to debug the logic without the view, or vice versa
-;     - the logic can be ticked at a lower frequency - or even different 
-;       parts at different rates, whereas the view needs ticking every frame
-;
-; * need to try to keep all the intensive 'every thing vs every thing' checking 
-;   in the logic side, where it can be done over many frames (i'm thinking the
-;   lags involved with things like nutrients getting absorbed may not matter 
-;   too much in this game)
-;
-; * using a message passing system to formalise the passing of information on 
-;   the logic side. this makes it possible to have objects sending messages
-;   at any point, and have them automatically collected up and dispatched to 
-;   the view
-;
-; * these messages are also converted to xmpp messages and sent out over the 
-;   network
-;
-; * line segments are computed in the logic side, and can be represented any
-;   way by the view - maybe the players plant will be geometry and everyone
-;   elses will be ribbons (stoopid LOD)
-;
-; * in the same way, the line segments can be created in any way by the logic 
-;   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)(read f))))

plant-eyes/scripts/client.ss

@@ -1,5 +1,11 @@
+;; p l a n t   e y e s  [ copyright (c) 2009 foam vzw : gpl v3 ]
+
 #lang scheme
-(require scheme/class "jabberer.ss" "message.ss" "list-utils.ss")
+(require scheme/class 
+  "jabberer.ss" 
+  "message.ss" 
+  "list-utils.ss")
+  
 (provide (all-defined-out))
 
 ; the client listens to all the messages from the logic side

plant-eyes/scripts/controller.ss

@@ -1,5 +1,11 @@
+;; p l a n t   e y e s  [ copyright (c) 2009 foam vzw : gpl v3 ]
+
 #lang scheme/base
-(require scheme/class fluxus-016/fluxus "logic.ss" "view.ss")
+(require scheme/class 
+  fluxus-016/fluxus 
+  "logic.ss" 
+  "view.ss")
+  
 (provide (all-defined-out))
 
 ; reads input events and tells the logic side what to do

plant-eyes/scripts/game-modes.ss

@@ -1,5 +1,15 @@
+;; p l a n t   e y e s  [ copyright (c) 2009 foam vzw : gpl v3 ]
+
 #lang scheme
-(require scheme/class fluxus-016/fluxus "logic.ss" "view.ss" "controller.ss" "client.ss" "jabberer.ss" "list-utils.ss")
+(require scheme/class 
+  fluxus-016/fluxus 
+  "logic.ss" 
+  "view.ss" 
+  "controller.ss" 
+  "client.ss" 
+  "jabberer.ss" 
+  "list-utils.ss")
+  
 (provide (all-defined-out))
 
 (define-struct player-info (jid pass tex pos col))

plant-eyes/scripts/jabberer.ss

@@ -1,3 +1,5 @@
+;; p l a n t   e y e s  [ copyright (c) 2009 foam vzw : gpl v3 ]
+
 #lang scheme/base
 (require scheme/class); openssl (prefix-in xmpp: "xmpp.ss"))
 (provide (all-defined-out))

plant-eyes/scripts/list-utils.ss

@@ -1,3 +1,5 @@
+;; p l a n t   e y e s  [ copyright (c) 2009 foam vzw : gpl v3 ]
+
 #lang scheme/base
 (provide (all-defined-out))
 
@@ -47,4 +49,4 @@
   (cond 
     ((null? l) #f)
     ((eq? (car l) k) n)
-    (else (which-element k (cdr l) (+ n 1)))))
+    (else (which-element k (cdr l) (+ n 1)))))

plant-eyes/scripts/logic.ss

@@ -1,5 +1,11 @@
+;; p l a n t   e y e s  [ copyright (c) 2009 foam vzw : gpl v3 ]
+
 #lang scheme
-(require scheme/class fluxus-016/fluxus "message.ss" "list-utils.ss")
+(require scheme/class 
+  fluxus-016/fluxus 
+  "message.ss" 
+  "list-utils.ss")
+  
 (provide (all-defined-out))
 
 (define branch-probability 6) ; as in one in branch-probability chance

plant-eyes/scripts/message.ss

@@ -1,5 +1,9 @@
+;; p l a n t   e y e s  [ copyright (c) 2009 foam vzw : gpl v3 ]
+
 #lang scheme/base
-(require scheme/class "list-utils.ss")
+(require scheme/class 
+  "list-utils.ss")
+  
 (provide (all-defined-out))
 
 ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

plant-eyes/scripts/ornament-views.ss

@@ -1,5 +1,10 @@
+;; p l a n t   e y e s  [ copyright (c) 2009 foam vzw : gpl v3 ]
+
 #lang scheme/base
-(require scheme/class fluxus-016/fluxus "sound.ss")
+(require scheme/class 
+  fluxus-016/fluxus 
+  "sound.ss")
+  
 (provide (all-defined-out))
 
 (define (clamp v l u)

plant-eyes/scripts/sound.ss

@@ -1,3 +1,5 @@
+;; p l a n t   e y e s  [ copyright (c) 2009 foam vzw : gpl v3 ]
+
 #lang scheme/base
 (require scheme/class fluxus-016/fluxus)
 (provide (all-defined-out))

plant-eyes/scripts/view.ss

@@ -1,5 +1,14 @@
+;; p l a n t   e y e s  [ copyright (c) 2009 foam vzw : gpl v3 ]
+
 #lang scheme/base
-(require scheme/class fluxus-016/fluxus fluxus-016/shapes "sound.ss" "message.ss" "list-utils.ss" "ornament-views.ss")
+(require scheme/class 
+  fluxus-016/fluxus 
+  fluxus-016/shapes 
+  "sound.ss" 
+  "message.ss" 
+  "list-utils.ss" 
+  "ornament-views.ss")
+  
 (provide (all-defined-out))
 
 ; the fluxus code to make things look the way they do
@@ -485,7 +494,7 @@
             (widths '())
             (points '())
             (global-growth 0)
-            (global-growth-time 20))
+            (global-growth-time 100))
         
         (define/override (build)
             (set! root (let ((p (with-state
@@ -603,15 +612,12 @@
                 (lambda (twig)
                     (send twig update t d)
                     (when (and 
-                            (< (length twigs) 50)
+                            (< (length twigs) 20)
                             (> (send twig get-num-points) 2) 
-                            (zero? (random 20)))
+                            (zero? (random 400)))
                         (let ((pi (inexact->exact (floor (send twig get-grow-t)))))
-                            (when (< pi (send twig get-num-points))
+                            (when (and (> pi 0) (< pi (send twig get-num-points)))
-								(with-state
+                               (set! twigs (cons 
-									(translate (vadd (send twig get-pos) (send twig get-point pi)))
-									(build-sphere 5 5))
-                                (set! twigs (cons 
                                         (build-tree 
                                             (vadd (send twig get-pos) (send twig get-point pi)) 
                                             (send twig get-dir)
@@ -764,8 +770,7 @@
 	  
         (when (and (not (eq? grow-t -1)) (not (eq? grow-t 999)))
 	      ; randomly add twiglets as we are growing
-		  (when (and (zero? (random 400)) (< grow-t num-points))
+		  (when (and (zero? (random 100)) (< grow-t num-points))
-		  	(printf "~a~n" (length twiglets))
 		  	(let ((t (make-object twiglets% (get-root)))
 			      (pi (inexact->exact (floor grow-t))))
 				(send t build (get-point pi) dir (/ (get-width pi) 2) 20)

plant-eyes/test-scripts/butterflies.scm

@@ -0,0 +1,41 @@
+(clear)
+
+(clear-colour 0.5)
+
+
+
+(define (build)     
+    (let ((p (build-locator)))
+        (with-state
+            (colour (rndvec))
+            (parent p)
+            (hint-depth-sort)
+            (hint-unlit)
+            (backfacecull 0)
+            (texture (load-texture "textures/butterfly.png"))
+            (load-primitive "meshes/butterfly.obj")
+            (translate (vector 0 0.001 0))
+            (load-primitive "meshes/butterfly.obj"))
+        p))
+
+(define (anim)
+    (let ((a (* 90 (rndf))))
+        (with-primitive (car (get-children))
+            (rotate (vector 0 0 a)))
+        (with-primitive (cadr (get-children))
+            (rotate (vector 0 0 (- a))))))
+
+(define l (build-list 10 
+    (lambda (_) 
+        (with-state 
+            (translate (srndvec)) 
+            (rotate (vmul (rndvec) 360))
+            (scale 0.5)
+            (build)))))
+
+(every-frame
+    (for-each 
+        (lambda (p)
+            (with-primitive p
+                (anim)))
+        l))

plant-eyes/test-scripts/camera-dir.scm

@@ -0,0 +1,17 @@
+(clear)
+(show-axis 1)
+(clear-colour 0.5)
+(hint-wire)
+(define p (build-ribbon 2))
+
+(define p2 (with-state (scale (vector 0.1 0.1 1)) (build-cube)))
+
+(every-frame 
+    (let ((dir (vtransform-rot (vector 0 0 1) (minverse (get-camera-transform)))))
+        (with-primitive p
+            (pdata-set! "p" 1 
+                dir))
+        (with-primitive p2
+            (identity)
+            (concat (maim dir (vector 0 1 0)))
+            (scale (vector 1 0.1 0.1)))))

plant-eyes/test-scripts/classtest.scm

@@ -0,0 +1,21 @@
+#lang scheme
+(define testy%
+  (class object%
+    (init-field (a 0))
+    
+    (define/public (m) (display a)(newline))
+    
+    (super-new)))
+
+(define testy2%
+  (class testy%
+    (inherit-field a)
+    (field (b a))
+    
+    (define/public (mm) (display a)(display b) (newline))
+    
+    (super-new)))
+
+(define t (make-object testy2% 100))
+(send t m)
+(send t mm)

plant-eyes/test-scripts/dust.scm

@@ -0,0 +1,39 @@
+(require scheme/class)
+
+
+(define dust%
+    (class object%
+        (field
+            (rate 10)
+            (next-p 0)
+            (root (let ((p (with-state
+                (build-particles 500))))
+                (with-primitive p
+                    (pdata-map! 
+                        (lambda (c)
+                            (vector 1 1 1))
+                        "c")) p))
+            (emitter (build-locator)))
+
+    (define/public (update t d)
+
+        (let ((emitter-pos (with-primitive emitter
+            (identity)
+            (concat (minverse (get-camera-transform)))
+            (translate (vector 0 0 -10))
+            (vtransform (vector 0 0 0) (get-transform)))))
+
+        (with-primitive root
+        (for ((i (in-range 0 rate)))
+            (pdata-set! "p" next-p (vadd emitter-pos (vmul (srndvec) 10)))
+            (set! next-p (+ next-p 1))))))
+
+    (super-new)))
+
+(clear)
+(define t (make-object dust%))
+
+(define (animate)
+    (send t update (time) (delta)))
+
+(every-frame (animate))

plant-eyes/test-scripts/earth.scm

@@ -0,0 +1,140 @@
+(define-struct stones (mesh-list (pos-list #:mutable) size-list rot-list 
+        (root #:mutable) (obj-list #:mutable)))
+
+
+(define (stones->list s)
+    (map list 
+        (stones-mesh-list s)
+        (stones-pos-list s)
+        (stones-size-list s)
+        (stones-rot-list s)))
+
+(define (write-out fn s)
+    (let ((f (open-output-file fn)))
+        (write (stones->list s) f)
+        (close-output-port f)))
+
+(define (choose l)
+    (list-ref l (random (length l))))
+
+(define models (list 
+        ;    "meshes/fork.obj"
+        "meshes/stone1.obj"
+        "meshes/stone2.obj"
+        "meshes/stone3.obj"))
+
+(define (stones-init num area size)
+    (make-stones
+        (append (build-list num
+                (lambda (_)
+                    (choose models)))
+            (build-list 5
+                (lambda (_)
+                    "meshes/seed.obj")))
+
+        (append
+            (build-list num
+                (lambda (_)
+                    (vmul (srndvec) (* size area))))
+            (build-list 5
+                (lambda (_)
+                    (vmul (srndvec) (* size area 0.5)))))
+
+        (append
+            (build-list num
+                (lambda (_)
+                    (* size (- 1 (expt (rndf) 2)))))
+            (build-list 5
+                (lambda (_)
+                    1)))
+
+        (append
+            (build-list num
+                (lambda (_)
+                    (vmul (rndvec) 360)))
+            (build-list 5
+                (lambda (_)
+                    (vmul (rndvec) 360))))
+
+            0
+            '()))
+    
+    (define (stones-build stones)
+        (let* ((root (build-locator))
+                (objs (with-state
+                        (parent root)
+                        (map
+                            (lambda (mesh pos size)  
+                                (let ((p (with-state
+                                                (if (string=? mesh "meshes/seed.obj")
+                                                    (colour (vector 0 1 0))
+                                                    (colour (vector 1 0.5 0)))
+                                                (load-primitive mesh))))
+                                    0
+                                    p))
+                            (stones-mesh-list stones)
+                            (stones-pos-list stones)
+                            (stones-size-list stones)))))
+            (set-stones-obj-list! stones objs)
+            (set-stones-root! stones root)
+            stones))
+    
+    (define (stones-relax stones amount)
+        (let ((done #t))
+            (set-stones-pos-list! stones
+                (map 
+                    (lambda (pos size)
+                        (foldl
+                            (lambda (opos osize r)
+                                (cond ((< (vdist pos opos) (* 5 (+ size osize)))
+                                        (set! done #f)
+                                        (vadd r (vmul (vnormalise (vsub pos opos)) amount)))
+                                    (else r)))
+                            (if (> (vy pos) 0) (vadd pos (vector 0 (* amount -30) 0)) pos)
+                            (stones-pos-list stones)
+                            (stones-size-list stones)))
+                    (stones-pos-list stones)
+                    (stones-size-list stones)))
+            done))
+    
+    (define (stones-update stones)
+        (let ((root (build-locator)))
+            (with-state
+                (parent root)
+                (for-each
+                    (lambda (obj pos size rot)
+                        (with-primitive obj
+                            (identity)                        
+                            (translate pos)
+                            (rotate rot)
+                            (scale size)))
+                    (stones-obj-list stones)
+                    (stones-pos-list stones)
+                    (stones-size-list stones)
+                    (stones-rot-list stones)))
+            (set-stones-root! stones root)))
+    
+    (clear)
+    (clear-colour 0)
+    (define s (stones-build (stones-init 200 1 10)))
+    
+    (define l (make-light 'spot 'free))
+    (light-diffuse 0 (vector 0 0 0))
+    (light-specular 0 (vector 0 0 0))
+    (light-diffuse l (vector 1 1 1))
+    (light-position l (vector 0 1000 0))
+    (light-specular l (vector 0.1 0.1 0.1))
+    
+    (define done #f)
+    
+    (define (animate)
+        (when (key-pressed "s") (write-out "stones.txt" s))
+        
+        (when (not done)
+            (set! done (stones-relax s 0.1))
+            (stones-update s))
+        (when done (printf "done~n")))
+    
+    (every-frame (animate))
+    
+    

plant-eyes/test-scripts/earth2.scm

@@ -0,0 +1,23 @@
+(define models (list 
+;    "meshes/fork.obj"
+    "meshes/stone1.obj"
+    "meshes/stone2.obj"
+    "meshes/stone3.obj"))
+
+(define (choose l)
+    (list-ref l (random (length l))))
+
+(clear)
+
+(for ((i (in-range 0 10)))
+    (with-state
+        (texture (load-texture "textures/quartz.png"))
+        (translate (vmul (srndvec) 10))
+        (rotate (vmul (rndvec) 360))
+        (scale 0.5)
+        (load-primitive (choose models))))
+
+
+
+
+

plant-eyes/test-scripts/fin-test.scm

@@ -0,0 +1,96 @@
+; an example of the fluxus extrusion tool
+
+(require scheme/class)
+
+(define min-fin-len 3)
+(define fin-length-var 6)
+(define fin-grow-prob 2)
+(define max-fins-per-twig 5)
+
+
+(define fin%
+    (class object%
+        (init-field
+            (fin-size 1)
+            (twig-ob #f)
+            (col (vector 0 0 0))
+            (path-len 0)
+            (profile-len 0))
+        
+        (field
+            (fin-len (min path-len (+ min-fin-len (random fin-length-var))))
+            (root (build-polygons (* fin-len 2) 'triangle-strip))
+            (pos (random profile-len))
+            (start (* (random (- path-len fin-len)) profile-len))
+            (grow-t 0)
+            (grow-speed (* (rndf) 0.1)))
+        
+        (define/public (build)
+            (with-primitive root
+                (parent twig-ob)
+                (texture (load-texture "textures/fin-roots.png"))
+                (hint-unlit)
+                (hint-depth-sort)
+                (colour col)
+                (backfacecull 0)
+                (pdata-index-map!
+                    (lambda (i t)
+                        (vector (/ (+ (quotient i 2) 1) (/ (pdata-size) 2)) (if (odd? i) 1 0) 0))
+                    "t")))
+        
+        (define/public (update t d)
+            (when (< grow-t 1)
+            (with-primitive root
+                (pdata-index-map!            
+                    (lambda (i p)            
+                        (let* ((ti (+ start pos (* (quotient i 2) profile-len)))
+                                (tp (with-primitive twig-ob (pdata-ref "p" ti)))
+                                (tn (with-primitive twig-ob (pdata-ref "n" ti))))
+                            (if (even? i)
+                                tp
+                                (vadd tp (vmul tn (* grow-t fin-size))))))
+                    "p"))
+            
+            (set! grow-t (+ grow-t (* d grow-speed)))))
+        
+        (super-new)))
+
+(clear)
+(clear-colour 0.5)
+(define profile (build-circle-profile 12 0.5))
+
+(define width (build-list 20
+        (lambda (n) (* n 0.01 (+ 1.5 (cos (* 0.5 n)))))))
+
+(define path (build-list 20
+        (lambda (n) (vadd (vector 1 0 0) (vmul (vector (sin (* 0.2 n)) 0 (cos (* 0.2 n))) (* 0.05 n))))))
+
+(define p (with-state
+        (wire-colour 0)
+        (colour (vector 1 1 1))   
+        (specular (vector 1 1 1))
+        (shinyness 20)
+        (hint-wire)
+        ;        (hint-normal)
+        (build-extrusion profile path width 10 (vector 0 1 0))))
+
+(define fins (build-list 10
+    (lambda (_)
+        (let ((f (make-object fin% 0.5 p (vector 1 1 1) (length path) (length profile))))
+            (send f build)
+            f))))
+
+(every-frame (for-each
+        (lambda (f)
+             (send f update (time) (delta)))
+        fins))
+        
+
+#;(define (animate)
+    (with-primitive p
+        (partial-extrude 
+            (* (* 0.5 (+ 1 (sin (* 1 (time))))) (+ (length path) 5)) 
+            profile path width (vector 0 1 0) 0.05)))
+
+#;(every-frame (animate))
+

plant-eyes/test-scripts/insect-test.scm

@@ -0,0 +1,96 @@
+(require scheme/class)
+
+
+(define insect-view%
+    (class object%
+        (init-field
+            (id 0)
+            (from (vector 0 0 0))
+            (type 'none))
+    
+        (field
+            (to (vector 0 0 0))
+            (from-dir (vector 1 0 0))
+            (to-dir (vector 1 0 0))
+            (time 0)
+            (tick 1))
+                
+        (define/public (move pos dur)
+            (set! from to)
+            (set! from-dir to-dir)
+            (set! to pos)
+            (set! to-dir (vnormalise (vsub from to)))
+            (set! time 0)
+            (set! tick dur))
+        
+        (define/public (update t d)
+           (set! time (+ time d)))
+        
+        (super-new)))
+
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+(define (add-blendshape key model)
+    (let ((b (load-primitive model))
+            (pname (string-append "p" (number->string key))))
+        (pdata-add pname "v")
+        (pdata-index-map!
+            (lambda (i p)
+                (with-primitive b (pdata-ref "p" i)))
+            pname)
+        (destroy b)))
+
+(define (set-blendshape key)
+    (pdata-copy (string-append "p" (number->string key)) "p"))
+
+(define spider-insect-view%
+    (class insect-view%
+        (inherit-field from to from-dir to-dir time tick)      
+        
+        (field
+            (root (let ((p (with-state
+                (hint-unlit)
+                (colour (vector 0 0 0))
+                (load-primitive "meshes/spider-1.obj"))))
+                (with-primitive p                
+                    (pdata-copy "p" "p0")
+                    (add-blendshape 1 "meshes/spider-2.obj")
+                    (add-blendshape 2 "meshes/spider-3.obj") p)))
+            (anim-t 0)
+            (anim-d (* 0.2 (rndf)))
+            (blendshape 0))
+        
+        (define/override (update t d)
+            (with-primitive root
+            
+                        (when (> anim-t anim-d)
+                            (set! anim-t 0)
+                            (set! blendshape (modulo (+ blendshape 1) 3))
+                            (set-blendshape blendshape))
+            
+                        (identity)
+                        
+                        (let ((h (hermite-tangent from to (vmul from-dir 2) (vmul to-dir 2) (/ time tick))
+                               #;(vlerp-tangent from to (/ time tick))))
+                            (translate (car h))
+                            (concat (maim (vector 0 0 1) (vnormalise (cadr h))))
+                        
+                        (scale 1)))
+            (set! time (+ time d))
+            (set! anim-t (+ anim-t d)))
+        
+        (super-new)))
+
+(clear)
+(clear-colour 0.5)
+(define s (make-object spider-insect-view% 0 (vector 0 0 0) 'spider))
+
+(define t 0)
+
+(every-frame
+    (begin
+        (when (> (time) t)
+            (set! t (+ (time) 1))
+            (send s move (vmul (srndvec) 10) 1))
+        (send s update (time) (delta))))
+

plant-eyes/test-scripts/ripple.scm

@@ -0,0 +1,37 @@
+
+(define (ripple t speed wave-length)
+    (define (pre-ripple p)
+        (for-each
+            (lambda (p)
+                (with-primitive p                
+                    (when (not (pdata-exists? "rip-pref"))
+                        (pdata-copy "p" "rip-pref"))
+                    (pre-ripple p)))
+            (get-children)))
+    
+    
+    (define (do-ripple p t)
+        (for-each
+            (lambda (p)
+                (with-primitive p                
+                    (pdata-map!
+                        (lambda (p pref)
+                            (vadd pref (vmul (srndvec) 
+                                    (* 0.1 (+ 1 (sin (+ (* t speed) (* wave-length     
+                                                        (vdist (vtransform p 
+                                                                (minverse (get-transform))) 
+                                                            (vector 0 0 0))))))))))
+                        "p" "rip-pref")
+                    (do-ripple p t)))
+            (get-children)))
+
+    (pre-ripple 1)
+    (do-ripple 1 t))
+
+(clear)
+(build-cube)
+(translate (rndvec))
+(build-torus 0.1 2 30 30)
+
+(every-frame (ripple (time) 5 0.001))
+

plant-eyes/test-scripts/serialise-test.scm

@@ -0,0 +1,47 @@
+#lang scheme
+
+(define (value->string a)
+  (cond
+    ((number? a) (string-append "n:" (number->string a)))
+    ((string? a) (string-append "s:" a))
+    ((vector? a) (string-append "v:" (number->string (vector-ref a 0)) ","
+                                (number->string (vector-ref a 1)) ","
+                                (number->string (vector-ref a 2))))
+    ((symbol? a) (string-append "y:" (symbol->string a)))
+    (else (error "unsupported arg type for " a))))
+
+(define (nvpairs->string l s)
+  (cond 
+    ((null? l) s)
+    (else
+     (nvpairs->string (cdr l) (string-append s (symbol->string (caar l)) "="
+                                           (value->string (cadr (car l))) " ")))))
+
+(define (string->value a)
+  (cond
+    ((string=? (car a) "n") (string->number (cadr a)))
+    ((string=? (car a) "s") (cadr a))
+    ((string=? (car a) "v") 
+     (let ((v (string-split (cadr a) #\,)))
+       (vector (string->number (list-ref v 0))
+               (string->number (list-ref v 1))
+               (string->number (list-ref v 2)))))
+    ((string=? (car a) "y") (string->symbol (cadr a)))
+    (else (error "unsupported value type for " a))))
+
+(define (string->nvpairs s l)
+  (map
+   (lambda (pair)
+     (let ((nv (string-split pair #\=)))
+     (list (string->symbol (car nv))
+           (string->value (string-split (cadr nv) #\:)))))
+   (string-split s #\ )))
+
+
+(define ser (nvpairs->string (list 
+                (list 'one 2)
+                (list 'two "three")
+                (list 'three (vector 1 2 3))
+                (list 'four 'hello)) ""))
+
+(string->nvpairs ser '())

plant-eyes/test-scripts/shader-test.scm

@@ -0,0 +1,20 @@
+(clear)
+(clear-shader-cache)
+(clear-texture-cache)
+
+(let ((l (make-light 'point 'free)))
+    (light-diffuse 0 (vector 0 0 0))
+    (light-diffuse l (vector 1 1 1))
+    (light-position l (vector 10 50 -4)))
+
+
+(with-primitive (with-state
+    (colour (vector 0.5 1 0.4))
+    (shader "shaders/twig.vert.glsl" "shaders/twig.frag.glsl")
+    (multitexture 0 (load-texture "textures/cells-1.png"))
+    (multitexture 1 (load-texture "textures/cells-2.png"))
+    (multitexture 2 (load-texture "textures/cells-3.png"))
+    (multitexture 3 (load-texture "textures/root-norm.png"))
+    (build-torus 1 2 20 20))
+
+(shader-set! (list "Maps" (list 0 1 2) "NormalMap" 3)))

plant-eyes/test-scripts/spark.scm

@@ -0,0 +1,25 @@
+(clear)
+
+(texture (load-texture "textures/spark.png"))
+(hint-unlit)
+
+(define (build-pickup x y)
+    (let ((p (build-ribbon 30)))
+        
+        (with-primitive p
+            (pdata-index-map!
+                (lambda (i p)
+                    (vector (cos (/ i x)) (sin (/ i y)) (/ i (pdata-size))))
+                "p")
+            (pdata-index-map!
+                (lambda (i p)
+                    (* 0.3 (sin (* 3.141 (/ i (pdata-size))))))
+                "w")
+            (pdata-map!
+                (lambda (c)
+                    (vector 1 1 1))
+                "c"))
+        
+        p))
+
+(build-pickup 5 3)

plant-eyes/test-scripts/spider.scm

@@ -0,0 +1,37 @@
+(clear)
+(clear-geometry-cache)
+(hint-unlit)
+(colour 0)
+(define p (load-primitive "meshes/spider-1.obj"))
+(clear-colour 0.5)
+
+(define (add-blendshape key model)
+    (let ((b (load-primitive model))
+            (pname (string-append "p" (number->string key)))
+            (nname (string-append "n" (number->string key))))
+        (pdata-add pname "v")
+        (pdata-add nname "v")
+        (pdata-index-map!
+            (lambda (i p)
+                (with-primitive b (pdata-ref "p" i)))
+            pname)
+        (pdata-index-map!
+            (lambda (i n)
+                (with-primitive b (pdata-ref "p" i)))
+            nname)
+        (destroy b)))
+
+(define (set-blendshape key)
+    (pdata-copy (string-append "p" (number->string key)) "p")
+    (pdata-copy (string-append "n" (number->string key)) "n")
+    (recalc-normals 0))
+
+(with-primitive p
+    (pdata-copy "p" "p0")
+    (pdata-copy "n" "n0")
+    (add-blendshape 1 "meshes/spider-2.obj")
+    (add-blendshape 2 "meshes/spider-3.obj"))
+
+(every-frame
+    (with-primitive p
+        (set-blendshape (modulo (inexact->exact (round (* (time) 5))) 3))))

plant-eyes/test-scripts/twiglets.scm

@@ -0,0 +1,300 @@
+(require scheme/class)
+(require "sound.ss")
+(define default-grow-speed 4)
+(define grow-overshoot 10)
+
+(define (fract n)
+    (- n (floor n)))
+
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+(define twig-view%
+    (class object%
+        (init-field
+            (id 0)
+            (pos (vector 0 0 0))
+            (type 'none)
+            (dir (vector 0 1 0))
+            (radius 1)
+            (num-points 0)) 
+        
+        (field
+            (index 0)
+            (parent-twig-id -1)
+            (child-twig-ids '())
+            (ornaments '())
+            (col (vector 1 1 1))
+            (tex "")
+            (markers '())
+            (shrink-t 0)
+            (grow-t -1)
+            (marker-destroy-t 0)
+            (grow-speed default-grow-speed)
+            (delme #f))
+        
+        (define/public (get-id) id)        
+        (define/public (delme?) delme)        
+        (define/public (get-dir) dir)        
+        (define/public (set-dir! s) (set! dir s))        
+        (define/public (set-col! s) (set! col s))        
+        (define/public (set-tex! s) (set! tex s))
+        (define/public (get-pos) pos)
+        (define/public (build) 0)        
+        (define/public (get-num-points) index)
+        (define/public (get-grow-t) grow-t)      
+        (define/public (set-pos! s) (set! pos s))
+        (define/public (get-child-twig-ids) child-twig-ids)
+        (define/public (get-root) (error "need to overide this"))        
+        (define/public (destroy-twig) (destroy (get-root)))
+        (define/public (set-parent-twig-id s) (set! parent-twig-id s))
+        (define/public (get-point point-index) (error "need to overide this"))        
+        (define/public (get-width point-index) (error "need to overide this"))
+        
+        (define/public (add-child-twig-id twig-id)
+            (set! child-twig-ids (cons twig-id child-twig-ids)))
+        
+        (define/public (growing?)
+            (< grow-t (+ num-points grow-overshoot)))
+        
+        (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 (+ num-points grow-overshoot))))
+        
+        (define/pubment (add-point point width make-marker)
+            (play-sound "snd/event01.wav" point (+ 0.1 (rndf)) 0.3) 
+            (when make-marker
+                (set! markers (append markers (list (with-state
+                                (parent (get-root))
+                                (translate point)
+                                (scale 0.1)
+                                (shader "shaders/toon.vert.glsl" "shaders/toon.frag.glsl")
+                                (colour col)
+                                (build-sphere 8 8))))))
+            
+            (inner (void) add-point point width make-marker))
+        
+        (define/public (add-ornament point-index property)          
+            (when (< point-index grow-t)
+                (play-sound "snd/nix.00203.wav" (get-point point-index) (+ 0.1 (rndf)) 0.3)
+                (with-state
+                    (parent (get-root))
+                    (let ((ornament (property->ornament property
+                                    (get-point point-index)
+                                    (get-width point-index)
+                                    (vnormalise (vsub (get-point point-index) (get-point (- point-index 1))))
+                                    col)))
+                        ; check above ground
+                        (let ((pos (with-primitive (get-root) (vtransform (vector 0 0 0) (get-global-transform)))))
+                            (if (not (and (send ornament above-ground-only?) 
+                                        (< (vy (vadd pos (get-point point-index))) 1)))
+                                ; todo - delete existing ornaments here
+                                (set! ornaments (cons (list point-index ornament) ornaments))
+                                (send ornament destroy-ornament)))))))
+        
+        (define/pubment (set-excitations! a b)
+            (for-each
+                (lambda (ornament)
+                    (send (cadr ornament) set-excitations! a b))
+                ornaments))
+        
+        (define/pubment (update t d)        
+            (for-each
+                (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)))
+                (set! grow-t (+ grow-t (* d grow-speed)))
+                (when (and (not (null? markers)) (> 0 (- marker-destroy-t grow-t)))
+                    ; soundtodo: marker gobble
+                    (set! marker-destroy-t (+ 1 marker-destroy-t))
+                    (destroy (car markers))
+                    (set! markers (cdr markers))))
+            
+            (when (> grow-t (+ num-points 10)) 
+                (set! grow-t 999)))
+        
+        (super-new)))
+
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+(define ribbon-twig-view%
+    (class twig-view%
+        
+        (inherit-field pos radius num-points index col tex grow-t)
+        
+        (field
+            (root 0)
+            (widths '())
+            (points '())
+            (global-growth 0)
+            (global-growth-time 10))
+        
+        (define/override (build)
+            (set! root (let ((p (with-state
+                                (translate pos)
+                                (colour col)
+                                (hint-unlit)
+                                (texture (load-texture "textures/ribbon-twig.png")) 
+                                (build-ribbon num-points))))
+                    (with-primitive p
+                        (pdata-map! 
+                            (lambda (w)
+                                0)
+                            "w")
+                        (pdata-set! "w" 0 radius))
+                    p)))
+        
+        
+        (define/override (get-root)
+            root)
+        
+        #;(define/override (get-point point-index)
+            (with-primitive root
+                (pdata-ref "p" point-index)))
+        
+        #;(define/override (get-width point-index)
+            (with-primitive root
+                (pdata-ref "w" point-index)))
+        
+        (define/override (get-point point-index)
+            (list-ref points point-index))
+        
+        (define/override (get-width point-index)
+            (list-ref widths point-index))
+        
+        (define/augment (add-point point width make-marker)
+            #;(with-primitive root
+                (pdata-index-map! ; set all the remaining points to the end
+                    (lambda (i p)    ; in order to hide them
+                        (if (< i index)
+                            p
+                            point))
+                    "p"))
+            (set! widths (append widths (list width)))
+            (set! points (append points (list point)))
+            (set! index (+ index 1)))
+        
+        (define/augment (update t d)
+            (when (and (> grow-t 0) (< grow-t (+ (length points) 10)))
+                (with-primitive root
+                    (pdata-index-map!
+                        (lambda (i w)    
+                            (* (/ global-growth global-growth-time)
+                                (cond ((< i (- grow-t 1))
+                                        (list-ref widths i))
+                                    ((< i grow-t)
+                                        (* (list-ref widths i) (fract grow-t)))
+                                    (else
+                                        0))))
+                        "w")
+                    
+                    (pdata-index-map!
+                        (lambda (i p)    
+                            (cond ((< i (- grow-t 1))
+                                    (list-ref points i))
+                                ((equal? i (inexact->exact (floor (+ grow-t 1))))
+                                    (vmix 
+                                        (list-ref points i)
+                                        (list-ref points (- i 1)) (fract grow-t)))
+                                (else
+                                    (list-ref points i))))
+                        "p")))
+            
+            (when (< global-growth global-growth-time)
+                (set! global-growth (+ global-growth d))))
+        
+        (super-new)))
+
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+; bunches of ribbon twigs 
+(define twiglets%
+    (class object%
+        (init-field
+            (par 0))
+        
+        (field
+            (twigs '()))
+        
+        (define/public (build pos dir width length)
+            (set! twigs (list (build-tree pos dir width length))))
+        
+        (define (build-tree pos dir width length)
+            (let   ((t (make-object ribbon-twig-view% 0 pos 'ribbon 
+                            dir 
+                            (* width (+ 0.5 (rndf))) length)))
+                (with-state
+                    (parent par)
+                    (send t build))
+                (let ((m (mrotate (vmul (srndvec) 45)))
+                        (ppos (vector 0 0 0)))
+                    (for ((i (in-range 0 length)))
+                        (let ((dir (vtransform (send t get-dir) m))
+                                (width (if (eq? i (- length 1)) 0 (/ width (+ i 1)))))
+                            (send t set-dir! dir)
+                            (send t add-point ppos width #f)
+                            (set! ppos (vadd ppos (vmul dir (* 5 width)))))))
+                (send t start-growing)
+                t))
+        
+        
+        
+        (define/public (update t d)
+            (for-each 
+                (lambda (twig)
+                    (send twig update t d)
+                    (when (and 
+                            (< (length twigs) 50)
+                            (> (send twig get-num-points) 2) 
+                            (zero? (random 20)))
+                        (let ((pi (inexact->exact (floor (send twig get-grow-t)))))
+                            (when (< pi (send twig get-num-points))
+                                (set! twigs (cons 
+                                        (build-tree 
+                                            (vadd (send twig get-pos) (send twig get-point pi)) 
+                                            (send twig get-dir)
+                                            (/ (send twig get-width pi) 1.4) 
+                                            (/ (send twig get-num-points) 2))
+                                        twigs))))))
+                twigs))
+        
+        (super-new)))
+
+
+(clear)
+(clear-colour 0.5)
+(define l (with-state 
+        (build-locator)))
+
+
+(define r '())
+
+(let ((t (make-object twiglets% l)))
+    (send t build (vector 0 0 0) (vector 0 1 0) 2 20)
+    (set! r (cons t r)))
+
+(every-frame 
+    (begin
+        (when (key-pressed " ")
+            (let ((t (make-object twiglets% l)))
+                (send t build (vector 0 0 0) (vector 0 1 0) 2 20)
+                (set! r (cons t r))))
+        (for-each
+            (lambda (t)
+                (send t update (time) 0.02))
+            r))) 
+
+;(start-framedump "ribbon-test-" "jpg")
+

plant-eyes/test-scripts/worm-test.scm

@@ -0,0 +1,150 @@
+(require scheme/class)
+
+(define (worm-colour) (vector 1 1 1))
+
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+; 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 insect-view%
+    (class object%
+        (init-field
+            (id 0)
+            (from (vector 0 0 0))
+            (type 'none))
+    
+        (field
+            (to (vector 0 0 0))
+            (from-dir (vector 1 0 0))
+            (to-dir (vector 1 0 0))
+            (time 0)
+            (tick 0))
+                
+        (define/public (move pos dur)
+            (set! from to)
+            (set! from-dir to-dir)
+            (set! to pos)
+            (set! to-dir (vnormalise (vsub from to)))
+            (set! time 0)
+            (set! tick dur))
+        
+        (define/public (update t d)
+          #;(when (< time tick)
+            (with-primitive root
+                        (identity)
+                        
+                        (let ((h (hermite-tangent (/ time tick) from to (vmul from-dir 2) (vmul to-dir 2))
+                                    #;(lerp-tangent (/ time tick) from to)))
+                            
+                            (translate (car h))
+                            (concat (maim (vector 0 0 1) (vnormalise (cadr h))))
+                        
+                        (scale 0.2))))
+            (set! time (+ time d)))
+        
+        (super-new)))
+
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+(define worm-insect-view%
+    (class insect-view%
+        (inherit-field from to from-dir to-dir time tick)      
+        
+        (field 
+            (hidden #t)
+            (from2 (vector 0 0 0))
+            (from-dir2 (vector 0 0 0))
+               (root (let ((p (build-ribbon 20)))
+              (with-primitive p
+                (translate (vector 0 0 -0.1))
+                (hint-depth-sort)
+                (hint-unlit)
+                (colour (worm-colour))
+                (texture (load-texture "textures/worm.png"))
+                (let ((width (+ 2 (* 2 (rndf)))))
+                    (pdata-index-map!
+                        (lambda (i w)
+                            width)
+                        "w"))
+                #;(pdata-map!
+                    (lambda (c)
+                        (vector 1 1 1))
+                    "c"))
+                p)))
+
+        (define/override (move pos dur)
+            (set! from2 from)
+            (set! from to)
+            (set! from-dir2 from-dir)
+            (set! from-dir to-dir)
+            (set! to pos)
+            (set! to-dir (vmul (vsub to from) 5))
+            (set! time 0)
+            (set! tick dur))      
+
+        (define/public (get-pos)
+            to)
+
+        (define/public (get-dir)
+            to-dir)
+         
+        (define/override (update t d)
+                    (let ((nt (/ time tick))) ; normalise time
+                        (with-primitive root
+                            (pdata-index-map!
+                                (lambda (i p)
+                                    (let ((st (- nt (* 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! time (+ time d)))
+    
+    (super-new)))
+
+(clear)
+(clear-colour 0.5)
+(define w (make-object worm-insect-view% 0 (srndvec)))
+
+(send w move (srndvec) 1)
+
+(define next 0)
+
+(every-frame
+    (begin
+        (when (> (time) next) 
+            (printf "~a~n" (send w get-dir))
+            (send w move (vmul (srndvec) 10) 5)
+            (set! next (+ (time) 5)))
+        (send w update (time) (delta))))