added all the game prototypes

README

@@ -1,2 +1,13 @@
 
 SYM-< BIO-< SYS 
+
+cellular : experiments dragging cells around to build plants
+danceplant : grow lsystem plants with a dancemat (or cursor keys)
+flatgarden : rendering test for 2d lsystems
+mingle : experiments blowing pollen, including dancemat driven flowers
+roots : roots growing around stones
+sketcher : mouse strokes -> lsystem plants
+treetris : play tetris to grow a plant
+bamboo : fluxus <-> pd interface
+comm : xmpp client
+hayfever : a multiplayer plant prototype

cellular/cellular-1.scm

@@ -0,0 +1,127 @@
+(require scheme/class)
+
+(define input%
+    (class object%
+        
+        (field
+            (last-mouse (vector 0 0 0))
+            (last-button #f)
+            (last-keys '())
+            (new-keys '())
+            (keys-pressed '())
+            (selected 0)
+            (zoom -20))
+        
+        (define/public (pre-update)
+            (when (and (not last-button) (mouse-button 1))
+                (set! selected (select (mouse-x) (mouse-y) 2))))
+        
+        (define/public (update)
+            (set! last-button (mouse-button 1))
+            (set! new-keys (append (keys-down) '() #;(get-special-keys-pressed)))
+            ;            (set! keys-pressed (filter
+                    ;                    (lambda (key)
+                        ;                        (not (bricks-in-list key last-keys)))
+                    ;                    new-keys))
+            (set! last-keys new-keys)
+            (when (key-pressed "-") (set! zoom (* zoom 1.1)))
+            (when (key-pressed "=") (set! zoom (* zoom 0.9)))
+            (set-camera-transform (mtranslate (vector 0 0 zoom))))
+        
+        (define/public (get-keys-pressed)
+            keys-pressed)
+        
+        (define/public (get-selected)
+            selected)
+        
+        (define/public (mouse-b n)
+            (mouse-button n))
+        
+        (define/public (get-pos-from-mouse)
+            (let* ((ndcpos (vector (* (- (/ (mouse-x) (vx (get-screen-size))) 0.5) (* -2 zoom))
+                            (* (- (- (/ (mouse-y) (vy (get-screen-size))) 0.5)) (* -1.5 zoom)) -10))
+                    (scrpos (vtransform ndcpos (minverse (get-camera-transform)))))
+                scrpos))        
+        
+        (define/public (get-mouse-change)
+            (let ((r (if last-button (vsub (get-pos-from-mouse) last-mouse)
+                            (vector 0 0 0))))
+                (set! last-mouse (get-pos-from-mouse))
+                r))
+        
+        (super-new)))
+
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+(define-struct cell (root wall (pos #:mutable) radius thresh))
+
+(define selected 0)
+
+(define (build-cell pos radius threshold)
+    (with-state
+        (push)
+        (hint-unlit)
+        (translate pos)
+        (scale radius)
+        (colour (vector 0.5 (+ 0.5 (* 0.5 (rndf))) 0.5))
+        (let ((root (build-sphere 7 7)))
+            (pop)
+            (parent root)
+            (scale threshold)
+            (opacity 0.3)
+            (colour (vector 0.5 (+ 0.5 (* 0.5 (rndf))) 0.5))
+            
+            (let ((wall (build-sphere 7 7)))
+            (make-cell root wall pos radius threshold)))))
+
+(define (cell-update cell input organism)
+    (with-primitive (cell-root cell)
+        (when (eq? (send input get-selected) (cell-wall cell))
+            (translate (send input get-mouse-change)))
+
+        (let ((dir (foldl
+                (lambda (other cur)
+                    (if (not (eq? cell other))
+                        (let ((dist (vdist (cell-pos cell) (cell-pos other))))
+                            (cond 
+                                ; inside nucleus
+                                ((< dist (+ (cell-radius cell) (cell-radius other)))
+                                    (vadd cur (vmul (vsub (cell-pos cell) (cell-pos other)) (* 0.1 (/ 1 dist)))))
+                                ((< dist (+ (cell-thresh cell) (cell-thresh other)))
+                                    (vadd cur (vmul (vsub (cell-pos cell) (cell-pos other)) -0.005)))
+                                (else
+                                    cur)))
+                        cur))
+                (vector 0 0 0)
+                organism)))
+        (translate (vector (vx dir) (vy dir) 0)))
+        
+        (set-cell-pos! cell (vtransform (vector 0 0 0) (get-transform)))))
+
+
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+(define (build-organism count)
+    (build-list count (lambda (_) (build-cell (vmul (vector (crndf) (crndf) 0) 15) 1 2))))
+
+(define (organism-update organism input)
+    (for-each
+        (lambda (cell)
+            (cell-update cell input organism))
+        organism))
+
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+(clear)
+(clear-colour (vector 0.2 0.3 0))
+(define organism (build-organism 100))
+
+(define input (make-object input%))
+
+(define (update)
+    (send input pre-update)
+    (organism-update organism input)
+    (send input update))
+
+(every-frame (update)) 

cellular/cellular-2.scm

@@ -0,0 +1,274 @@
+(require scheme/class)
+
+(define photon-thresh 0.1)
+
+(define (contains? a l)
+    (cond 
+        ((null? l) #f)
+        ((eq? (car l) a) #t)
+        (else (contains? a (cdr l)))))
+
+(define (remove a l)
+    (cond
+        ((null? l) l)
+        ((eq? (car l) a) (remove a (cdr l)))
+        (else (cons (car l) (remove a (cdr l))))))
+
+(define input%
+    (class object%
+        
+        (field
+            (last-mouse (vector 0 0 0))
+            (last-button #f)
+            (last-keys '())
+            (new-keys '())
+            (keys-pressed '())
+            (selected 0)
+            (zoom -50))
+        
+        (define/public (pre-update)
+            (when (and (not last-button) (mouse-button 1))
+                (set! selected (select (mouse-x) (mouse-y) 2))))
+        
+        (define/public (update)
+            (set! last-button (mouse-button 1))
+            (set! new-keys (append (keys-down) '() #;(get-special-keys-pressed)))
+            (set! keys-pressed (filter
+                    (lambda (key)
+                        (not (contains? key last-keys)))
+                    new-keys))
+            (set! last-keys new-keys)
+            (when (key-pressed "-") (set! zoom (* zoom 1.1)))
+            (when (key-pressed "=") (set! zoom (* zoom 0.9)))
+            (set-camera-transform (mtranslate (vector 0 0 zoom))))
+        
+        (define/public (get-keys-pressed)
+            keys-pressed)
+        
+        (define/public (get-selected)
+            selected)
+        
+        (define/public (mouse-b n)
+            (mouse-button n))
+        
+        (define/public (get-pos-from-mouse)
+            (let* ((ndcpos (vector (* (- (/ (mouse-x) (vx (get-screen-size))) 0.5) (* -2 zoom))
+                            (* (- (- (/ (mouse-y) (vy (get-screen-size))) 0.5)) (* -1.5 zoom)) -10))
+                    (scrpos (vtransform ndcpos (minverse (get-camera-transform)))))
+                scrpos))        
+        
+        (define/public (get-mouse-change)
+            (let ((r (if last-button (vsub (get-pos-from-mouse) last-mouse)
+                            (vector 0 0 0))))
+                (set! last-mouse (get-pos-from-mouse))
+                r))
+        
+        (super-new)))
+
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+(define-struct photons (root))
+
+(define (build-photons photon-count)
+    (with-state
+        (hint-depth-sort)
+        (texture (load-texture "textures/star.png"))
+        (let ((p (build-particles photon-count)))
+            (with-primitive p
+                (pdata-map!
+                    (lambda (s)
+                        (vector 2 2 0))
+                    "s")
+                (pdata-map!
+                    (lambda (c)
+                        (vector 1 1 1))
+                    "c")
+                (pdata-map!
+                    (lambda (p)
+                        (vector 1 1000 1))
+                    "p"))
+            (make-photons p))))
+
+(define (photons-update light)
+    (with-primitive (photons-root light)
+        (for ((i (in-range 0 30)))
+            (let ((p (vector (* (crndf) 30) (* (rndf) 30) 0)))
+                (if (> (snoise (* 0.03 (vx p)) (* 0.03 (vy p)) (* 0.1 (time))) photon-thresh)
+                    (pdata-set! "p" (random (pdata-size)) p)
+                    (pdata-set! "p" (random (pdata-size)) (vector 0 1000 0)))))))
+
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+(define-struct resources ((water #:mutable)))
+
+(define (build-resources)
+    (make-resources (build-list 5 (lambda (_)
+         (with-state
+            (translate (vmul (vector (crndf) (- (rndf)) 0) 30))
+            (translate (vector 0 -10 10))
+            (opacity 0.5)
+            (scale (vector 10 10 1))
+            (colour (vector 0.5 0.5 1))
+            (build-sphere 10 10))))))
+
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+(define-struct cell (root 
+        wall 
+        (pos #:mutable) 
+        radius 
+        thresh
+        (dragging #:mutable)
+        (connected #:mutable)
+        (energy #:mutable)
+        type))
+
+(define (build-cell pos radius threshold type)
+    (with-state
+        (push)
+        (hint-unlit)
+        (translate pos)
+        (scale radius)
+        (let ((root (build-sphere 7 7)))
+            (pop)
+            (parent root)
+            (scale threshold)
+            (opacity 0.3)
+            (if (eq? type 'photo)
+                (colour (vector 0 1 0))
+                (colour (vector 1 0.5 0)))
+            (let ((wall (build-sphere 7 7)))
+                (make-cell root wall pos radius threshold #f '() 0 type)))))
+
+(define (cell-connect! cell other)
+    (set-cell-connected! cell (cons other (cell-connected cell)))
+    (set-cell-connected! other (cons cell (cell-connected other))))
+
+(define (cell-disconnect cell other)
+    (set-cell-connected! cell (remove other (cell-connected cell)))
+    (set-cell-connected! other (remove cell (cell-connected other))))
+
+(define (choose l)
+    (list-ref l (random (length l))))
+
+(define (cell-divide cell organism)
+    (let ((new-cell (build-cell 
+                    (vadd (cell-pos cell) (vmul (srndvec) 3))
+                    (cell-radius cell) (cell-thresh cell) 
+            (choose '(photo struct struct struct absorb)))))
+        (cell-connect! cell new-cell)
+        (set-organism-cells! organism (cons new-cell
+                (organism-cells organism)))))
+
+(define (cell-update cell input organism photons)
+    
+    (with-primitive (cell-wall cell)
+        (if (null? (cell-connected cell))
+            (hide 1)
+            (hide 0)))
+    
+    (with-primitive (cell-root cell)
+        (cond ((eq? (cell-type cell) 'photo)
+                (colour (vmul (vector 0.5 1 0.5) (+ 0.5 (cell-energy cell)))))
+            ((eq? (cell-type cell) 'struct)
+                (colour (vmul (vector 1 0.7 0.3) (+ 0.5 (cell-energy cell)))))
+            ((eq? (cell-type cell) 'absorb)
+                (when (> (cell-energy cell) 1)
+                    (set-cell-energy! cell 0)
+                    (cell-divide cell organism))
+                (colour (vmul (vector 0.5 0.5 1) (+ 0.5 (cell-energy cell))))))
+        
+        
+        (when (or (eq? (send input get-selected) (cell-wall cell))
+                (eq? (send input get-selected) (cell-root cell)))
+            (translate (send input get-mouse-change))
+            (for-each            
+                (lambda (other)
+                    (when (and (not (eq? cell other))
+                            (not (contains? other (cell-connected cell))))
+                        
+                        (let ((dist (vdist (cell-pos cell) (cell-pos other))))
+                            (when (< dist (+ (cell-thresh cell) (cell-thresh other)))
+                                (cell-connect! other cell)))))
+                (organism-cells organism)))                
+        
+        
+        (let ((dir (foldl
+                        (lambda (other cur)
+                            (let ((dist (vdist (cell-pos cell) (cell-pos other))))
+                                (cond 
+                                    ; inside nucleus
+                                    ((< dist (+ (cell-radius cell) (cell-radius other)))
+                                        (vadd cur (vmul (vsub (cell-pos cell) (cell-pos other)) (* 0.1 (/ 1 dist)))))
+                                    ((< dist (+ (cell-thresh cell) (cell-thresh other)))
+                                        (vadd cur (vmul (vsub (cell-pos cell) (cell-pos other)) -0.01)))
+                                    (else
+                                        (cell-disconnect cell other)
+                                        cur))))
+                        (vector 0 0 0)
+                        (cell-connected cell))))
+            (when (eq? (cell-type cell) 'photo)
+                (translate (vector (vx dir) (vy dir) 0))))
+        
+        (when (and (eq? (cell-type cell) 'photo)
+                (not (null? (cell-connected cell))))
+            (with-primitive (photons-root photons)
+                (set-cell-energy! cell 
+                    (+ (pdata-fold 
+                            (lambda (p v)
+                                (if (< (vdist (cell-pos cell) p) (cell-radius cell))
+                                    (+ 0.2 v)
+                                    v))
+                            0 "p") (cell-energy cell)))))
+        
+        (when (zero? (random 10))
+            (for-each
+                (lambda (other)
+                    (when (> (cell-energy other) 0.1)
+                        (set-cell-energy! cell (+ (cell-energy cell) (* (cell-energy other) 0.49)))
+                        (set-cell-energy! other (* (cell-energy other) 0.49))))
+                (cell-connected cell)))
+        
+        (set-cell-pos! cell (vtransform (vector 0 0 0) (get-transform)))))
+
+
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+(define-struct organism ((cells #:mutable)))
+
+(define (build-organism count)
+    (make-organism 
+        (build-list count 
+            (lambda (_)
+                (build-cell (vmul (vector (crndf) (crndf) 0) 5) 1 2 
+                    (choose '(struct struct struct photo absorb)))))))
+
+(define (organism-update organism input photons)
+    (for-each
+        (lambda (cell)
+            (cell-update cell input organism photons))
+        (organism-cells organism)))
+
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+(clear)
+(clear-colour (vector 0.2 0.1 0.1))
+(define organism (build-organism 10))
+(define photons (build-photons 40))
+(define input (make-object input%))
+(define resources (build-resources))
+
+(define sky (with-state
+    (colour (vector 0.3 0.5 0.2))
+    (translate (vector 0 30 -10))
+    (scale (vector 150 60 0))
+    (build-plane)))
+
+(define (update)
+    (send input pre-update)
+    (organism-update organism input photons)
+    (photons-update photons)
+    (send input update))
+
+(every-frame (update)) 

cellular/cellular.scm

@@ -0,0 +1,144 @@
+(require scheme/class)
+
+(define (contains? a l)
+    (cond 
+        ((null? l) #f)
+        ((eq? (car l) a) #t)
+        (else (contains? a (cdr l)))))
+
+(define input%
+    (class object%
+        
+        (field
+            (last-mouse (vector 0 0 0))
+            (last-button #f)
+            (last-keys '())
+            (new-keys '())
+            (keys-pressed '())
+            (selected 0)
+            (zoom -10))
+        
+        (define/public (pre-update)
+            (when (and (not last-button) (mouse-button 1))
+               (set! selected (select (mouse-x) (mouse-y) 2))))
+        
+        (define/public (update)
+            (set! last-button (mouse-button 1))
+            (set! new-keys (append (keys-down) '() #;(get-special-keys-pressed)))
+            (set! keys-pressed (filter
+                    (lambda (key)
+                        (not (contains? key last-keys)))
+                    new-keys))
+            (set! last-keys new-keys)
+            (when (key-pressed "-") (set! zoom (* zoom 1.1)))
+            (when (key-pressed "=") (set! zoom (* zoom 0.9)))
+            (set-camera-transform (mtranslate (vector 0 0 zoom))))
+        
+        (define/public (get-keys-pressed)
+            keys-pressed)
+        
+        (define/public (get-selected)
+            selected)
+        
+        (define/public (mouse-b n)
+            (mouse-button n))
+        
+        (define/public (get-pos-from-mouse)
+            (let* ((ndcpos (vector (* (- (/ (mouse-x) (vx (get-screen-size))) 0.5) (* -2 zoom))
+                            (* (- (- (/ (mouse-y) (vy (get-screen-size))) 0.5)) (* -1.5 zoom)) -10))
+                    (scrpos (vtransform ndcpos (minverse (get-camera-transform)))))
+                scrpos))        
+        
+        (define/public (get-mouse-change)
+            (let ((r (if last-button (vsub (get-pos-from-mouse) last-mouse)
+                            (vector 0 0 0))))
+                (set! last-mouse (get-pos-from-mouse))
+                r))
+        
+        (super-new)))
+
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+(define-struct cell (root 
+        wall 
+        (pos #:mutable) 
+        radius 
+        thresh
+        (dragging #:mutable)
+        (connected #:mutable)))
+
+(define (build-cell pos radius threshold)
+    (with-state
+        (push)
+        (hint-unlit)
+        (translate pos)
+        (scale radius)
+        (let ((root (build-sphere 7 7)))
+            (pop)
+            (parent root)
+            (scale threshold)
+            (opacity 0.3)
+            (let ((wall (build-sphere 7 7)))
+                (make-cell root wall pos radius threshold #f '())))))
+
+(define (cell-add-connected! cell other)
+    (set-cell-connected! cell (cons other (cell-connected cell))))
+
+(define (cell-update cell input organism)
+    (with-primitive (cell-root cell)
+        (when (eq? (send input get-selected) (cell-wall cell))
+            (translate (send input get-mouse-change))
+            (for-each            
+                (lambda (other)
+                    (when (not (eq? cell other))
+                        (let ((dist (vdist (cell-pos cell) (cell-pos other))))
+                            (when (< dist (+ (cell-thresh cell) (cell-thresh other)))
+                                (cell-add-connected! cell other)
+                                (cell-add-connected! other cell)))))
+                organism))
+        
+        (let ((dir (foldl
+                        (lambda (other cur)
+                            (if (not (eq? cell other))
+                                (let ((dist (vdist (cell-pos cell) (cell-pos other))))
+                                    (cond 
+                                        ; inside nucleus
+                                        ((< dist (+ (cell-radius cell) (cell-radius other)))
+                                            (vadd cur (vmul (vsub (cell-pos cell) (cell-pos other)) 0.01)))
+                                        ((< dist (+ (cell-thresh cell) (cell-thresh other)))
+                                            (vadd cur (vmul (vsub (cell-pos cell) (cell-pos other)) -0.01)))
+                                        (else
+                                            cur)))
+                                cur))
+                        (vector 0 0 0)
+                        (cell-connected cell))))
+            (translate (vmul (vector (vx dir) (vy dir) 0) 0.1)))
+        
+        (set-cell-pos! cell (vtransform (vector 0 0 0) (get-transform)))))
+
+
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+(define (build-organism count)
+    (build-list count (lambda (_) (build-cell (vmul (vector (crndf) (crndf) 0) 5) 1 1.5))))
+
+(define (organism-update organism input)
+    (for-each
+        (lambda (cell)
+            (cell-update cell input organism))
+        organism))
+
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+(clear)
+(define organism (build-organism 10))
+
+(define input (make-object input%))
+
+(define (update)
+    (send input pre-update)
+    (organism-update organism input)
+    (send input update))
+
+(every-frame (update)) 

danceplant/borrowed.scm

@@ -0,0 +1,465 @@
+;#lang scheme/base
+;(require fluxus-016/drflux)
+
+(define max-tokens 3000)
+(define additive-growth #t)
+
+(define (texpath s)
+    (string-append "/home/dave/flotsam/groworld/game-prototypes/danceplant/" s))
+
+(define-struct token (char gen age id (root #:mutable)))
+
+(define nxt-id 0)
+
+(define (token-gid) 
+    (set! nxt-id (+ nxt-id 1))
+    nxt-id)
+
+(define (reset-token-gid)
+    (set! nxt-id 0))
+
+(define (token-eq? a b)
+    (eq? (token-char a) (token-char b)))
+
+(define (token-copy a gen)
+    (make-token (token-char a) gen (token-age a) (token-gid) 0))
+
+(define (make-token-list str)
+    (map
+        (lambda (char)
+            (make-token char 0 0 0 0))
+        (string->list str)))
+
+(define (copy-token-list str gen)
+    (map 
+        (lambda (token)
+            (token-copy token gen))
+        str))
+
+(define (print-token-list tl)
+    (for-each
+        (lambda (token)
+            (printf "~a" (token-char token)))
+        tl)
+    (newline))
+
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+(define-struct ls-rule (from to))
+
+; make a rule from a char and a string
+(define (make-rule from to)
+    (when (not (char? from)) (error ""))
+    (make-ls-rule
+        (make-token from 0 0 0 0)
+        (make-token-list to)))
+
+; convert a list of strings into a list of rules
+(define (make-rule-list l)
+    (map
+        (lambda (r)
+            (make-rule (string-ref (car r) 0) (cadr r)))
+        l))
+
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+(define-struct plant ((rules #:mutable) 
+        axiom
+        angle
+        branch-scale
+        (str #:mutable) 
+        (gen #:mutable) 
+        (root #:mutable)        
+        base-root
+        (components #:mutable)
+        (anim-time #:mutable)
+        (col #:mutable)
+        (decay #:mutable)))
+
+(define (build-plant axiom angle branch-scale rules)
+    (let ((base-root (build-locator)))
+        (with-state
+            (parent base-root)
+            (make-plant (make-rule-list rules) (make-token-list axiom)
+                angle branch-scale (make-token-list axiom) 0 (build-locator) 
+                base-root '() (time) (vector 1 1 1) #f))))
+
+(define (plant-clear plant)
+    (set-plant-gen! plant 0)
+    (set-plant-str! plant (copy-token-list (plant-axiom plant) 0))
+    (set-plant-components! plant '()))
+
+(define (plant-inc-gen plant)
+    (when (not (plant-decay plant))
+        (set-plant-anim-time! plant (time))
+        (set-plant-gen! plant (+ (plant-gen plant) 1))
+        (destroy (plant-root plant))
+        (with-state
+            (parent (plant-base-root plant))
+            (set-plant-root! plant (build-locator)))
+        (reset-token-gid)
+        (plant-generate plant)        
+        (plant-print plant)        
+        (set-plant-components! plant (build-components plant (plant-root plant) 
+                (plant-angle plant) (plant-branch-scale plant)))))
+
+(define (plant-update plant time)            
+    (components-update plant (plant-components plant) time))
+
+(define (plant-print plant)
+    (print-token-list (plant-str plant)))
+
+(define (plant-add-to-rule plant n s)
+    
+    (cond ((plant-decay plant)
+            (component-do-decay plant (plant-components plant)))
+        (else
+            
+            (let ((c 0))
+                (set-plant-rules! plant 
+                    (map 
+                        (lambda (rule)
+                            (set! c (+ c 1))
+                            (if (eq? (- c 1) n)
+                                (make-ls-rule (ls-rule-from rule)
+                                    (append (ls-rule-to rule) 
+                                        (map
+                                            (lambda (char)
+                                                (make-token char -1 (plant-gen plant) 0 0))
+                                            (string->list s))))
+                                rule))
+                        (plant-rules plant)))))))
+
+; try all the rules on this token - returns #f if none are matched
+(define (plant-run-rules plant token gen)
+    (foldl
+        (lambda (rule str)
+            (if str ; if str is not #f
+                str ; then we have already found a rule, return it
+                (if (and (token-eq? token (ls-rule-from rule)) ; check this rule
+                        (< (length (plant-str plant)) max-tokens))
+                    (copy-token-list (ls-rule-to rule) gen) ; return the result
+                    #f))) ; no match
+        #f
+        (plant-rules plant)))
+
+; runs the lsystem rules on every token in a list, returns the new list
+(define (plant-search-replace plant pos result gen)
+    (cond 
+        ((>= pos (length (plant-str plant))) result)
+        (else
+            (let ((ret (plant-run-rules plant (list-ref (plant-str plant) pos) gen)))
+                (if (list? ret)
+                    (plant-search-replace plant (+ pos 1) (append result ret) gen)
+                    (plant-search-replace plant (+ pos 1) 
+                        (append result (list (list-ref (plant-str plant) pos))) gen))))))
+
+(define (plant-generate plant)
+    (when (< (length (plant-str plant)) max-tokens)
+        ;    (print-token-list (plant-str plant))
+        (cond (additive-growth
+                (set-plant-str! plant (plant-search-replace plant 0 
+                        '() (plant-gen plant))))
+            (else
+                ; reset the string
+                (set-plant-str! plant (copy-token-list (plant-axiom plant) 0))
+                (for ((i (in-range 0 (plant-gen plant))))
+                    (set-plant-str! plant (plant-search-replace plant 0 '() (+ i 1))))))))
+
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+(define-struct component (type root gen rot sc id (decay #:mutable) fall))
+
+(define (components-update plant components time)
+    (for-each
+        (lambda (component)
+            (cond ((component-decay component)
+                    (with-primitive (component-root component)
+                        (translate (component-fall component))))
+                (else
+                    (let ((growing (eq? (plant-gen plant) (component-gen component)))
+                            (t (- time (plant-anim-time plant))))
+                        (with-primitive (component-root component)
+                            (identity)
+                            (translate (vector 1 0 0))        
+                            
+                            (rotate (vector 0 (+ (* 0.5 (sin (+ (component-id component) 
+                                                    (* 1 time))))) 0))
+                            
+                            (if (and growing (< t 1))
+                                (rotate (vector 0 (* t (component-rot component)) 0))                        
+                                (rotate (vector 0 (component-rot component) 0)))
+                            
+                            (scale (component-sc component))
+                            (when (and growing (< t 1)) (scale (vector t 1 1))))))))
+        components))
+
+
+#;(define (component-do-decay plant components)
+    (for-each
+        (lambda (component)
+            (when (null? (with-primitive (component-root component) (get-children)))
+                (set-component-decay! component #t)
+                (with-primitive (component-root component)
+                    (detach-parent)
+                    ;                    (apply-transform)
+                    (parent (plant-root plant)))))
+        components))
+
+(define (component-do-decay plant components)
+    (for-each
+        (lambda (component)
+            (set-component-decay! component #t)
+            (with-primitive (component-root component)
+                (detach-parent)
+                (apply-transform)
+                (parent (plant-root plant))))
+        (filter 
+            (lambda (component)
+                (null? (with-primitive (component-root component) (get-children))))
+            components)))
+
+
+; builds objects from a list of tokens
+(define (build-components plant root angle branch-scale)
+    (let ((parent-stack '(root))
+            (last-obj root)
+            (rot 0)
+            (sc 1)
+            (sc-stack '(1))
+            (rot-stack '(0))
+            (bo (with-state                    
+                    (rotate (vector 90 0 0))
+                    (translate (vector 0.5 0 0))
+                    (scale (vector 1.1 0.5 0.5))
+                    (build-plane)))
+            (lo (with-state                    
+                    (rotate (vector 90 0 0))
+                    (translate (vector 0.5 0 0))
+                    (build-plane))))
+        
+        
+        (define (build-obj-component token)
+            (let ((obj (with-state
+;                            (colour (* (vx (plant-col plant)) 4))
+                            (hint-ignore-depth)
+                            (cond 
+                                ((char=? #\F (token-char token))
+                                    (texture (load-texture (texpath "textures/lina-branch1.png"))))
+                                ((char=? #\G (token-char token))
+                                    (texture (load-texture (texpath "textures/lina-branch1.png"))))
+                                ((char=? #\L (token-char token))
+                                    (texture (load-texture (texpath "textures/lina-leaf1.png"))))
+                                ((char=? #\M (token-char token))
+                                    (texture (load-texture (texpath "textures/lina-leaf1.png")))))
+                            (hint-unlit)
+                            (cond ((or (char=? #\F (token-char token))
+                                        (char=? #\G (token-char token)))
+                                    (build-copy bo))
+                                ((or (char=? #\L (token-char token))
+                                        (char=? #\M (token-char token)))
+                                    (build-copy lo))))))
+                (with-primitive obj
+                    (hide 0)
+                    (when (not (zero? last-obj))
+                        (parent last-obj)))
+                (set! last-obj obj)
+                (make-component (token-char token) obj
+                    ;                    (if (> (token-age token) (token-gen token))
+                        ;                        (+ (token-age token) 1)
+                        (token-gen token);)
+                    rot sc (token-id token) #f (srndvec))))
+        
+        (with-primitive bo
+            (hide 1)
+            (pdata-set! "t" 0 (vector 0 0 0))
+            (pdata-set! "t" 1 (vector 0 1 0))
+            (pdata-set! "t" 2 (vector 1 1 0))
+            (pdata-set! "t" 3 (vector 1 0 0))
+            (apply-transform))
+        
+        (with-primitive lo
+            (hide 1)
+            (pdata-set! "t" 0 (vector 1 1 0))
+            (pdata-set! "t" 1 (vector 1 0 0))
+            (pdata-set! "t" 2 (vector 0 0 0))
+            (pdata-set! "t" 3 (vector 0 1 0))
+            (apply-transform))
+        
+        (foldl
+            (lambda (token ret)
+                (let ((char (token-char token)))
+                    (cond 
+                        ((or (char=? #\F char) (char=? #\G char) (char=? #\L char) (char=? #\M char))
+                            (let ((r (build-obj-component token)))
+                                (set! rot 0)
+                                (cons r ret)))
+                        ((char=? #\+ char) (set! rot (+ rot angle)) ret)
+                        ((char=? #\- char) (set! rot (- rot angle)) ret)
+                        ((char=? #\[ char)
+                                (set! parent-stack (cons last-obj parent-stack))
+                                (set! sc-stack (cons sc sc-stack))
+                                (set! sc (* sc branch-scale))
+                                (set! rot-stack (cons rot rot-stack))
+                                ret)
+                            ((char=? #\] char)
+                            (set! last-obj (car parent-stack))                        
+                            (set! parent-stack (cdr parent-stack))
+                            (set! sc (car sc-stack))                        
+                            (set! sc-stack (cdr sc-stack))
+                            (set! rot (car rot-stack))                        
+                            (set! rot-stack (cdr rot-stack))
+                            ret)
+                        (else ret))))
+            '()
+            (plant-str plant))))
+
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+(define (choose l)
+    (list-ref l (random (length l))))
+
+(define (build-foliage count rules)
+    (build-list count 
+        (lambda (_) 
+            (with-state
+                (translate (vector 0 (+ 0 (* (rndf) 10)) (* 15 (crndf))))
+                (build-plant "FA" (* 40 (crndf)) 0.96 (choose rules))))))
+
+
+(define (foliage-grow foliage)
+    (for-each
+        (lambda (plant)
+            (for ((i (in-range 4 (random 10))))
+                (set-plant-col! plant (vmul (vector 0 0.6 0.6) (rndf)))
+                (plant-inc-gen plant)))
+        foliage))
+
+(define (foliage-update foliage time)
+    (for-each
+        (lambda (plant)
+            (plant-update plant time))
+        foliage))
+
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+(define debounce-vec (build-vector 10 (lambda (_) #f)))
+
+(define (debounce n)
+    (vector-ref debounce-vec n))
+
+(define (debounce! n s)
+    (vector-set! debounce-vec n s))
+
+(define (on-key p n proc)
+    (if p
+        (when (debounce n)
+            (proc)
+            (debounce! n #f))
+        (debounce! n #t)))
+
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+(clear)
+(clear-colour (vector 0 0 0))
+#;(set-camera-transform (mmul (mtranslate (vector 0 -5 -7))
+        (mrotate (vector 90 90 180))))
+
+(with-state
+    (hint-unlit)
+    (colour (vector 0 0 0))
+    (scale 100)
+    (rotate (vector 0 90 0))
+    (build-plane))
+
+(define foliage (build-foliage 30
+        '((("A" "F[-[+++FM]G[-FL]+A]"))
+            (("A" "F-F[++AL]G-A"))
+            (("A" "F++[+A+FFL]")))))
+
+(foliage-grow foliage)
+
+(define rules '(("a" "F") ("b" "F") ("A" "[a][b]")))
+(define p (build-plant "FA" 40 0.96 rules))
+(set-plant-col! p (vector 0.5 1 0.5))
+(define decay-count 0)
+
+(define (animate)
+    
+    #;((when (and (zero? decay-count)
+            (or (> (length (plant-str p)) max-tokens) (> (plant-gen p) 20)))
+        (set! decay-count 1)
+        (set-plant-decay! p #t))
+    
+    (when (> decay-count 0)
+        (set! decay-count (+ decay-count 1))
+        ;        (display decay-count)(newline)
+        )
+    
+    (when (> decay-count 100)
+        (set! decay-count 0) 
+        (set-plant-decay! p #f)
+        (plant-clear p)
+        (set-plant-rules! p (make-rule-list rules))
+        (plant-inc-gen p))
+    
+    (on-key (key-special-pressed 101) 0 ; up
+        (lambda ()
+            (plant-add-to-rule p 0 "G+a")
+            (plant-add-to-rule p 1 "G-b")
+            (plant-inc-gen p)))
+    
+    (on-key (key-special-pressed 100) 1 ; left
+        (lambda ()
+            (plant-add-to-rule p 0 "+F+b")
+            (plant-add-to-rule p 1 "+F+a")
+            (plant-inc-gen p)))
+    
+    (on-key (key-special-pressed 102) 2 ; right
+        (lambda ()
+            (plant-add-to-rule p 0 "-F-a")
+            (plant-add-to-rule p 1 "-F-b")
+            (plant-inc-gen p)))
+    
+    (on-key (key-special-pressed 103) 3 ; down
+        (lambda ()
+            (plant-add-to-rule p 0 "[F++b-FL]")
+            (plant-add-to-rule p 1 "[F--a+FL]")
+            (plant-inc-gen p)))
+    
+    (on-key (key-pressed "q") 4
+        (lambda ()
+            (plant-inc-gen p)
+            (plant-add-to-rule p 0 "bF-a")))
+    
+    (on-key (key-pressed "e") 4
+        (lambda ()
+            (plant-inc-gen p)
+            (plant-add-to-rule p 1 "a-bF")))
+    
+    (on-key (key-pressed "z") 5
+        (lambda ()
+            (plant-inc-gen p)
+            (plant-add-to-rule p 1 "b[+M]")))
+    
+    (on-key (key-pressed "c") 6
+        (lambda ()
+            (plant-add-to-rule p 0 "a+[--M]")
+            (plant-inc-gen p)))
+    
+    (on-key (key-pressed "s") 7
+        (lambda ()
+            (plant-add-to-rule p 0 "A")
+            (plant-add-to-rule p 1 "A")
+            (plant-inc-gen p)))           
+    
+    (on-key (key-pressed (string #\newline)) 8
+        (lambda ()
+            (plant-clear p)
+            (set-plant-rules! p (make-rule-list rules)))))
+    
+    
+    (plant-update p (time))
+    (foliage-update foliage (time)))
+
+(every-frame (animate))

danceplant/danceplant.scm

@@ -0,0 +1,415 @@
+(define max-tokens 3000)
+(define additive-growth #t)
+
+(define (texpath s)
+    (string-append "/home/dave/flotsam/groworld/game-prototypes/danceplant/" s))
+
+(define-struct token (char gen age id (root #:mutable)))
+
+(define nxt-id 0)
+
+(define (token-gid) 
+    (set! nxt-id (+ nxt-id 1))
+    nxt-id)
+
+(define (reset-token-gid)
+    (set! nxt-id 0))
+
+(define (token-eq? a b)
+    (eq? (token-char a) (token-char b)))
+
+(define (token-copy a gen)
+    (make-token (token-char a) gen (token-age a) (token-gid) 0))
+
+(define (make-token-list str)
+    (map
+        (lambda (char)
+            (make-token char 0 0 0 0))
+        (string->list str)))
+
+(define (copy-token-list str gen)
+    (map 
+        (lambda (token)
+            (token-copy token gen))
+        str))
+
+(define (print-token-list tl)
+    (for-each
+        (lambda (token)
+            (printf "~a" (token-char token)))
+        tl)
+    (newline))
+
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+(define-struct ls-rule (from to))
+
+; make a rule from a char and a string
+(define (make-rule from to)
+    (when (not (char? from)) (error ""))
+    (make-ls-rule
+        (make-token from 0 0 0 0)
+        (make-token-list to)))
+
+; convert a list of strings into a list of rules
+(define (make-rule-list l)
+    (map
+        (lambda (r)
+            (make-rule (string-ref (car r) 0) (cadr r)))
+        l))
+
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+(define-struct plant ((rules #:mutable) 
+        axiom
+        angle
+        branch-scale
+        (str #:mutable) 
+        (gen #:mutable) 
+        (root #:mutable)        
+        base-root
+        (components #:mutable)
+        (anim-time #:mutable)
+        (col #:mutable)))
+
+(define (build-plant axiom angle branch-scale rules)
+    (let ((base-root (build-locator)))
+        (with-state
+            (parent base-root)
+            (make-plant (make-rule-list rules) (make-token-list axiom)
+                angle branch-scale (make-token-list axiom) 0 (build-locator) 
+                base-root '() (time) (vector 1 1 1)))))
+
+(define (plant-clear plant)
+    (set-plant-gen! plant 0)
+    (set-plant-str! plant (copy-token-list (plant-axiom plant) 0))
+    (set-plant-components! plant '()))
+
+(define (plant-inc-gen plant)
+    (set-plant-anim-time! plant (time))
+    (set-plant-gen! plant (+ (plant-gen plant) 1))
+    (destroy (plant-root plant))
+    (with-state
+        (parent (plant-base-root plant))
+        (set-plant-root! plant (build-locator)))
+    (reset-token-gid)
+    (plant-generate plant)        
+    ; (plant-print plant)        
+    (set-plant-components! plant (build-components plant (plant-root plant) 
+            (plant-angle plant) (plant-branch-scale plant))))
+
+(define (plant-update plant time)            
+    (components-update plant (plant-components plant) time))
+
+(define (plant-print plant)
+    (print-token-list (plant-str plant)))
+
+(define (plant-add-to-rule plant n s)
+    (let ((c 0))
+        (set-plant-rules! plant 
+            (map 
+                (lambda (rule)
+                    (set! c (+ c 1))
+                    (if (eq? (- c 1) n)
+                        (make-ls-rule (ls-rule-from rule)
+                            (append (ls-rule-to rule) 
+                                (map
+                                    (lambda (char)
+                                        (make-token char -1 (plant-gen plant) 0 0))
+                                    (string->list s))))
+                        rule))
+                (plant-rules plant)))))
+
+; try all the rules on this token - returns #f if none are matched
+(define (plant-run-rules plant token gen)
+    (foldl
+        (lambda (rule str)
+            (if str ; if str is not #f
+                str ; then we have already found a rule, return it
+                (if (and (token-eq? token (ls-rule-from rule)) ; check this rule
+                        (< (length (plant-str plant)) max-tokens))
+                    (copy-token-list (ls-rule-to rule) gen) ; return the result
+                    #f))) ; no match
+        #f
+        (plant-rules plant)))
+
+; runs the lsystem rules on every token in a list, returns the new list
+(define (plant-search-replace plant pos result gen)
+    (cond 
+        ((>= pos (length (plant-str plant))) result)
+        (else
+            (let ((ret (plant-run-rules plant (list-ref (plant-str plant) pos) gen)))
+                (if (list? ret)
+                    (plant-search-replace plant (+ pos 1) (append result ret) gen)
+                    (plant-search-replace plant (+ pos 1) 
+                        (append result (list (list-ref (plant-str plant) pos))) gen))))))
+
+(define (plant-generate plant)
+    (when (< (length (plant-str plant)) max-tokens)
+        ;    (print-token-list (plant-str plant))
+        (cond (additive-growth
+                (set-plant-str! plant (plant-search-replace plant 0 
+                        '() (plant-gen plant))))
+            (else
+                ; reset the string
+                (set-plant-str! plant (copy-token-list (plant-axiom plant) 0))
+                (for ((i (in-range 0 (plant-gen plant))))
+                    (set-plant-str! plant (plant-search-replace plant 0 '() (+ i 1))))))))
+
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+(define-struct component (type root gen rot sc id decay))
+
+(define (components-update plant components time)
+    (for-each
+        (lambda (component)
+            (cond ((component-decay component)
+                    (with-primitive (component-root component)
+                        (translate (vector 0 0 -0.1))))
+                (else
+                    (let ((growing (eq? (plant-gen plant) (component-gen component)))
+                            (t (- time (plant-anim-time plant))))
+                        (with-primitive (component-root component)
+                            (identity)
+                            (translate (vector 1 0 0))        
+                            
+                            (rotate (vector 0 (+ (* 0.5 (sin (+ (component-id component) 
+                                                    (* 1 time))))) 0))
+                            
+                            (if (and growing (< t 1))
+                                (rotate (vector 0 (* t (component-rot component)) 0))                        
+                                (rotate (vector 0 (component-rot component) 0)))
+                            
+                            (scale (component-sc component))
+                            (when (and growing (< t 1)) (scale (vector t 1 1))))))))
+        components))
+
+; builds objects from a list of tokens
+(define (build-components plant root angle branch-scale)
+    (let ((parent-stack '(root))
+            (last-obj root)
+            (rot 0)
+            (sc 1)
+            (sc-stack '(1))
+            (rot-stack '(0))
+            (bo (with-state                    
+                    (rotate (vector 90 0 0))
+                    (translate (vector 0.5 0 0))
+                    (scale (vector 1.1 0.5 0.5))
+                    (build-plane)))
+            (lo (with-state                    
+                    (rotate (vector 90 0 0))
+                    (translate (vector 0.5 0 0))
+                    (build-plane))))
+        
+        
+        (define (build-obj-component token)
+            (let ((obj (with-state
+                            (colour (plant-col plant))
+                            (hint-ignore-depth)
+                            (cond 
+                                ((char=? #\F (token-char token))
+                                    (texture (load-texture (texpath "textures/branch-a.png"))))
+                                ((char=? #\G (token-char token))
+                                    (texture (load-texture (texpath "textures/branch-b.png"))))
+                                ((char=? #\L (token-char token))
+                                    (texture (load-texture (texpath "textures/leaf-a.png"))))
+                                ((char=? #\M (token-char token))
+                                    (texture (load-texture (texpath "textures/leaf-b.png")))))
+                            (hint-unlit)
+                            (cond ((or (char=? #\F (token-char token))
+                                        (char=? #\G (token-char token)))
+                                    (build-copy bo))
+                                ((or (char=? #\L (token-char token))
+                                        (char=? #\M (token-char token)))
+                                    (build-copy lo))))))
+                (with-primitive obj
+                    (hide 0)
+                    (when (not (zero? last-obj))
+                        (parent last-obj)))
+                (set! last-obj obj)
+                (make-component (token-char token) obj
+                    ;                    (if (> (token-age token) (token-gen token))
+                        ;                        (+ (token-age token) 1)
+                        (token-gen token);)
+                    rot sc (token-id token) #f)))
+        
+        (with-primitive bo
+            (hide 1)
+            (pdata-set! "t" 0 (vector 0 0 0))
+            (pdata-set! "t" 1 (vector 0 1 0))
+            (pdata-set! "t" 2 (vector 1 1 0))
+            (pdata-set! "t" 3 (vector 1 0 0))
+            (apply-transform))
+        
+        (with-primitive lo
+            (hide 1)
+            (pdata-set! "t" 0 (vector 1 1 0))
+            (pdata-set! "t" 1 (vector 1 0 0))
+            (pdata-set! "t" 2 (vector 0 0 0))
+            (pdata-set! "t" 3 (vector 0 1 0))
+            (apply-transform))
+        
+        (foldl
+            (lambda (token ret)
+                (let ((char (token-char token)))
+                    (cond 
+                        ((or (char=? #\F char) (char=? #\G char) (char=? #\L char) (char=? #\M char))
+                            (let ((r (build-obj-component token)))
+                                (set! rot 0)
+                                (cons r ret)))
+                        ((char=? #\+ char) (set! rot (+ rot angle)) ret)
+                        ((char=? #\- char) (set! rot (- rot angle)) ret)
+                        ((char=? #\[ char)
+                                (set! parent-stack (cons last-obj parent-stack))
+                                (set! sc-stack (cons sc sc-stack))
+                                (set! sc (* sc branch-scale))
+                                (set! rot-stack (cons rot rot-stack))
+                                ret)
+                            ((char=? #\] char)
+                            (set! last-obj (car parent-stack))                        
+                            (set! parent-stack (cdr parent-stack))
+                            (set! sc (car sc-stack))                        
+                            (set! sc-stack (cdr sc-stack))
+                            (set! rot (car rot-stack))                        
+                            (set! rot-stack (cdr rot-stack))
+                            ret)
+                        (else ret))))
+            '()
+            (plant-str plant))))
+
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+(define (choose l)
+    (list-ref l (random (length l))))
+
+(define (build-foliage count rules)
+    (build-list count 
+        (lambda (_) 
+            (with-state
+                (translate (vector 0 (+ 0 (* (rndf) 10)) (* 15 (crndf))))
+                (build-plant "FA" (* 40 (crndf)) 0.96 (choose rules))))))
+
+
+(define (foliage-grow foliage)
+    (for-each
+        (lambda (plant)
+            (for ((i (in-range 2 (random 10))))
+                (set-plant-col! plant (vmul (vector 0 0.6 0.6) (rndf)))
+                (plant-inc-gen plant)))
+        foliage))
+
+(define (foliage-update foliage time)
+    (for-each
+        (lambda (plant)
+            (plant-update plant time))
+        foliage))
+
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+(define debounce-vec (build-vector 10 (lambda (_) #f)))
+
+(define (debounce n)
+    (vector-ref debounce-vec n))
+
+(define (debounce! n s)
+    (vector-set! debounce-vec n s))
+
+(define (on-key p n proc)
+    (if p
+        (when (debounce n)
+            (proc)
+            (debounce! n #f))
+        (debounce! n #t)))
+
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+(clear)
+(clear-colour (vector 0 0.5 0.4))
+(set-camera-transform (mmul (mtranslate (vector 0 -5 -10))
+        (mrotate (vector 90 90 180))))
+
+(with-state
+    (hint-unlit)
+    (colour (vector 0 0.4 0.3))
+    (scale 100)
+    (rotate (vector 0 90 0))
+    (build-plane))
+
+(define foliage (build-foliage 30
+        '((("A" "F[-[+++FM]G[-FL]+A]"))
+            (("A" "F-F[++AL]G-A"))
+            (("A" "F++[+A+FFL]")))))
+
+(foliage-grow foliage)
+
+(define rules '(("a" "F") ("b" "F") ("A" "[a][b]")))
+(define p (build-plant "FA" 40 0.96 rules))
+(set-plant-col! p (vector 0.5 1 0.5))
+
+(define (animate)
+    
+    (on-key (key-special-pressed 101) 0 ; up
+        (lambda ()
+            (plant-add-to-rule p 0 "G+a")
+            (plant-add-to-rule p 1 "G-b")
+            (plant-inc-gen p)))
+    
+    (on-key (key-special-pressed 100) 1 ; left
+        (lambda ()
+            (plant-add-to-rule p 0 "+F+b")
+            (plant-add-to-rule p 1 "+F+a")
+            (plant-inc-gen p)))
+    
+    (on-key (key-special-pressed 102) 2 ; right
+        (lambda ()
+            (plant-add-to-rule p 0 "-F-a")
+            (plant-add-to-rule p 1 "-F-b")
+            (plant-inc-gen p)))
+    
+    (on-key (key-special-pressed 103) 3 ; down
+        (lambda ()
+            (plant-add-to-rule p 0 "[F++b-FL]")
+            (plant-add-to-rule p 1 "[F--a+FL]")
+            (plant-inc-gen p)))
+    
+    (on-key (key-pressed "q") 4
+        (lambda ()
+            (plant-inc-gen p)
+            (plant-add-to-rule p 0 "b-A")))
+    
+    (on-key (key-pressed "e") 4
+        (lambda ()
+            (plant-inc-gen p)
+            (plant-add-to-rule p 1 "a-A")))
+    
+    (on-key (key-pressed "z") 5
+        (lambda ()
+            (plant-inc-gen p)
+            (plant-add-to-rule p 1 "b[+AM]")))
+    
+    (on-key (key-pressed "c") 6
+        (lambda ()
+            (plant-add-to-rule p 0 "a+[--AM]")
+            (plant-inc-gen p)))
+    
+    (on-key (key-pressed "s") 7
+        (lambda ()
+            (plant-add-to-rule p 0 "A")
+            (plant-add-to-rule p 1 "A")
+            (plant-inc-gen p)))           
+    
+    (on-key (key-pressed (string #\newline)) 8
+        (lambda ()
+            (plant-clear p)
+            (set-plant-rules! p (make-rule-list rules))))
+    
+    (when (or (> (length (plant-str p)) max-tokens) (> (plant-gen p) 20))
+        (plant-clear p)
+        (set-plant-rules! p (make-rule-list rules))
+        (plant-inc-gen p))
+    
+    (plant-update p (time))
+    (foliage-update foliage (time)))
+
+(every-frame (animate))

danceplant/danceplant2.scm

@@ -0,0 +1,242 @@
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+; slightly more advanced lsystem for
+; interactive growth. 
+;
+; doing away with strings.
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+(define-struct token (char gen age id (root #:mutable)))
+
+(define nxt-id 0)
+
+(define (token-gid) 
+    (set! nxt-id (+ nxt-id 1))
+    nxt-id)
+
+(define (reset-token-gid)
+    (set! nxt-id 0))
+
+(define (token-eq? a b)
+    (eq? (token-char a) (token-char b)))
+
+(define (token-copy a gen)
+    (make-token (token-char a) gen (token-age a) (token-gid) 0))
+
+(define (make-token-list str)
+    (map
+        (lambda (char)
+            (make-token char 0 0 0 0))
+        (string->list str)))
+
+(define (copy-token-list str gen)
+    (map 
+        (lambda (token)
+            (token-copy token gen))
+        str))
+
+(define (print-token-list tl)
+    (for-each
+        (lambda (token)
+            (printf "(~a ~a ~a)" (token-char token) (token-gen token) (token-age token)))
+        tl)
+    (newline))
+
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+(define-struct ls-rule (from to))
+
+; make a rule from a char and a string
+(define (make-rule from to)
+    (when (not (char? from)) (error ""))
+    (make-ls-rule
+        (make-token from 0 0 0 0)
+        (make-token-list to)))
+
+; convert a list of strings into a list of rules
+(define (make-rule-list l)
+    (map
+        (lambda (r)
+            (make-rule (string-ref (car r) 0) (cadr r)))
+        l))
+
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+(define-struct plant ((rules #:mutable) 
+        axiom
+        angle
+        branch-scale
+        (str #:mutable) 
+        (gen #:mutable) 
+        (root #:mutable)
+        (components #:mutable)))
+
+(define (build-plant root angle branch-scale rules)
+    (make-plant (make-rule-list rules) (make-token-list "FA")
+        angle branch-scale '() 0 root '()))
+
+(define (plant-clear plant)
+    (set-plant-gen! plant 0)
+    (set-plant-str! plant (copy-token-list (plant-axiom plant) 0))
+    (set-plant-components! plant '()))
+
+(define (plant-update plant time)
+        
+    (when (> (inexact->exact (floor time)) (plant-gen plant))
+        (when (< time (plant-gen plant)) (plant-clear plant))
+        (set-plant-gen! plant (inexact->exact (floor time)))        
+        (destroy (plant-root plant))
+        (set-plant-root! plant (build-locator))        
+        (reset-token-gid)
+        (plant-generate plant)        
+        ; (plant-print plant)        
+        (set-plant-components! plant (build-components plant (plant-root plant) 
+                (plant-angle plant) (plant-branch-scale plant))))
+    
+    (components-update (plant-components plant) time))
+
+(define (plant-print plant)
+    (print-token-list (plant-str plant)))
+
+(define (plant-add-to-rule plant n char)
+    (let ((c 0))
+        (set-plant-rules! plant 
+            (map 
+                (lambda (rule)
+                    (set! c (+ c 1))
+                    (if (eq? (- c 1) n)
+                        (make-ls-rule (ls-rule-from rule)
+                            (append (ls-rule-to rule) 
+                                (list (make-token char -1 (plant-gen plant) 0))))
+                        rule))
+                (plant-rules plant)))))
+
+; try all the rules on this token - returns #f if none are matched
+(define (plant-run-rules plant token gen)
+    (foldl
+        (lambda (rule str)
+            (if str ; if str is not #f
+                str ; then we have already found a rule, return it
+                (if (token-eq? token (ls-rule-from rule)) ; check this rule
+                    (copy-token-list (ls-rule-to rule) gen) ; return the result
+                    #f))) ; no match
+        #f
+        (plant-rules plant)))
+
+; runs the lsystem rules on every token in a list, returns the new list
+(define (plant-search-replace plant pos result gen)
+    (cond 
+        ((>= pos (length (plant-str plant))) result)
+        (else
+            (let ((ret (plant-run-rules plant (list-ref (plant-str plant) pos) gen)))
+                (if (list? ret)
+                    (plant-search-replace plant (+ pos 1) (append result ret) gen)
+                    (plant-search-replace plant (+ pos 1) 
+                        (append result (list (list-ref (plant-str plant) pos))) gen))))))
+
+(define (plant-generate plant)
+    ; reset the string
+    (set-plant-str! plant (copy-token-list (plant-axiom plant) 0))
+    (for ((i (in-range 0 (plant-gen plant))))
+        (set-plant-str! plant (plant-search-replace plant 0 '() (+ i 1)))))
+
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+(define-struct component (type root t rot sc id))
+
+(define (components-update components time)
+    (for-each
+        (lambda (component)
+            (let ((t (- time (component-t component))))
+                (with-primitive (component-root component)
+                    (identity)
+                    (translate (vector 1 0 0))        
+                    
+                    (rotate (vector 0 (+ (* 5 (sin (+ (component-id component) 
+                        (* 3 time))))) 0))
+                    
+                    (if (< t 1)
+                        (rotate (vector 0 (* t (component-rot component)) 0))                        
+                        (rotate (vector 0 (component-rot component) 0)))
+                    
+                    (scale (component-sc component))
+                    (when (< t 1) (scale (vector t 1 1))))))
+        components))
+
+; builds objects from a list of tokens
+(define (build-components plant root angle branch-scale)
+    (let ((parent-stack '(root))
+            (last-obj root)
+            (rot 0)
+            (sc 1)
+            (sc-stack '(1))
+            (rot-stack '(0))
+            (o (with-state                    
+                    (rotate (vector 90 0 0))
+                    (translate (vector 0.5 0 0))
+                    (scale (vector 1 0.1 0.1))
+                    (build-plane))))
+        
+        
+        (define (build-obj-component token)
+            (let ((obj (with-state
+                            (hint-unlit)
+                            (build-copy o))))
+                (with-primitive obj
+                    (hide 0)
+                    (when (not (zero? last-obj))
+                        (parent last-obj)))
+                (set! last-obj obj)
+                (make-component (token-char token) obj (token-gen token) 
+                    rot sc (token-id token))))
+        
+        (with-primitive o
+            (hide 1)
+            (apply-transform))   
+        
+        (foldl
+            (lambda (token ret)
+                (let ((char (token-char token)))
+                    (cond 
+                        ((char=? #\F char) 
+                            (let ((r (build-obj-component token)))
+                                (set! rot 0)
+                                (cons r ret)))
+                        ((char=? #\+ char) (set! rot (+ rot angle)) ret)
+                        ((char=? #\- char) (set! rot (- rot angle)) ret)
+                        ((char=? #\[ char)
+                                (set! parent-stack (cons last-obj parent-stack))
+                                (set! sc-stack (cons sc sc-stack))
+                                (set! sc (* sc branch-scale))
+                                (set! rot-stack (cons rot rot-stack))
+                                ret)
+                            ((char=? #\] char)
+                            (set! last-obj (car parent-stack))                        
+                            (set! parent-stack (cdr parent-stack))
+                            (set! sc (car sc-stack))                        
+                            (set! sc-stack (cdr sc-stack))
+                            (set! rot (car rot-stack))                        
+                            (set! rot-stack (cdr rot-stack))
+                            ret)
+                        (else ret))))
+            '()
+            (plant-str plant))))
+
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+(clear)
+
+(define root (build-locator))
+
+;(define p (build-plant root 30 0.96 '(("A" "[+FB][-FB]") ("B" "F[+AF]A"))))
+(define p (build-plant root 30 0.96 '(("A" "F[++A][F-A]"))))
+
+(define t 0)
+
+(define (animate)
+    (let ((t (fmod (* 1 t) 10)))
+        (plant-update p t))
+    (set! t (+ t 0.01)))
+
+(every-frame (animate))
+
+(start-framedump "gro" "jpg")

danceplant/danceplant3.scm

@@ -0,0 +1,452 @@
+;#lang scheme/base
+;(require fluxus-016/drflux)
+
+(define max-tokens 2000)
+(define additive-growth #t)
+
+(define (texpath s)
+    (string-append "/home/dave/flotsam/groworld/game-prototypes/danceplant/" s))
+
+(define-struct token (char gen age id (root #:mutable)))
+
+(define nxt-id 0)
+
+(define (token-gid) 
+    (set! nxt-id (+ nxt-id 1))
+    nxt-id)
+
+(define (reset-token-gid)
+    (set! nxt-id 0))
+
+(define (token-eq? a b)
+    (eq? (token-char a) (token-char b)))
+
+(define (token-copy a gen)
+    (make-token (token-char a) gen (token-age a) (token-gid) 0))
+
+(define (make-token-list str)
+    (map
+        (lambda (char)
+            (make-token char 0 0 0 0))
+        (string->list str)))
+
+(define (copy-token-list str gen)
+    (map 
+        (lambda (token)
+            (token-copy token gen))
+        str))
+
+(define (print-token-list tl)
+    (for-each
+        (lambda (token)
+            (printf "~a" (token-char token)))
+        tl)
+    (newline))
+
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+(define-struct ls-rule (from to))
+
+; make a rule from a char and a string
+(define (make-rule from to)
+    (when (not (char? from)) (error ""))
+    (make-ls-rule
+        (make-token from 0 0 0 0)
+        (make-token-list to)))
+
+; convert a list of strings into a list of rules
+(define (make-rule-list l)
+    (map
+        (lambda (r)
+            (make-rule (string-ref (car r) 0) (cadr r)))
+        l))
+
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+(define-struct plant ((rules #:mutable) 
+        axiom
+        angle
+        branch-scale
+        (str #:mutable) 
+        (gen #:mutable) 
+        (root #:mutable)        
+        base-root
+        (components #:mutable)
+        (anim-time #:mutable)
+        (col #:mutable)
+        (decay #:mutable)))
+
+(define (build-plant axiom angle branch-scale rules)
+    (let ((base-root (build-locator)))
+        (with-state
+            (parent base-root)
+            (make-plant (make-rule-list rules) (make-token-list axiom)
+                angle branch-scale (make-token-list axiom) 0 (build-locator) 
+                base-root '() (time) (vector 1 1 1) #f))))
+
+(define (plant-clear plant)
+    (set-plant-gen! plant 0)
+    (set-plant-str! plant (copy-token-list (plant-axiom plant) 0))
+    (set-plant-components! plant '()))
+
+(define (plant-inc-gen plant)
+    (when (not (plant-decay plant))
+        (set-plant-anim-time! plant (time))
+        (set-plant-gen! plant (+ (plant-gen plant) 1))
+        (destroy (plant-root plant))
+        (with-state
+            (parent (plant-base-root plant))
+            (set-plant-root! plant (build-locator)))
+        (reset-token-gid)
+        (plant-generate plant)        
+        ; (plant-print plant)        
+        (set-plant-components! plant (build-components plant (plant-root plant) 
+                (plant-angle plant) (plant-branch-scale plant)))))
+
+(define (plant-update plant time)            
+    (components-update plant (plant-components plant) time))
+
+(define (plant-print plant)
+    (print-token-list (plant-str plant)))
+
+(define (plant-add-to-rule plant n s)
+    
+    (cond ((plant-decay plant)
+            (component-do-decay plant (plant-components plant)))
+        (else
+            
+            (let ((c 0))
+                (set-plant-rules! plant 
+                    (map 
+                        (lambda (rule)
+                            (set! c (+ c 1))
+                            (if (eq? (- c 1) n)
+                                (make-ls-rule (ls-rule-from rule)
+                                    (append (ls-rule-to rule) 
+                                        (map
+                                            (lambda (char)
+                                                (make-token char -1 (plant-gen plant) 0 0))
+                                            (string->list s))))
+                                rule))
+                        (plant-rules plant)))))))
+
+; try all the rules on this token - returns #f if none are matched
+(define (plant-run-rules plant token gen)
+    (foldl
+        (lambda (rule str)
+            (if str ; if str is not #f
+                str ; then we have already found a rule, return it
+                (if (and (token-eq? token (ls-rule-from rule)) ; check this rule
+                        (< (length (plant-str plant)) max-tokens))
+                    (copy-token-list (ls-rule-to rule) gen) ; return the result
+                    #f))) ; no match
+        #f
+        (plant-rules plant)))
+
+; runs the lsystem rules on every token in a list, returns the new list
+(define (plant-search-replace plant pos result gen)
+    (cond 
+        ((>= pos (length (plant-str plant))) result)
+        (else
+            (let ((ret (plant-run-rules plant (list-ref (plant-str plant) pos) gen)))
+                (if (list? ret)
+                    (plant-search-replace plant (+ pos 1) (append result ret) gen)
+                    (plant-search-replace plant (+ pos 1) 
+                        (append result (list (list-ref (plant-str plant) pos))) gen))))))
+
+(define (plant-generate plant)
+    (when (< (length (plant-str plant)) max-tokens)
+        ;    (print-token-list (plant-str plant))
+        (cond (additive-growth
+                (set-plant-str! plant (plant-search-replace plant 0 
+                        '() (plant-gen plant))))
+            (else
+                ; reset the string
+                (set-plant-str! plant (copy-token-list (plant-axiom plant) 0))
+                (for ((i (in-range 0 (plant-gen plant))))
+                    (set-plant-str! plant (plant-search-replace plant 0 '() (+ i 1))))))))
+
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+(define-struct component (type root gen rot sc id (decay #:mutable) fall))
+
+(define (components-update plant components time)
+    (for-each
+        (lambda (component)
+            (cond ((component-decay component)
+                    (with-primitive (component-root component)
+                        (translate (component-fall component))))
+                (else
+                    (let ((growing (eq? (plant-gen plant) (component-gen component)))
+                            (t (- time (plant-anim-time plant))))
+                        (with-primitive (component-root component)
+                            (identity)
+                            (translate (vector 1 0 0))        
+                            
+                            (rotate (vector 0 (+ (* 0.5 (sin (+ (component-id component) 
+                                                    (* 1 time))))) 0))
+                            
+                            (if (and growing (< t 1))
+                                (rotate (vector 0 (* t (component-rot component)) 0))                        
+                                (rotate (vector 0 (component-rot component) 0)))
+                            
+                            (scale (component-sc component))
+                            (when (and growing (< t 1)) (scale (vector t 1 1))))))))
+        components))
+
+
+(define (component-do-decay plant components)
+    (for-each
+        (lambda (component)
+            (when (zero? (random 100))
+                ;(null? (with-primitive (component-root component) (get-children)))
+                (set-component-decay! component #t)
+                (with-primitive (component-root component)
+                    (detach-parent)
+                    ;                    (apply-transform)
+                    (parent (plant-root plant)))))
+        components))
+
+; builds objects from a list of tokens
+(define (build-components plant root angle branch-scale)
+    (let ((parent-stack '(root))
+            (last-obj root)
+            (rot 0)
+            (sc 1)
+            (sc-stack '(1))
+            (rot-stack '(0))
+            (bo (with-state                    
+                    (rotate (vector 90 0 0))
+                    (translate (vector 0.5 0 0))
+                    (scale (vector 1.1 0.5 0.5))
+                    (build-plane)))
+            (lo (with-state                    
+                    (rotate (vector 90 0 0))
+                    (translate (vector 0.5 0 0))
+                    (build-plane))))
+        
+        
+        (define (build-obj-component token)
+            (let ((obj (with-state
+                            (colour (plant-col plant))
+                            (hint-ignore-depth)
+                            (cond 
+                                ((char=? #\F (token-char token))
+                                    (texture (load-texture (texpath "textures/branch-a.png"))))
+                                ((char=? #\G (token-char token))
+                                    (texture (load-texture (texpath "textures/branch-b.png"))))
+                                ((char=? #\L (token-char token))
+                                    (texture (load-texture (texpath "textures/leaf-a.png"))))
+                                ((char=? #\M (token-char token))
+                                    (texture (load-texture (texpath "textures/leaf-b.png")))))
+                            (hint-unlit)
+                            (cond ((or (char=? #\F (token-char token))
+                                        (char=? #\G (token-char token)))
+                                    (build-copy bo))
+                                ((or (char=? #\L (token-char token))
+                                        (char=? #\M (token-char token)))
+                                    (build-copy lo))))))
+                (with-primitive obj
+                    (hide 0)
+                    (when (not (zero? last-obj))
+                        (parent last-obj)))
+                (set! last-obj obj)
+                (make-component (token-char token) obj
+                    ;                    (if (> (token-age token) (token-gen token))
+                        ;                        (+ (token-age token) 1)
+                        (token-gen token);)
+                    rot sc (token-id token) #f (srndvec))))
+        
+        (with-primitive bo
+            (hide 1)
+            (pdata-set! "t" 0 (vector 0 0 0))
+            (pdata-set! "t" 1 (vector 0 1 0))
+            (pdata-set! "t" 2 (vector 1 1 0))
+            (pdata-set! "t" 3 (vector 1 0 0))
+            (apply-transform))
+        
+        (with-primitive lo
+            (hide 1)
+            (pdata-set! "t" 0 (vector 1 1 0))
+            (pdata-set! "t" 1 (vector 1 0 0))
+            (pdata-set! "t" 2 (vector 0 0 0))
+            (pdata-set! "t" 3 (vector 0 1 0))
+            (apply-transform))
+        
+        (foldl
+            (lambda (token ret)
+                (let ((char (token-char token)))
+                    (cond 
+                        ((or (char=? #\F char) (char=? #\G char) (char=? #\L char) (char=? #\M char))
+                            (let ((r (build-obj-component token)))
+                                (set! rot 0)
+                                (cons r ret)))
+                        ((char=? #\+ char) (set! rot (+ rot angle)) ret)
+                        ((char=? #\- char) (set! rot (- rot angle)) ret)
+                        ((char=? #\[ char)
+                                (set! parent-stack (cons last-obj parent-stack))
+                                (set! sc-stack (cons sc sc-stack))
+                                (set! sc (* sc branch-scale))
+                                (set! rot-stack (cons rot rot-stack))
+                                ret)
+                            ((char=? #\] char)
+                            (set! last-obj (car parent-stack))                        
+                            (set! parent-stack (cdr parent-stack))
+                            (set! sc (car sc-stack))                        
+                            (set! sc-stack (cdr sc-stack))
+                            (set! rot (car rot-stack))                        
+                            (set! rot-stack (cdr rot-stack))
+                            ret)
+                        (else ret))))
+            '()
+            (plant-str plant))))
+
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+(define (choose l)
+    (list-ref l (random (length l))))
+
+(define (build-foliage count rules)
+    (build-list count 
+        (lambda (_) 
+            (with-state
+                (translate (vector 0 (+ 0 (* (rndf) 10)) (* 15 (crndf))))
+                (build-plant "FA" (* 40 (crndf)) 0.96 (choose rules))))))
+
+
+(define (foliage-grow foliage)
+    (for-each
+        (lambda (plant)
+            (for ((i (in-range 4 (random 10))))
+                (set-plant-col! plant (vmul (vector 0 0.6 0.6) (rndf)))
+                (plant-inc-gen plant)))
+        foliage))
+
+(define (foliage-update foliage time)
+    (for-each
+        (lambda (plant)
+            (plant-update plant time))
+        foliage))
+
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+(define debounce-vec (build-vector 10 (lambda (_) #f)))
+
+(define (debounce n)
+    (vector-ref debounce-vec n))
+
+(define (debounce! n s)
+    (vector-set! debounce-vec n s))
+
+(define (on-key p n proc)
+    (if p
+        (when (debounce n)
+            (proc)
+            (debounce! n #f))
+        (debounce! n #t)))
+
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+(clear)
+(clear-colour (vector 0 0.5 0.4))
+(set-camera-transform (mmul (mtranslate (vector 0 -5 -10))
+        (mrotate (vector 90 90 180))))
+
+(with-state
+    (hint-unlit)
+    (colour (vector 0 0.4 0.3))
+    (scale 100)
+    (rotate (vector 0 90 0))
+    (build-plane))
+
+(define foliage (build-foliage 30
+        '((("A" "F[-[+++FM]G[-FL]+A]"))
+            (("A" "F-F[++AL]G-A"))
+            (("A" "F++[+A+FFL]")))))
+
+(foliage-grow foliage)
+
+(define rules '(("a" "F") ("b" "F") ("A" "[a][b]")))
+(define p (build-plant "FA" 40 0.96 rules))
+(set-plant-col! p (vector 0.5 1 0.5))
+(define decay-count 0)
+
+(define (animate)
+    
+    (when (and (zero? decay-count)
+            (or (> (length (plant-str p)) max-tokens) (> (plant-gen p) 20)))
+        (set! decay-count 1)
+        (set-plant-decay! p #t))
+    
+    (when (> decay-count 0)
+        (set! decay-count (+ decay-count 1))
+        ;        (display decay-count)(newline)
+        )
+    
+    (when (> decay-count 100)
+        (set! decay-count 0) 
+        (set-plant-decay! p #f)
+        (plant-clear p)
+        (set-plant-rules! p (make-rule-list rules))
+        (plant-inc-gen p))
+    
+    (on-key (key-special-pressed 101) 0 ; up
+        (lambda ()
+            (plant-add-to-rule p 0 "G+a")
+            (plant-add-to-rule p 1 "G-b")
+            (plant-inc-gen p)))
+    
+    (on-key (key-special-pressed 100) 1 ; left
+        (lambda ()
+            (plant-add-to-rule p 0 "+F+b")
+            (plant-add-to-rule p 1 "+F+a")
+            (plant-inc-gen p)))
+    
+    (on-key (key-special-pressed 102) 2 ; right
+        (lambda ()
+            (plant-add-to-rule p 0 "-F-a")
+            (plant-add-to-rule p 1 "-F-b")
+            (plant-inc-gen p)))
+    
+    (on-key (key-special-pressed 103) 3 ; down
+        (lambda ()
+            (plant-add-to-rule p 0 "[F++b-FL]")
+            (plant-add-to-rule p 1 "[F--a+FL]")
+            (plant-inc-gen p)))
+    
+    (on-key (key-pressed "q") 4
+        (lambda ()
+            (plant-inc-gen p)
+            (plant-add-to-rule p 0 "b-a")))
+    
+    (on-key (key-pressed "e") 4
+        (lambda ()
+            (plant-inc-gen p)
+            (plant-add-to-rule p 1 "a-b")))
+    
+    (on-key (key-pressed "z") 5
+        (lambda ()
+            (plant-inc-gen p)
+            (plant-add-to-rule p 1 "b[+M]")))
+    
+    (on-key (key-pressed "c") 6
+        (lambda ()
+            (plant-add-to-rule p 0 "a+[--M]")
+            (plant-inc-gen p)))
+    
+    (on-key (key-pressed "s") 7
+        (lambda ()
+            (plant-add-to-rule p 0 "A")
+            (plant-add-to-rule p 1 "A")
+            (plant-inc-gen p)))           
+    
+    (on-key (key-pressed (string #\newline)) 8
+        (lambda ()
+            (plant-clear p)
+            (set-plant-rules! p (make-rule-list rules))))
+    
+    
+    (plant-update p (time))
+    (foliage-update foliage (time)))
+
+(every-frame (animate))

danceplant/gro.scm

@@ -0,0 +1,333 @@
+(define max-tokens 1000)
+(define additive-growth #t)
+
+(define-struct token (char gen age id (root #:mutable)))
+
+(define nxt-id 0)
+
+(define (token-gid) 
+    (set! nxt-id (+ nxt-id 1))
+    nxt-id)
+
+(define (reset-token-gid)
+    (set! nxt-id 0))
+
+(define (token-eq? a b)
+    (eq? (token-char a) (token-char b)))
+
+(define (token-copy a gen)
+    (make-token (token-char a) gen (token-age a) (token-gid) 0))
+
+(define (make-token-list str)
+    (map
+        (lambda (char)
+            (make-token char 0 0 0 0))
+        (string->list str)))
+
+(define (copy-token-list str gen)
+    (map 
+        (lambda (token)
+            (token-copy token gen))
+        str))
+
+(define (print-token-list tl)
+    (for-each
+        (lambda (token)
+            (printf "~a" (token-char token)))
+        tl)
+    (newline))
+
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+(define-struct ls-rule (from to))
+
+; make a rule from a char and a string
+(define (make-rule from to)
+    (when (not (char? from)) (error ""))
+    (make-ls-rule
+        (make-token from 0 0 0 0)
+        (make-token-list to)))
+
+; convert a list of strings into a list of rules
+(define (make-rule-list l)
+    (map
+        (lambda (r)
+            (make-rule (string-ref (car r) 0) (cadr r)))
+        l))
+
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+(define-struct plant ((rules #:mutable) 
+        axiom
+        angle
+        branch-scale
+        (str #:mutable) 
+        (gen #:mutable) 
+        (root #:mutable)        
+        base-root
+        (components #:mutable)
+        (anim-time #:mutable)
+        (col #:mutable)))
+
+(define (build-plant axiom angle branch-scale rules)
+    (let ((base-root (build-locator)))
+        (with-state
+            (parent base-root)
+            (make-plant (make-rule-list rules) (make-token-list axiom)
+                angle branch-scale (make-token-list axiom) 0 (build-locator) 
+                    base-root '() (time) (vector 1 1 1)))))
+
+(define (plant-clear plant)
+    (set-plant-gen! plant 0)
+    (set-plant-str! plant (copy-token-list (plant-axiom plant) 0))
+    (set-plant-components! plant '()))
+
+(define (plant-inc-gen plant)
+    (set-plant-anim-time! plant (time))
+    (set-plant-gen! plant (+ (plant-gen plant) 1))
+    (destroy (plant-root plant))
+    (with-state
+        (parent (plant-base-root plant))
+        (set-plant-root! plant (build-locator)))
+    (reset-token-gid)
+    (plant-generate plant)        
+    ; (plant-print plant)        
+    (set-plant-components! plant (build-components plant (plant-root plant) 
+            (plant-angle plant) (plant-branch-scale plant))))
+
+(define (plant-update plant time)            
+    (components-update plant (plant-components plant) time))
+
+(define (plant-print plant)
+    (print-token-list (plant-str plant)))
+
+(define (plant-add-to-rule plant n s)
+    (let ((c 0))
+        (set-plant-rules! plant 
+            (map 
+                (lambda (rule)
+                    (set! c (+ c 1))
+                    (if (eq? (- c 1) n)
+                        (make-ls-rule (ls-rule-from rule)
+                            (append (ls-rule-to rule) 
+                                (map
+                                    (lambda (char)
+                                        (make-token char -1 (plant-gen plant) 0 0))
+                                    (string->list s))))
+                        rule))
+                (plant-rules plant)))))
+
+; try all the rules on this token - returns #f if none are matched
+(define (plant-run-rules plant token gen)
+    (foldl
+        (lambda (rule str)
+            (if str ; if str is not #f
+                str ; then we have already found a rule, return it
+                (if (and (token-eq? token (ls-rule-from rule)) ; check this rule
+                        (< (length (plant-str plant)) max-tokens))
+                    (copy-token-list (ls-rule-to rule) gen) ; return the result
+                    #f))) ; no match
+        #f
+        (plant-rules plant)))
+
+; runs the lsystem rules on every token in a list, returns the new list
+(define (plant-search-replace plant pos result gen)
+    (cond 
+        ((>= pos (length (plant-str plant))) result)
+        (else
+            (let ((ret (plant-run-rules plant (list-ref (plant-str plant) pos) gen)))
+                (if (list? ret)
+                    (plant-search-replace plant (+ pos 1) (append result ret) gen)
+                    (plant-search-replace plant (+ pos 1) 
+                        (append result (list (list-ref (plant-str plant) pos))) gen))))))
+
+(define (plant-generate plant)
+    (when (< (length (plant-str plant)) max-tokens)
+        ;    (print-token-list (plant-str plant))
+        (cond (additive-growth
+                (set-plant-str! plant (plant-search-replace plant 0 
+                        '() (plant-gen plant))))
+            (else
+                ; reset the string
+                (set-plant-str! plant (copy-token-list (plant-axiom plant) 0))
+                (for ((i (in-range 0 (plant-gen plant))))
+                    (set-plant-str! plant (plant-search-replace plant 0 '() (+ i 1))))))))
+
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+(define-struct component (type root gen rot sc id))
+
+(define (components-update plant components time)
+    (for-each
+        (lambda (component)
+            (let ((growing (eq? (plant-gen plant) (component-gen component)))
+                    (t (- time (plant-anim-time plant))))
+                (with-primitive (component-root component)
+                    (identity)
+                    (translate (vector 1 0 0))        
+                    
+                    (rotate (vector 0 (+ (* 0.5 (sin (+ (component-id component) 
+                                            (* 3 time))))) 0))
+                    
+                    (if (and growing (< t 1))
+                        (rotate (vector 0 (* t (component-rot component)) 0))                        
+                        (rotate (vector 0 (component-rot component) 0)))
+                    
+                    (scale (component-sc component))
+                    (when (and growing (< t 1)) (scale (vector t 1 1))))))
+        components))
+
+; builds objects from a list of tokens
+(define (build-components plant root angle branch-scale)
+    (let ((parent-stack '(root))
+            (last-obj root)
+            (rot 0)
+            (sc 1)
+            (sc-stack '(1))
+            (rot-stack '(0))
+            (bo (with-state                    
+                    (rotate (vector 90 0 0))
+                    (translate (vector 0.5 0 0))
+                    (scale (vector 1.1 0.1 0.1))
+                    (build-plane)))
+            (lo (with-state                    
+                    (rotate (vector 90 0 0))
+                    (translate (vector 0.5 0 0))
+                    (build-plane))))
+        
+        
+        (define (build-obj-component token)
+            (let ((obj (with-state
+                            (colour (plant-col plant))
+                            (hint-ignore-depth)
+                            #;(cond 
+                                ((char=? #\F (token-char token))
+                                    (texture (load-texture "textures/branch-a.png")))
+                                ((char=? #\G (token-char token))
+                                    (texture (load-texture "textures/branch-b.png")))
+                                ((char=? #\L (token-char token))
+                                    (texture (load-texture "textures/leaf-a.png")))
+                                ((char=? #\M (token-char token))
+                                    (texture (load-texture "textures/leaf-b.png"))))
+                            (hint-unlit)
+                            (cond ((or (char=? #\F (token-char token))
+                                       (char=? #\G (token-char token)))
+                                    (build-copy bo))
+                                  ((or (char=? #\L (token-char token))
+                                       (char=? #\M (token-char token)))
+                                    (build-copy lo))))))
+                (with-primitive obj
+                    (hide 0)
+                    (when (not (zero? last-obj))
+                        (parent last-obj)))
+                (set! last-obj obj)
+                (make-component (token-char token) obj
+                    ;                    (if (> (token-age token) (token-gen token))
+                        ;                        (+ (token-age token) 1)
+                        (token-gen token);)
+                    rot sc (token-id token))))
+        
+        (with-primitive bo
+            (hide 1)
+            (pdata-set! "t" 0 (vector 0 0 0))
+            (pdata-set! "t" 1 (vector 0 1 0))
+            (pdata-set! "t" 2 (vector 1 1 0))
+            (pdata-set! "t" 3 (vector 1 0 0))
+            (apply-transform))
+
+        (with-primitive lo
+            (hide 1)
+            (pdata-set! "t" 0 (vector 1 1 0))
+            (pdata-set! "t" 1 (vector 1 0 0))
+            (pdata-set! "t" 2 (vector 0 0 0))
+            (pdata-set! "t" 3 (vector 0 1 0))
+            (apply-transform))
+        
+        (foldl
+            (lambda (token ret)
+                (let ((char (token-char token)))
+                    (cond 
+                        ((or (char=? #\F char) (char=? #\G char) (char=? #\L char) (char=? #\M char))
+                            (let ((r (build-obj-component token)))
+                                (set! rot 0)
+                                (cons r ret)))
+                        ((char=? #\+ char) (set! rot (+ rot angle)) ret)
+                        ((char=? #\- char) (set! rot (- rot angle)) ret)
+                        ((char=? #\[ char)
+                                (set! parent-stack (cons last-obj parent-stack))
+                                (set! sc-stack (cons sc sc-stack))
+                                (set! sc (* sc branch-scale))
+                                (set! rot-stack (cons rot rot-stack))
+                                ret)
+                            ((char=? #\] char)
+                            (set! last-obj (car parent-stack))                        
+                            (set! parent-stack (cdr parent-stack))
+                            (set! sc (car sc-stack))                        
+                            (set! sc-stack (cdr sc-stack))
+                            (set! rot (car rot-stack))                        
+                            (set! rot-stack (cdr rot-stack))
+                            ret)
+                        (else ret))))
+            '()
+            (plant-str plant))))
+
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+(define (choose l)
+    (list-ref l (random (length l))))
+
+(define (build-foliage count rules)
+    (build-list count 
+        (lambda (_) 
+            (with-state
+                (translate (vector 0 (+ 0 (* (rndf) 10)) (* 15 (crndf))))
+                (build-plant "FA" (* 40 (crndf)) 0.96 (choose rules))))))
+
+
+(define (foliage-grow foliage)
+    (for-each
+        (lambda (plant)
+            (for ((i (in-range 2 (random 10))))
+                (set-plant-col! plant (vmul (vector 0 0.6 0.6) (rndf)))
+                (plant-inc-gen plant)))
+        foliage))
+
+(define (foliage-update foliage time)
+    (for-each
+        (lambda (plant)
+            (plant-update plant time))
+        foliage))
+
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+(clear)
+(clear-colour (vector 0 0.3 0.2))
+(set-camera-transform (mmul (mtranslate (vector 0 -5 -10))
+        (mrotate (vector 90 90 180))))
+
+(with-state
+    (hint-unlit)
+    (colour (vector 0 0.2 0.1))
+    (scale 100)
+    (rotate (vector 0 90 0))
+    (build-plane))
+
+(define rules '(("A" "F-[+F+F+FA]+F[+F-F-FA]-F[-F-FA]")))
+(define p (build-plant "A" 34 0.96 rules))
+(set-plant-col! p (vector 0.5 1 0.5))
+
+(define t (time))
+
+(define (animate)
+
+    (when (> (time) t)
+        (set! t (+ t 1))
+        (plant-inc-gen p))
+
+    (when (> (plant-gen p) 10)
+        (plant-clear p)
+        (set-plant-rules! p (make-rule-list rules)))
+    
+    (plant-update p (time)))
+
+(every-frame (animate))

danceplant/gro2.scm

@@ -0,0 +1,335 @@
+(define max-tokens 1000)
+(define additive-growth #t)
+
+(define-struct token (char gen age id (root #:mutable)))
+
+(define nxt-id 0)
+
+(define (token-gid) 
+    (set! nxt-id (+ nxt-id 1))
+    nxt-id)
+
+(define (reset-token-gid)
+    (set! nxt-id 0))
+
+(define (token-eq? a b)
+    (eq? (token-char a) (token-char b)))
+
+(define (token-copy a gen)
+    (make-token (token-char a) gen (token-age a) (token-gid) 0))
+
+(define (make-token-list str)
+    (map
+        (lambda (char)
+            (make-token char 0 0 0 0))
+        (string->list str)))
+
+(define (copy-token-list str gen)
+    (map 
+        (lambda (token)
+            (token-copy token gen))
+        str))
+
+(define (print-token-list tl)
+    (for-each
+        (lambda (token)
+            (printf "~a" (token-char token)))
+        tl)
+    (newline))
+
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+(define-struct ls-rule (from to))
+
+; make a rule from a char and a string
+(define (make-rule from to)
+    (when (not (char? from)) (error ""))
+    (make-ls-rule
+        (make-token from 0 0 0 0)
+        (make-token-list to)))
+
+; convert a list of strings into a list of rules
+(define (make-rule-list l)
+    (map
+        (lambda (r)
+            (make-rule (string-ref (car r) 0) (cadr r)))
+        l))
+
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+(define-struct plant ((rules #:mutable) 
+        axiom
+        angle
+        branch-scale
+        (str #:mutable) 
+        (gen #:mutable) 
+        (root #:mutable)        
+        base-root
+        (components #:mutable)
+        (anim-time #:mutable)
+        (col #:mutable)))
+
+(define (build-plant axiom angle branch-scale rules)
+    (let ((base-root (build-locator)))
+        (with-state
+            (parent base-root)
+            (make-plant (make-rule-list rules) (make-token-list axiom)
+                angle branch-scale (make-token-list axiom) 0 (build-locator) 
+                    base-root '() (time) (vector 1 1 1)))))
+
+(define (plant-clear plant)
+    (set-plant-gen! plant 0)
+    (set-plant-str! plant (copy-token-list (plant-axiom plant) 0))
+    (set-plant-components! plant '()))
+
+(define (plant-inc-gen plant)
+    (set-plant-anim-time! plant (time))
+    (set-plant-gen! plant (+ (plant-gen plant) 1))
+    (destroy (plant-root plant))
+    (with-state
+        (parent (plant-base-root plant))
+        (set-plant-root! plant (build-locator)))
+    (reset-token-gid)
+    (plant-generate plant)        
+    ; (plant-print plant)        
+    (set-plant-components! plant (build-components plant (plant-root plant) 
+            (plant-angle plant) (plant-branch-scale plant))))
+
+(define (plant-update plant time)            
+    (components-update plant (plant-components plant) time))
+
+(define (plant-print plant)
+    (print-token-list (plant-str plant)))
+
+(define (plant-add-to-rule plant n s)
+    (let ((c 0))
+        (set-plant-rules! plant 
+            (map 
+                (lambda (rule)
+                    (set! c (+ c 1))
+                    (if (eq? (- c 1) n)
+                        (make-ls-rule (ls-rule-from rule)
+                            (append (ls-rule-to rule) 
+                                (map
+                                    (lambda (char)
+                                        (make-token char -1 (plant-gen plant) 0 0))
+                                    (string->list s))))
+                        rule))
+                (plant-rules plant)))))
+
+; try all the rules on this token - returns #f if none are matched
+(define (plant-run-rules plant token gen)
+    (foldl
+        (lambda (rule str)
+            (if str ; if str is not #f
+                str ; then we have already found a rule, return it
+                (if (and (token-eq? token (ls-rule-from rule)) ; check this rule
+                        (< (length (plant-str plant)) max-tokens))
+                    (copy-token-list (ls-rule-to rule) gen) ; return the result
+                    #f))) ; no match
+        #f
+        (plant-rules plant)))
+
+; runs the lsystem rules on every token in a list, returns the new list
+(define (plant-search-replace plant pos result gen)
+    (cond 
+        ((>= pos (length (plant-str plant))) result)
+        (else
+            (let ((ret (plant-run-rules plant (list-ref (plant-str plant) pos) gen)))
+                (if (list? ret)
+                    (plant-search-replace plant (+ pos 1) (append result ret) gen)
+                    (plant-search-replace plant (+ pos 1) 
+                        (append result (list (list-ref (plant-str plant) pos))) gen))))))
+
+(define (plant-generate plant)
+    (when (< (length (plant-str plant)) max-tokens)
+        ;    (print-token-list (plant-str plant))
+        (cond (additive-growth
+                (set-plant-str! plant (plant-search-replace plant 0 
+                        '() (plant-gen plant))))
+            (else
+                ; reset the string
+                (set-plant-str! plant (copy-token-list (plant-axiom plant) 0))
+                (for ((i (in-range 0 (plant-gen plant))))
+                    (set-plant-str! plant (plant-search-replace plant 0 '() (+ i 1))))))))
+
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+(define-struct component (type root gen rot sc id))
+
+(define (components-update plant components time)
+
+    (for-each
+        (lambda (component)
+            (let ((growing (eq? (plant-gen plant) (component-gen component)))
+                    (t (- time (plant-anim-time plant))))
+                (with-primitive (component-root component)
+                    (identity)
+                    (translate (vector 1 0 0))        
+                    
+                    (rotate (vector 0 (+ (gh (component-id component))
+                            (* 0.5 (sin (+ (component-id component) 
+                                            (* 3 time))))) 0))
+                    
+                    (if (and growing (< t 1))
+                        (rotate (vector 0 (* t (component-rot component)) 0))                        
+                        (rotate (vector 0 (component-rot component) 0)))
+                    
+                    (scale (component-sc component))
+                    (when (and growing (< t 1)) (scale (vector t 1 1))))))
+        components))
+
+; builds objects from a list of tokens
+(define (build-components plant root angle branch-scale)
+    (let ((parent-stack '(root))
+            (last-obj root)
+            (rot 0)
+            (sc 1)
+            (sc-stack '(1))
+            (rot-stack '(0))
+            (bo (with-state                    
+                    (rotate (vector 90 0 0))
+                    (translate (vector 0.5 0 0))
+                    (scale (vector 1.1 0.1 0.1))
+                    (build-plane)))
+            (lo (with-state                    
+                    (rotate (vector 90 0 0))
+                    (translate (vector 0.5 0 0))
+                    (build-plane))))
+        
+        
+        (define (build-obj-component token)
+            (let ((obj (with-state
+                            (colour (plant-col plant))
+                            (hint-ignore-depth)
+                            #;(cond 
+                                ((char=? #\F (token-char token))
+                                    (texture (load-texture "textures/branch-a.png")))
+                                ((char=? #\G (token-char token))
+                                    (texture (load-texture "textures/branch-b.png")))
+                                ((char=? #\L (token-char token))
+                                    (texture (load-texture "textures/leaf-a.png")))
+                                ((char=? #\M (token-char token))
+                                    (texture (load-texture "textures/leaf-b.png"))))
+                            (hint-unlit)
+                            (cond ((or (char=? #\F (token-char token))
+                                       (char=? #\G (token-char token)))
+                                    (build-copy bo))
+                                  ((or (char=? #\L (token-char token))
+                                       (char=? #\M (token-char token)))
+                                    (build-copy lo))))))
+                (with-primitive obj
+                    (hide 0)
+                    (when (not (zero? last-obj))
+                        (parent last-obj)))
+                (set! last-obj obj)
+                (make-component (token-char token) obj
+                    ;                    (if (> (token-age token) (token-gen token))
+                        ;                        (+ (token-age token) 1)
+                        (token-gen token);)
+                    rot sc (token-id token))))
+        
+        (with-primitive bo
+            (hide 1)
+            (pdata-set! "t" 0 (vector 0 0 0))
+            (pdata-set! "t" 1 (vector 0 1 0))
+            (pdata-set! "t" 2 (vector 1 1 0))
+            (pdata-set! "t" 3 (vector 1 0 0))
+            (apply-transform))
+
+        (with-primitive lo
+            (hide 1)
+            (pdata-set! "t" 0 (vector 1 1 0))
+            (pdata-set! "t" 1 (vector 1 0 0))
+            (pdata-set! "t" 2 (vector 0 0 0))
+            (pdata-set! "t" 3 (vector 0 1 0))
+            (apply-transform))
+        
+        (foldl
+            (lambda (token ret)
+                (let ((char (token-char token)))
+                    (cond 
+                        ((or (char=? #\F char) (char=? #\G char) (char=? #\L char) (char=? #\M char))
+                            (let ((r (build-obj-component token)))
+                                (set! rot 0)
+                                (cons r ret)))
+                        ((char=? #\+ char) (set! rot (+ rot angle)) ret)
+                        ((char=? #\- char) (set! rot (- rot angle)) ret)
+                        ((char=? #\[ char)
+                                (set! parent-stack (cons last-obj parent-stack))
+                                (set! sc-stack (cons sc sc-stack))
+                                (set! sc (* sc branch-scale))
+                                (set! rot-stack (cons rot rot-stack))
+                                ret)
+                            ((char=? #\] char)
+                            (set! last-obj (car parent-stack))                        
+                            (set! parent-stack (cdr parent-stack))
+                            (set! sc (car sc-stack))                        
+                            (set! sc-stack (cdr sc-stack))
+                            (set! rot (car rot-stack))                        
+                            (set! rot-stack (cdr rot-stack))
+                            ret)
+                        (else ret))))
+            '()
+            (plant-str plant))))
+
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+(define (choose l)
+    (list-ref l (random (length l))))
+
+(define (build-foliage count rules)
+    (build-list count 
+        (lambda (_) 
+            (with-state
+                (translate (vector 0 (+ 0 (* (rndf) 10)) (* 15 (crndf))))
+                (build-plant "FA" (* 40 (crndf)) 0.96 (choose rules))))))
+
+
+(define (foliage-grow foliage)
+    (for-each
+        (lambda (plant)
+            (for ((i (in-range 2 (random 10))))
+                (set-plant-col! plant (vmul (vector 0 0.6 0.6) (rndf)))
+                (plant-inc-gen plant)))
+        foliage))
+
+(define (foliage-update foliage time)
+    (for-each
+        (lambda (plant)
+            (plant-update plant time))
+        foliage))
+
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+(clear)
+;(clear-colour (vector 0 0.5 0.4))
+(set-camera-transform (mmul (mtranslate (vector 0 -5 -10))
+        (mrotate (vector 90 90 180))))
+
+#;(with-state
+    (hint-unlit)
+    (colour (vector 0 0.4 0.3))
+    (scale 100)
+    (rotate (vector 0 90 0))
+    (build-plane))
+
+(define rules '(("A" "--[+FFFFA]+[++FA]++[-FFA]")))
+(define p (build-plant "FA" 30 0.96 rules))
+(set-plant-col! p (vector 0.5 1 0.5))
+
+(define t (time))
+
+(define (animate)
+
+    (when (> (time) t)
+        (set! t (+ t 1))
+        (plant-inc-gen p))
+
+    (when (> (plant-gen p) 10)
+        (plant-clear p)
+        (set-plant-rules! p (make-rule-list rules)))
+    
+    (plant-update p (time)))
+
+(every-frame (animate))

flatgarden/flatgarden-mulberry.scm

@@ -0,0 +1,161 @@
+(clear)
+
+(define current-time 0)
+(define fps 25)
+(define (time-update) (set! current-time (+ current-time (/ 1 fps))))
+(define (delta) (/ 1 fps))
+(define (time) current-time)
+
+; try all the rules on this character - 
+; returns #f if none are matched
+(define (lsys-run-rules char rules)
+    (foldl
+        (lambda (rule str)
+            (if str ; if str is not #f
+                str ; then we have already found a rule, return it
+                (if (char=? char (string-ref (car rule) 0)) ; check this rule
+                    (cadr rule) ; return the string
+                    #f))) ; no match
+        #f
+        rules))
+
+; runs the lsystem rules on every character in a string, 
+; returns the new string
+(define (lsys-search-replace str rules pos result)
+    (cond 
+        ((>= pos (string-length str)) result)
+        (else
+            (let ((ret (lsys-run-rules (string-ref str pos) rules)))
+                (if (string? ret)
+                    (lsys-search-replace str rules (+ pos 1) 
+                        (string-append result ret))
+                    (lsys-search-replace str rules (+ pos 1) 
+                        (string-append result (string (string-ref str pos)))))))))
+
+; runs the search-replace multiple (n) times on a string
+(define (ls-generate n str rules)
+    (cond 
+        ((zero? n) str)
+        (else
+            (ls-generate (- n 1) 
+                (lsys-search-replace str rules 0 "") rules))))
+
+; todo: get rid of all these
+
+(define branch-obj (with-state
+        (translate (vector 0.5 0 0))
+        (scale (vector 1 0.25 0.25))
+        (rotate (vector 0 0 90))
+        (build-plane)))
+
+(with-primitive branch-obj
+    (hide 1)
+    (apply-transform))
+
+(define leaf-obj (with-state
+        (translate (vector 1.9 0 0))
+        (scale (vector 4 2 2))
+        (rotate (vector 0 0 90))
+        (build-plane)))
+
+(with-primitive leaf-obj
+    (hide 1)
+    (apply-transform))
+
+(define berry-obj (with-state
+        (translate (vector 1.0 0 0))
+        (scale (vector 2 1 1))
+        (rotate (vector 0 0 90))
+        (build-plane)))
+
+(with-primitive berry-obj
+    (hide 1)
+    (apply-transform))
+
+
+; builds objects from a string
+(define (ls-build root string angle branch-scale)
+    (let ((parent-stack '(root))
+            (last-obj root)
+            (obj-list '())
+            (rot 0))
+        
+        (define (make-component src-obj tex)
+            (let ((obj (with-state
+                            (hint-unlit)
+                            (texture (load-texture tex))
+                            (translate (vector 1 0.01 0))
+                            (rotate (vector 0 0 rot))      
+                            (set! rot 0)
+                            (build-copy src-obj))))
+                (with-primitive obj
+                    (hide 0)
+                    ;(apply-transform)
+                    (when (not (zero? last-obj))
+                        (parent last-obj)))
+                (set! last-obj obj)
+                (set! obj-list (cons obj obj-list))))
+        
+        
+        (hint-ignore-depth)
+        (for-each 
+            (lambda (char)
+                (cond 
+                    ((char=? #\F char) (make-component branch-obj "textures/mulberry-branch.png"))                
+                    ((char=? #\G char) (make-component branch-obj "textures/mulberry-branch.png"))                
+                    ((char=? #\L char) (make-component leaf-obj "textures/mulberry-leaf.png"))                   
+                    ((char=? #\B char) (make-component berry-obj "textures/mulberry-berry.png"))                   
+                    ((char=? #\+ char)
+                        (set! rot (+ rot angle)))
+                    ((char=? #\- char)
+                        (set! rot (- rot angle)))
+                    ((char=? #\[ char)
+                            (push)
+                            (set! parent-stack (cons last-obj parent-stack))
+                            (scale (vector branch-scale branch-scale branch-scale))
+                            )
+                        ((char=? #\] char)
+                        (pop)
+                        (set! last-obj (car parent-stack))
+                        (set! parent-stack (cdr parent-stack)))))
+            (string->list string))
+    obj-list))
+
+(define (animate obj-list)
+    (time-update)
+    (let ((c 0))
+    (for-each 
+        (lambda (objs)
+            (for-each 
+                (lambda (obj)
+                    (with-primitive obj
+                        (rotate (vmul (vector 0 0 (* 1 (sin (+ c (time))))) (delta))))
+                    (set! c (+ c 20)))
+                objs))
+        obj-list)))
+
+
+(persp)
+(hint-depth-sort)
+(clear-colour (vector 0.1 0.2 0.2))
+(set-camera-transform (mmul 
+    (mrotate (vector 0 0 90))
+    (mtranslate (vector -17 0 -20))))
+(set-ortho-zoom -20)
+(clear-texture-cache)
+
+(define trees '())
+
+(colour 1)
+(fog (vector 0.1 0.2 0.2) 0.02 1 10)
+(for ((i (in-range 0 20)))
+    (let ((t2 (with-state
+                    (translate (vector 0 (* 20 (crndf)) (- 10 (* 50 (rndf)))))
+                    (build-locator))))
+ ;       (set! trees (cons (ls-build t2 (ls-generate 3 "F" '(("F" "G-[-F+G+FB]+F[+F-G-FL]-F"))) 
+        (set! trees (cons (ls-build t2 (ls-generate 3 "F" 
+            '(("F" "F[--FL]+F[++FB]-F[--FB]"))) 
+            (+ 5 (random 50)) 0.95) trees))))
+
+
+(every-frame (animate trees))

flatgarden/flatgarden.scm

@@ -0,0 +1,143 @@
+(clear)
+
+(define texture-loc "/home/dave/flotsam/groworld/game-prototypes/flatgarden/textures/")
+
+; try all the rules on this character - 
+; returns #f if none are matched
+(define (lsys-run-rules char rules)
+    (foldl
+        (lambda (rule str)
+            (if str ; if str is not #f
+                str ; then we have already found a rule, return it
+                (if (char=? char (string-ref (car rule) 0)) ; check this rule
+                    (cadr rule) ; return the string
+                    #f))) ; no match
+        #f
+        rules))
+
+; runs the lsystem rules on every character in a string, 
+; returns the new string
+(define (lsys-search-replace str rules pos result)
+    (cond 
+        ((>= pos (string-length str)) result)
+        (else
+            (let ((ret (lsys-run-rules (string-ref str pos) rules)))
+                (if (string? ret)
+                    (lsys-search-replace str rules (+ pos 1) 
+                        (string-append result ret))
+                    (lsys-search-replace str rules (+ pos 1) 
+                        (string-append result (string (string-ref str pos)))))))))
+
+; runs the search-replace multiple (n) times on a string
+(define (ls-generate n str rules)
+    (cond 
+        ((zero? n) str)
+        (else
+            (ls-generate (- n 1) 
+                (lsys-search-replace str rules 0 "") rules))))
+
+; todo: get rid of all these
+
+(define branch-obj (with-state
+        (translate (vector 0.5 0 0))
+        (scale (vector 1 0.5 0.5))
+        (rotate (vector 0 0 90))
+        (build-plane)))
+
+(with-primitive branch-obj
+    (hide 1)
+    (apply-transform))
+
+(define leaf-obj (with-state
+        (translate (vector 0.5 0 0))
+        ;    (scale (vector 1 0.5 0.5))
+        (rotate (vector 0 0 -90))
+        (build-plane)))
+
+(with-primitive leaf-obj
+    (hide 1)
+    (apply-transform))
+
+
+; builds objects from a string
+(define (ls-build root string angle branch-scale)
+    (let ((parent-stack '(root))
+            (last-obj root)
+            (obj-list '())
+            (rot 0))
+        
+        (define (make-component src-obj tex)
+            (let ((obj (with-state
+                            (hint-unlit)
+                            (texture (load-texture tex))
+                            (translate (vector 1 0.01 0))
+                            (rotate (vector 0 0 rot))      
+                            (set! rot 0)
+                            (build-copy src-obj))))
+                (with-primitive obj
+                    (hide 0)
+                    ;(apply-transform)
+                    (when (not (zero? last-obj))
+                        (parent last-obj)))
+                (set! last-obj obj)
+                (set! obj-list (cons obj obj-list))))
+        
+        
+        (hint-ignore-depth)
+        (for-each 
+            (lambda (char)
+                (cond 
+                    ((char=? #\F char) (make-component branch-obj (string-append texture-loc "branch-a.png")))                
+                    ((char=? #\G char) (make-component branch-obj (string-append texture-loc "branch-b.png")))                
+                    ((char=? #\L char) (make-component leaf-obj (string-append texture-loc "leaf-a.png")))               
+                    ((char=? #\B char) (make-component leaf-obj (string-append texture-loc "leaf-b.png")))               
+                    ((char=? #\+ char)
+                        (set! rot (+ rot angle)))
+                    ((char=? #\- char)
+                        (set! rot (- rot angle)))
+                    ((char=? #\[ char)
+                            (push)
+                            (set! parent-stack (cons last-obj parent-stack))
+                            (scale (vector branch-scale branch-scale branch-scale))
+                            )
+                        ((char=? #\] char)
+                        (pop)
+                        (set! last-obj (car parent-stack))
+                        (set! parent-stack (cdr parent-stack)))))
+            (string->list string))
+    obj-list))
+
+(define (animate obj-list)
+    (let ((c 0))
+    (for-each 
+        (lambda (objs)
+            (for-each 
+                (lambda (obj)
+                    (with-primitive obj
+                        (rotate (vector 0 0 (* 0.1 (sin (+ c (time)))))))
+                    (set! c (+ c 20)))
+                objs))
+        obj-list)))
+
+
+(ortho)
+(clear-colour (vector 0 0 0))
+(set-camera-transform (mmul 
+    (mrotate (vector 0 0 90))
+    (mtranslate (vector -9 0 -10))))
+(set-ortho-zoom -10)
+(clear-texture-cache)
+
+(define trees '())
+
+(colour 1)
+
+(for ((i (in-range 0 5)))
+    (let ((t2 (with-state
+                    (translate (vector 0 (* 20 (crndf)) (rndf)))
+                    (build-locator))))
+        (set! trees (cons (ls-build t2 (ls-generate 3 "F" '(("F" "G-[-F+G+FB]+F[+F-G-FL]-F"))) 
+            (+ 10 (random 20)) 0.9) trees))))
+
+
+(every-frame (animate trees))

flatgarden/parent-test.scm

@@ -0,0 +1,137 @@
+(clear)
+
+; try all the rules on this character - 
+; returns #f if none are matched
+(define (lsys-run-rules char rules)
+    (foldl
+        (lambda (rule str)
+            (if str ; if str is not #f
+                str ; then we have already found a rule, return it
+                (if (char=? char (string-ref (car rule) 0)) ; check this rule
+                    (cadr rule) ; return the string
+                    #f))) ; no match
+        #f
+        rules))
+
+; runs the lsystem rules on every character in a string, 
+; returns the new string
+(define (lsys-search-replace str rules pos result)
+    (cond 
+        ((>= pos (string-length str)) result)
+        (else
+            (let ((ret (lsys-run-rules (string-ref str pos) rules)))
+                (if (string? ret)
+                    (lsys-search-replace str rules (+ pos 1) 
+                        (string-append result ret))
+                    (lsys-search-replace str rules (+ pos 1) 
+                        (string-append result (string (string-ref str pos)))))))))
+
+; runs the search-replace multiple (n) times on a string
+(define (ls-generate n str rules)
+    (cond 
+        ((zero? n) str)
+        (else
+            (ls-generate (- n 1) 
+                (lsys-search-replace str rules 0 "") rules))))
+
+; todo: get rid of all these
+
+(define branch-obj (with-state
+        (translate (vector 0.5 0 0))
+        (scale (vector 1 0.5 0.5))
+        (rotate (vector 0 0 90))
+        (build-plane)))
+
+(with-primitive branch-obj
+    (hide 1)
+    (apply-transform))
+
+(define leaf-obj (with-state
+        (translate (vector 0.5 0 0))
+        ;    (scale (vector 1 0.5 0.5))
+        (rotate (vector 0 0 90))
+        (build-plane)))
+
+(with-primitive leaf-obj
+    (hide 1)
+    (apply-transform))
+
+
+; builds objects from a string
+(define (ls-build root string angle branch-scale)
+    (let ((parent-stack '(root))
+            (last-obj root)
+            (obj-list '())
+            (rot 0))
+        
+        (define (make-component src-obj tex)
+            (let ((obj (with-state
+                            (hint-unlit)
+                            (texture (load-texture tex))
+                            (translate (vector 1 0.01 0))
+                            (rotate (vector 0 0 rot))      
+                            (set! rot 0)
+                            (build-copy src-obj))))
+                (with-primitive obj
+                    (hide 0)
+                    ;(apply-transform)
+                    (when (not (zero? last-obj))
+                        (parent last-obj)))
+                (set! last-obj obj)
+                (set! obj-list (cons obj obj-list))))
+        
+        
+        (hint-ignore-depth)
+        (for-each 
+            (lambda (char)
+                (cond 
+                    ((char=? #\F char) (make-component branch-obj "textures/branch-a.png"))                
+                    ((char=? #\G char) (make-component branch-obj "textures/branch-b.png"))                
+                    ((char=? #\L char) (make-component leaf-obj "textures/leaf-a.png"))                   
+                    ((char=? #\B char) (make-component leaf-obj "textures/leaf-b.png"))                   
+                    ((char=? #\+ char)
+                        (set! rot (+ rot angle)))
+                    ((char=? #\- char)
+                        (set! rot (- rot angle)))
+                    ((char=? #\[ char)
+                            (push)
+                            (set! parent-stack (cons last-obj parent-stack))
+                            (scale (vector branch-scale branch-scale branch-scale))
+                            )
+                        ((char=? #\] char)
+                        (pop)
+                        (set! last-obj (car parent-stack))
+                        (set! parent-stack (cdr parent-stack)))))
+            (string->list string))))
+
+(define (animate obj-list)
+    (let ((c 0))
+    (for-each 
+        (lambda (obj)
+            (with-primitive obj
+                (translate (vector 0 (* 0.1 (sin (+ c (time)))) 0)))
+            (set! c (+ c 1)))
+        obj-list)))
+
+
+(ortho)
+(set-camera-transform (mmul 
+    (mrotate (vector 0 0 90))
+    (mtranslate (vector -9 0 -10))))
+(set-ortho-zoom -15)
+(clear-texture-cache)
+
+(define trees '())
+
+(colour 0.2)
+
+(for ((i (in-range 0 10)))
+    (let ((t2 (with-state
+                    (translate (vector 0 (* 20 (crndf)) (rndf)))
+                    (build-locator))))
+        (set! trees (cons t2 trees))
+        (ls-build t2 (ls-generate 3 "F" '(("F" "G-[-F+G+FB]+F[+F-G-FL]-F"))) 
+            (+ 10 (random 20)) 0.9)))
+
+
+(every-frame (animate trees))

mingle/dance-mingle.scm

@@ -0,0 +1,191 @@
+(require fluxus-016/fluxa)
+(clear)
+
+(define texture-loc "/home/dave/flotsam/groworld/game-prototypes/mingle/textures/")
+
+;----------------------------------------------------------------
+
+(define t 0)
+
+(define (vg-npush-particles)
+    (set! t (+ t 0.04))
+    (pdata-map! 
+        (lambda (p)
+            (let* ((pp (vmul p 0.1))
+                    (v (vector (- (noise (vx pp) (vy pp) (time)) 0.5)
+                            (- (noise (vx pp) (+ (vy pp) 112.3) t) 0.5) 0)))
+                (vadd (vadd p (vmul v 1))
+                    (vmul (vector (crndf) (crndf) 0) 0.05))))
+        "p"))
+
+(define (cirndvec)
+    (let ((o (srndvec)))
+        (vector (vx o) (vy o) 0)))
+
+(define (puff pos col size np)
+    (for ((i (in-range 0 np)))
+        (let ((c (random (pdata-size))))
+            (pdata-set! "p" c (vadd (vmul (cirndvec) size) pos))
+            (pdata-set! "c" c (vadd col (vmul (grndvec) 0.2))))))
+
+
+;-------------
+
+(define-struct flower (pos tex col root rot 
+        (sc #:mutable) (power #:mutable) (r #:mutable)))
+
+(define (build-flower pos tex col)
+    (let ((pos (vadd pos (vmul (cirndvec) 1))))
+        (make-flower pos tex col (with-state
+                (translate pos)
+                (hint-unlit)
+                (scale 3)
+                ;            (colour col)    
+                (texture (load-texture tex))
+                (build-plane))
+            (* (crndf) 0.5)
+            1
+            100
+            0)))
+
+(define (flower-puff flower particles)
+    (set-flower-sc! flower 2)
+    (with-primitive particles
+        (puff (flower-pos flower) (flower-col flower) 1 (flower-power flower))
+        (when (> (flower-power flower) 0)
+            (set-flower-power! flower (- (flower-power flower) 5)))))
+
+(define (flower-update flower particles do-puff)
+    (with-primitive (flower-root flower)
+        (identity)
+        (translate (flower-pos flower))
+        (scale 3)
+        (when (> (flower-sc flower) 1)
+            (set-flower-sc! flower (* (flower-sc flower) 0.9))
+            (scale (* (flower-sc flower) 1))
+            (colour (flower-sc flower)))
+        
+        (set-flower-r! flower (+ (flower-r flower) (flower-rot flower)))
+        (rotate (vector 0 0 (flower-r flower))))
+    (when (< (flower-power flower) 100) 
+        (set-flower-power! flower (+ (flower-power flower) 1))))
+
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+(define debounce-vec (build-vector 10 (lambda (_) #f)))
+
+(define (debounce n)
+    (vector-ref debounce-vec n))
+
+(define (debounce! n s)
+    (vector-set! debounce-vec n s))
+
+(define (on-key p n proc)
+    (if p
+        (when (debounce n)
+            (proc)
+            (debounce! n #f))
+        (debounce! n #t)))
+
+;--------------
+
+(clear)
+
+(define f (list
+        (build-flower (vector -5 5 0) (string-append texture-loc "wflower1.png") (vector 1 0.5 0.6))
+        (build-flower (vector 0 5 0) (string-append texture-loc "wflower2.png") (vector 0.6 0 0.6))
+        (build-flower (vector 5 5 0) (string-append texture-loc "wflower3.png") (vector 1 1 0))
+        
+        (build-flower (vector -5 0 0) (string-append texture-loc "wflower4.png") (vector 1 1 0.9))
+        (build-flower (vector 0 0 0) (string-append texture-loc "wflower5.png") (vector 0.6 0.6 1))
+        (build-flower (vector 5 0 0) (string-append texture-loc "wflower6.png") (vector 0.5 0.5 0.5))
+        
+        (build-flower (vector -5 -5 0) (string-append texture-loc "wflower7.png") (vector 0.5 0.2 0.1))
+        (build-flower (vector 0 -5 0) (string-append texture-loc "wflower8.png") (vector 0.5 0.5 1))
+        (build-flower (vector 5 -5 0) (string-append texture-loc "wflower9.png") (vector 1 1 1))))
+
+
+(define p (with-state
+        (texture (load-texture (string-append texture-loc "particle.png")))
+        (build-particles 3000)))
+
+(with-primitive p
+    (opacity 0.5)
+    (hint-ignore-depth)
+    (pdata-map!
+        (lambda (p)
+            (vmul (vector (crndf) (crndf) 0) 100))
+        "p")
+    (pdata-map!
+        (lambda (c)
+            (vector 1 1 1 0.5))
+        "c")
+    (pdata-map!
+        (lambda (c)
+            (let ((s (* 0.5 (grndf))))
+                (vector s s 1)))
+        "s"))
+
+
+;-------------
+
+
+(define (animate)
+    (on-key (key-pressed "q") 0 
+        (lambda () 
+            (play-now (mul (adsr 0 0.1 0.1 1) 
+                    (mul (sine (add 20 (mul (adsr 0 0.05 0 0) 3))) 4)))
+            (flower-puff (list-ref f 0) p)))
+    (on-key (key-special-pressed 101) 1
+        (lambda () 
+            (play-now (mul (adsr 0 0.1 0.1 1) (sine (add 100 (mul (sine 10) 3000)))))
+            (flower-puff (list-ref f 1) p)))
+    (on-key (key-pressed "e") 2
+        (lambda () 
+            (play-now (mul (adsr 0 0.1 0.1 1) (mooglp (add (saw 41) (saw 40)) (adsr 0.1 0 0 0) 0.4)))
+            (flower-puff (list-ref f 2) p)))
+    
+    (on-key (key-special-pressed 100) 3
+        (lambda () 
+            (play-now (mul (adsr 0 0.1 0.1 1) 
+                    (sine (add 100 (mul (sine 100) (mul (adsr 0.2 0.2 0 0) 3000))))))
+            (flower-puff (list-ref f 3) p)))
+    (on-key (key-pressed "s") 4
+        (lambda () 
+            (play-now (mul (adsr 0 0.05 0 0) (pink 4)))
+            (flower-puff (list-ref f 4) p)))
+    (on-key (key-special-pressed 102) 5
+        (lambda () 
+            (play-now (mul (adsr 0 0.1 0.1 1) (moogbp (add (saw 81) (saw 81.1)) (adsr 0.1 0 0 0) 0.4)))
+            (flower-puff (list-ref f 5) p)))
+    
+    (on-key (key-pressed "z") 6
+        (lambda () 
+            (play-now (mul (adsr 0 0.1 0.1 1) 
+                    (sine (+ (random 100) 100))))
+            (flower-puff (list-ref f 6) p)))
+    (on-key (key-special-pressed 103) 7
+        (lambda () 
+            (play-now (mul (adsr 0.2 0.1 0.1 1) 
+                (sine (add 100 (mul (sine 100) (mul (sine 5) 300))))))
+
+            (flower-puff (list-ref f 7) p)))
+    (on-key (key-pressed "c") 8
+        (lambda () 
+            (let ((n (+ (random 100) 50)))
+            (play-now (echo 
+                (mul (adsr 0 0.05 0.1 1) 
+                    (mul (add (squ (+ n 0.1)) (squ n)) 0.3))
+                0.1 0.6)))
+
+            (flower-puff (list-ref f 8) p)))
+    
+    (for-each 
+        (lambda (flower)
+            (flower-update flower p (mouse-button 1)))
+        f)
+    
+    (with-primitive p 
+        (vg-npush-particles)))
+
+(every-frame (animate))

mingle/vg.scm

@@ -0,0 +1,144 @@
+(clear)
+
+(define-struct vg (v w h))
+
+(define (build-vg x y)
+    (make-vg    
+        (build-vector (* x y) (lambda (n)
+                (srndvec))) x y))
+
+(define (vg-ref vg x y)
+    (if (and (>= x 0) (>= y 0) (< x (vg-w vg)) (< y (vg-h vg)))
+        (vector-ref (vg-v vg) (+ (* y (vg-w vg)) x))
+        (vector 0 0 0)))
+
+(define (vg-lerp vg x y)
+    (let* ((ix (inexact->exact (floor x))) (iy (inexact->exact (floor y)))
+            (fx (- x ix)) (fy (- y iy)))
+        (if (and (>= ix 0) (>= iy 0) (< (+ ix 1) (vg-w vg)) (< (+ iy 1) (vg-h vg)))
+            (let ((a (vector-ref (vg-v vg) (+ (* iy (vg-w vg)) ix)))
+                    (b (vector-ref (vg-v vg) (+ (* (+ iy 1) (vg-w vg)) (+ ix 1)))))
+                (vector (+ (* (vx b) fx) (* (vx a) (- 1 fx)))
+                    (+ (* (vy b) fy) (* (vy a) (- 1 fy))) 0))
+            (vector 0 0 0))))
+
+
+(define (vg-set! vg x y s)
+    (when (and (>= x 0) (>= y 0) (< x (vg-w vg)) (< y (vg-h vg)))
+        (vector-set! (vg-v vg) (+ (* y (vg-w vg)) x) s)))
+
+(define (vg-blend! vg)
+    (for ((x (in-range 0 (vg-w vg))))        
+        (for ((y (in-range 0 (vg-h vg))))
+            (vg-set! vg x y 
+                (vadd
+                    (vmul (vadd
+                            (vadd (vg-ref vg (- x 1) y) (vg-ref vg x (- y 1)))
+                            (vadd (vg-ref vg (+ x 1) y) (vg-ref vg x (+ y 1))))
+                        (/ 1 5))
+                    (vmul (vg-ref vg x y) (/ 1 5)))))))
+
+(define (vg-turbulate! vg s)
+    (for ((x (in-range 0 (vg-w vg))))        
+        (for ((y (in-range 0 (vg-h vg))))
+            (vg-set! vg x y 
+                (vmul
+                    (let ((x (* x 0.1)) (y (* y 0.1)))
+                        (vector (- (noise (+ x (time)) y)  0.5)
+                            (- (noise (+ x (time)) (+ y 100)) 0.5) 0)) s)))))
+
+(define (vg-jitter! vg s)
+    (for ((x (in-range 0 (vg-w vg))))        
+        (for ((y (in-range 0 (vg-h vg))))
+            (vg-set! vg x y 
+                (vadd 
+                    (vmul
+                        (vector (crndf) (crndf) 0) s)
+                    (vmul (vg-ref vg x y) (- 1 s)))))))
+
+
+
+(define (render-vg root vg)
+    (with-state
+        (wire-colour (vector 1 1 1))
+        (hint-none)
+        (hint-wire)
+        (line-width 1)
+        (hint-unlit)
+        (parent root)
+        (for ((x (in-range 0 (vg-w vg))))
+            (for ((y (in-range 0 (vg-h vg))))
+                (let ((p (build-ribbon 2)))
+                    (with-primitive p
+                        (pdata-set! "p" 0 (vector x y 0))
+                        (pdata-set! "p" 1 (vadd (vector x y 0) 
+                                (vmul (vg-ref vg x y) 1)))))))))
+
+
+;----------------------------------------------------------------
+
+
+(define (vg-push-particles vg)
+    (pdata-map! 
+        (lambda (p)
+            (let ((v (vg-lerp vg (vx p) (vy p))))0
+                (if (and (zero? (vx v)) (zero? (vy v)))
+                    (vadd (vector 15 15 0) 
+                        (vmul (vector (crndf) (crndf) 0) 1))
+                    (vadd (vadd p (vmul v 0.5))
+                        (vmul (vector (crndf) (crndf) 0) 0.1)))))
+        "p"))
+
+
+(clear)
+
+(define p (with-state
+    (hint-none)
+    (hint-points)
+    (build-particles 5000)))
+
+(with-primitive p
+    (pdata-map!
+        (lambda (p)
+            (vadd (vector 15 15 0) (vmul (vector (crndf) (crndf) 0) 1)))
+        "p")
+    (pdata-map!
+        (lambda (c)
+            (vector 1 1 1))
+        "c"))
+
+(define r (build-locator))
+
+(define v (build-vg 30 30))
+
+(define (animate)
+    
+    (with-primitive p
+        (vg-push-particles v)
+        #;(for ((i (in-range 0 10)))
+            (pdata-set! "p" (random (pdata-size)) (vadd (vector 15 15 0) 
+                    (vmul (vector (crndf) (crndf) 0) 10)))))
+    
+    #;(when (zero? (random 1))
+        (for ((i (in-range 0 10))) 
+            (vg-set! v (random (vg-w v)) (random (vg-h v))
+                (vmul (vector (crndf) (crndf) 0) 1))))
+    #;(when (zero? (random 1))
+        (for ((i (in-range 0 1))) 
+            (let ((x (random (vg-w v)))
+                    (y (random (vg-h v))))
+                (vg-set! v x y
+                    (vnormalise (vg-ref v x y))))))
+    
+    ;(vg-set! v 0 10 (vector 1 0 0))
+    ;(vg-set! v 10 5 (vector 0 1 0))
+    ;(vg-set! v 8 0 (vector 1 -1 0))
+    
+    
+    (destroy r)
+    (set! r (build-locator))
+    (vg-turbulate! v 5)
+    ;    (vg-blend! v)
+    #;(render-vg r v))
+
+(every-frame (animate))

mingle/wind.scm

@@ -0,0 +1,141 @@
+(clear)
+
+(define-struct vg (v w h))
+
+(define (build-vg x y)
+    (make-vg    
+        (build-vector (* x y) (lambda (n)
+                (srndvec))) x y))
+
+(define (vg-ref vg x y)
+    (if (and (>= x 0) (>= y 0) (< x (vg-w vg)) (< y (vg-h vg)))
+        (vector-ref (vg-v vg) (+ (* y (vg-w vg)) x))
+        (vector 0 0 0)))
+
+(define (vg-lerp vg x y)
+    (let* ((ix (inexact->exact (floor x))) (iy (inexact->exact (floor y)))
+            (fx (- x ix)) (fy (- y iy)))
+        (if (and (>= ix 0) (>= iy 0) (< (+ ix 1) (vg-w vg)) (< (+ iy 1) (vg-h vg)))
+            (let ((a (vector-ref (vg-v vg) (+ (* iy (vg-w vg)) ix)))
+                    (b (vector-ref (vg-v vg) (+ (* (+ iy 1) (vg-w vg)) (+ ix 1)))))
+                (vector (+ (* (vx b) fx) (* (vx a) (- 1 fx)))
+                    (+ (* (vy b) fy) (* (vy a) (- 1 fy))) 0))
+            (vector 0 0 0))))
+
+
+(define (vg-set! vg x y s)
+    (when (and (>= x 0) (>= y 0) (< x (vg-w vg)) (< y (vg-h vg)))
+        (vector-set! (vg-v vg) (+ (* y (vg-w vg)) x) s)))
+
+(define (vg-blend! vg)
+    (for ((x (in-range 0 (vg-w vg))))        
+        (for ((y (in-range 0 (vg-h vg))))
+            (vg-set! vg x y 
+                (vadd
+                    (vmul (vadd
+                            (vadd (vg-ref vg (- x 1) y) (vg-ref vg x (- y 1)))
+                            (vadd (vg-ref vg (+ x 1) y) (vg-ref vg x (+ y 1))))
+                        (/ 1 5))
+                    (vmul (vg-ref vg x y) (/ 1 5)))))))
+
+(define (vg-turbulate! vg s)
+    (for ((x (in-range 0 (vg-w vg))))        
+        (for ((y (in-range 0 (vg-h vg))))
+            (vg-set! vg x y 
+                (vmul
+                    (let ((x (* x 0.3)) (y (* y 0.3)))
+                        (vector (- (noise (+ x (time)) y)  0.5)
+                            (- (noise (+ x (time)) (+ y 100)) 0.5) 0)) s)))))
+
+(define (vg-jitter! vg s)
+    (for ((x (in-range 0 (vg-w vg))))        
+        (for ((y (in-range 0 (vg-h vg))))
+            (vg-set! vg x y 
+                (vadd 
+                    (vmul
+                        (vector (crndf) (crndf) 0) s)
+                    (vmul (vg-ref vg x y) (- 1 s)))))))
+
+
+
+(define (render-vg root vg)
+    (with-state
+        (wire-colour (vector 1 1 1))
+        (hint-none)
+        (hint-wire)
+        (line-width 1)
+        (hint-unlit)
+        (parent root)
+        (for ((x (in-range 0 (vg-w vg))))
+            (for ((y (in-range 0 (vg-h vg))))
+                (let ((p (build-ribbon 2)))
+                    (with-primitive p
+                        (pdata-set! "p" 0 (vector x y 0))
+                        (pdata-set! "p" 1 (vadd (vector x y 0) 
+                                (vmul (vg-ref vg x y) 1)))))))))
+
+
+;----------------------------------------------------------------
+
+
+(define (vg-push-particles vg c)
+    (pdata-map! 
+        (lambda (p)
+            (let ((v (vg-lerp vg (vx p) (vy p))))0
+                (if (and (zero? (vx v)) (zero? (vy v)))
+                    (vadd c
+                        (vmul (vector (crndf) (crndf) 0) 1))
+                    (vadd (vadd p (vmul v 0.5))
+                        (vmul (vector (crndf) (crndf) 0) 0.1)))))
+        "p"))
+
+
+(clear)
+
+(define p (with-state
+        (hint-none)
+        (hint-points)
+        (build-particles 2000)))
+
+(define rp (with-state
+        (hint-none)
+        (hint-points)
+        (build-particles 2000)))
+
+
+(with-primitive p
+    (pdata-map!
+        (lambda (p)
+            (vadd (vector 15 15 0) (vmul (vector (crndf) (crndf) 0) 1)))
+        "p")
+    (pdata-map!
+        (lambda (c)
+            (vector 1 1 1))
+        "c"))
+
+(with-primitive rp
+    (pdata-map!
+        (lambda (p)
+            (vadd (vector 10 15 0) (vmul (vector (crndf) (crndf) 0) 1)))
+        "p")
+    (pdata-map!
+        (lambda (c)
+            (vector 1 0.5 0.5))
+        "c"))
+
+
+(define r (build-locator))
+
+(define v (build-vg 30 30))
+
+(define (animate)
+    
+    (with-primitive p 
+        (vg-push-particles v (vector 5 15 0)))
+
+    (with-primitive rp 
+        (vg-push-particles v (vector 15 15 0)))
+
+    (vg-turbulate! v 5))
+
+(every-frame (animate))

roots/roots.scm

@@ -0,0 +1,168 @@
+
+
+(define (calc-xyz index max-index r)
+    (let*
+        ( [angle (* 6.28312 (/ index (- max-index 1)))]
+            [x (* (cos angle) r)]
+            [y (* (sin angle) r)] )
+        (vector x y 0)))
+
+(define (build-ellipse rmin rmaj num-verts)
+    (define p (build-polygons (* 3 num-verts) 'triangle-list))
+    (with-primitive p
+        (for ([i (in-range 0 (* 3 num-verts) 3) ])
+            (pdata-set! "p" i (vector 0 0 0))
+            (pdata-set! "n" i (vector 0 0 1))
+            (pdata-set! "p" (+ i 1) (calc-xyz (/ i 3) num-verts rmin))
+            (pdata-set! "n" (+ i 1) (vnormalise (calc-xyz (/ i 3) num-verts rmin)))
+            (pdata-set! "p" (+ i 2) (calc-xyz (+ (/ i 3) 1) num-verts rmin))
+            (pdata-set! "n" (+ i 2) (vnormalise (calc-xyz (+ (/ i 3) 1) num-verts rmin))))
+        (poly-convert-to-indexed))
+    p)
+
+(define-struct stones ((pos-list #:mutable) size-list (root #:mutable) (obj-list #:mutable)))
+
+(define (choose l)
+    (list-ref l (random (length l))))
+
+(define (stones-init num area size)
+    (make-stones
+        (build-list num
+            (lambda (_)
+                (vmul (vector (vx (srndvec)) (vy (srndvec)) 0) area)))
+        (build-list num
+            (lambda (_)
+                (* size (rndf))))
+        0
+        '()))
+
+(define (stones-build stones)
+    (let* ((root (build-locator))
+            (objs (with-state
+                    (parent root)
+                    (map
+                        (lambda (pos size)
+                            (if (and (< size 0.4) (zero? (random 3)))
+                                (let ((o (with-state
+                                                (hint-unlit)
+                                                (scale 0.2)
+                                                (colour (vector 0.25 0.5 0))
+                                                (build-plane))))
+                                    (with-primitive o (apply-transform))
+                                    o)
+                                (with-state
+                                    ;(hint-unlit)
+                                    (hint-ignore-depth)
+                                    (colour (hsv->rgb (vector (+ 0 (* 0.2 (rndf))) 0.5 (+ 0.1 (rndf)))))
+                                    (translate pos)
+                                    (build-ellipse size size 32))))
+                        (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)
+    (set-stones-pos-list! stones
+        (map 
+            (lambda (pos size)
+                (foldl
+                    (lambda (opos osize r)
+                        (if (< (vdist pos opos) (+ size osize))
+                            (vadd r (vmul (vnormalise (vsub pos opos)) amount))
+                            r))
+                    pos
+                    (stones-pos-list stones)
+                    (stones-size-list stones)))
+            (stones-pos-list stones)
+            (stones-size-list stones))))
+
+(define (stones-update stones)
+    (let ((root (build-locator)))
+        (with-state
+            (parent root)
+            (for-each
+                (lambda (obj pos size)
+                    (with-primitive obj
+                        (identity)
+                        (translate pos)))
+                (stones-obj-list stones)
+                (stones-pos-list stones)
+                (stones-size-list stones)))
+        (set-stones-root! stones root)))
+
+(define (nudge stones amount)
+    (pdata-map!
+        (lambda (p)
+            (foldl
+                (lambda (pos size r)
+                    (if (< (vdist p pos) size)
+                        (vadd r (vmul (vnormalise (vsub p pos)) amount))
+                        r))
+                p
+                (stones-pos-list stones)
+                (stones-size-list stones)))
+        "p"))
+
+(define (shrink amount)
+    (pdata-index-map!
+        (lambda (i p)
+            (if (or (zero? i) (eq? i (- (pdata-size) 1)))
+                p
+                (vadd (vmul p (- 1 amount)) 
+                    (vmul (pdata-ref "p" (+ i 1)) (* 0.5 amount))
+                    (vmul (pdata-ref "p" (- i 1)) (* 0.5 amount)))))
+        "p"))
+
+(define (mangle-normals amount)
+    (pdata-map! 
+        (lambda (n)
+            (vadd n (vmul (srndvec) amount)))
+        "n"))
+
+(define (build-root x)
+    (let ((root (with-state 
+;                    (hint-unlit)
+                    (hint-ignore-depth)
+                    (colour (vmul (vector 0.2 0.4 0.2) (+ 0.5 (rndf))))
+                    (build-ribbon 25))))
+        
+        (with-primitive root
+            (pdata-index-map!
+                (lambda (i p)
+                    (vector (+ (crndf) x) (- (* i 0.3) 2) 0)
+                    #;(vmul (vector (vx (srndvec)) (vy (srndvec)) 0) 3))
+                "p")
+            (pdata-index-map!
+                (lambda (i w)
+                    (* 0.4 (/ i (pdata-size))))
+                "w"))
+        root))
+
+(clear)
+(clear-colour 0)
+(define l (make-light 'point 'free))
+(light-position l (vector 0 10 -5))
+(light-diffuse 0 (vector 0.2 0.2 0.2))
+(light-diffuse l (vector 1 1 1))
+
+(define s (stones-build (stones-init 100 5 1)))
+
+(define roots (build-list 10 (lambda (_) (build-root (* 5 (crndf))))))
+
+(define (animate)
+    (for-each
+        (lambda (root)
+            (with-primitive root
+                (nudge s 0.01)
+                (shrink 0.01)))
+        roots)
+    (stones-relax s 0.01)
+    (stones-update s))
+
+(every-frame (animate))
+
+
+
+
+

sketcher/ls.ss

@@ -0,0 +1,37 @@
+#lang scheme/base
+
+(provide (all-defined-out))
+
+; try all the rules on this character - 
+; returns #f if none are matched
+(define (run-rules char rules)
+    (foldl
+        (lambda (rule str)
+            (if str ; if str is not #f
+                str ; then we have already found a rule, return it
+                (if (char=? char (string-ref (car rule) 0)) ; check this rule
+                    (cadr rule) ; return the string
+                    #f))) ; no match
+        #f
+        rules))
+
+; runs the lsystem rules on every character in a string, 
+; returns the new string
+(define (search-replace str rules pos result)
+    (cond 
+        ((>= pos (string-length str)) result)
+        (else
+            (let ((ret (run-rules (string-ref str pos) rules)))
+                (if (string? ret)
+                    (search-replace str rules (+ pos 1) 
+                        (string-append result ret))
+                    (search-replace str rules (+ pos 1) 
+                        (string-append result (string (string-ref str pos)))))))))
+
+; runs the search-replace multiple (n) times on a string
+(define (lsystem-generate n str rules)
+    (cond 
+        ((zero? n) str)
+        (else
+            (lsystem-generate (- n 1) 
+                (search-replace str rules 0 "") rules))))

sketcher/sketch-lsys.scm

@@ -0,0 +1,201 @@
+;------------------------------------------------------
+; lsystem sketching prototype
+; ---------------------------
+;
+; an idea for putting lsystems under human control, 
+; and making them sketchable. 
+; not sure how this would be best extended to 3D.
+; [I need to work on the mouse stuff in fluxus]
+;
+; instructions:
+; * draw from the centre by dragging with left mouse
+; * repeat to make a new plant/drawing
+;
+; don't make the drawing too long, it'll make your computer cry
+
+(require "ls.ss")
+
+; gets a line representing a segment of the projection of the mouse into 3D space
+; should move this into the fluxus scheme library 
+(define (get-line-from-mouse)
+    (let* ((ndcpos (vector (* (- (/ (mouse-x) (vx (get-screen-size))) 0.5) 2)
+                    (* (- (- (/ (mouse-y) (vy (get-screen-size))) 0.5)) 1.5) -1))
+            (scrpos2 (vtransform (vmul ndcpos 50) (minverse (get-camera-transform))))
+            (scrpos (vtransform ndcpos (minverse (get-camera-transform)))))
+        (list scrpos scrpos2)))
+
+; we'll just use the end of the projection line here
+(define (mouse-pos)
+    (cadr (get-line-from-mouse)))
+
+; 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)))))
+
+;-----------------------------------------------------
+; builds objects from a string
+; would be good to abstract this asap
+
+(define (ls-build string angle branch-scale branch-col leaf-col)
+    (hint-depth-sort)
+    (for-each 
+        (lambda (char)
+            (cond 
+                ((char=? #\F char)
+                    (with-state
+                        (translate (vector 1 0 0))
+                        (translate (vmul (crndvec) 0.01))
+                        (scale (vector 1.2 2 2))
+                        (rotate (vector 0 90 0))         
+                        (colour (vector 0.5 1 0.2))                        
+                        (with-primitive (build-ribbon 2)
+                        ;    (texture (load-texture "textures/fade4.png"))
+                        ;    (hint-unlit)
+                            (pdata-set! "w" 0 0.1)
+                            (pdata-set! "w" 1 0.1)
+                            (pdata-set! "p" 0 (vector 0 0 1))
+                            (pdata-set! "p" 1 (vector 0 0 0))))
+                    (translate (vector 1 0 0)))
+                ((char=? #\L char)
+                    #;                   (with-state
+                        (translate (vector 1 0 0))
+                        (scale (vector 2 1 1))
+                        ;         (rotate (vector 0 90 0))         
+                        (colour leaf-col)
+                        (texture (load-texture "../textures/leaf.png"))
+                        (build-plane))
+                    (translate (vector 1 0 0)))
+                ((char=? #\f char)
+                    (translate (vector 1 0 0)))
+                ((char=? #\/ char)
+                    (rotate (vector angle 0 0)))
+                ((char=? #\\ char)
+                    (rotate (vector (- angle) 0 0)))
+                ((char=? #\+ char)
+                    (rotate (vector 0 angle 0)))
+                ((char=? #\- char)
+                    (rotate (vector 0 (- angle) 0)))
+                ((char=? #\^ char)
+                    (rotate (vector 0 0 angle)))
+                ((char=? #\& char)
+                    (rotate (vector 0 0 (- angle))))
+                ((char=? #\| char)
+                    (rotate (vector 0 0 180)))
+                ((char=? #\[ char)
+                        (push)
+                        (scale (vector branch-scale branch-scale branch-scale)))
+                    ((char=? #\] char)
+                    (pop))))
+        (string->list string)))
+
+;------------------------------------------------------
+; strokes are collections of points representing mouse movement
+
+(define-struct stroke ((points #:mutable)))
+
+(define (build-stroke)
+    (make-stroke (list (vector 0 0 -40)))) ; start with a point in the middle of the screen
+
+(define (stroke-clear stroke)
+    (set-stroke-points! stroke (list (vector 0 0 -40))))
+
+(define (stroke-add stroke pos)
+    (set-stroke-points! stroke (cons pos (stroke-points stroke))))
+
+(define (stroke-last-point stroke)
+    (car (stroke-points stroke)))
+
+(define (stroke-update stroke)
+    ; make a new point when the mouse is suitibly far from the last point
+    (when (> (vdist (stroke-last-point stroke) (mouse-pos)) 2)
+        (stroke-add stroke (mouse-pos))))
+
+; draw some blobs to indicate the path drawn
+(define (stroke-render stroke)
+    (for-each 
+        (lambda (pos)
+            (with-state
+                (opacity 0.7)
+                (translate pos)
+                (hint-unlit)
+                (colour (vector 1 1 0))
+                (draw-sphere)))
+        (stroke-points stroke)))
+
+; converts a stroke into the corresponding lsystem string, 
+; with some branchpoints to recurse the drawing - would be 
+; better to get the branchpoints from the drawing somehow...
+(define (stroke->string stroke angle)
+    (define (collect pos next-pos last-angle str c)
+        (cond ((null? next-pos) str)
+            (else
+                (let* ((v (vsub (car pos) (car next-pos)))
+                        (a (2dvec->angle (vx v) (vy v))) ; get the absolute angle
+                        (ra (- a last-angle)) ; get angle relative to the last angle
+                        ; make a string which represents this turn
+                        (new-str (if (> ra 0) ; which way are we turning?
+                                (make-string (inexact->exact (round (/ ra angle))) #\-)
+                                (make-string (inexact->exact (round (abs (/ ra angle)))) #\+)))
+                        (out (if (zero? (modulo c 10))
+                                (string-append str new-str "F") ; add branch
+                                (string-append str new-str "F")))) ; normal
+                    
+                    (collect (cdr pos) (cdr next-pos) a out (+ c 1))))))
+    (collect 
+        (reverse (stroke-points stroke))
+        (cdr (reverse (stroke-points stroke))) 0 "" 0))
+
+;------------------------------------------------------
+
+; a fluxus mouse pointer!
+(define (draw-mouse)
+    (with-state
+        (translate (mouse-pos))
+        (hint-unlit)
+        (colour (vector 1 0.4 0.3))
+        (draw-sphere)))
+
+(define stroke (build-stroke))
+(define root (build-locator))
+(define debounce #t)
+
+(define (animate)
+    (draw-mouse)
+    (when (mouse-button 1) (stroke-update stroke))
+    (stroke-render stroke)
+
+    (when (and (not debounce) (not (mouse-button 1)))
+        (display (stroke->string stroke 45))(newline)
+        (with-state
+            (parent root)
+;            (translate (vector 0 -30 -40))
+            (scale 0.75)
+            (rotate (vector 90 90 0))
+            (ls-build 
+                (lsystem-generate 4 "A" (list (list "A" "B[----AB][++++AB]")
+                                              (list "B" (stroke->string stroke 10))))
+                10 0.75 (vector 1 1 1) (vector 1 1 1)))
+        (set! debounce #t))
+
+    
+    (when (and debounce (mouse-button 1))
+        (set! debounce #f)
+        (stroke-clear stroke)
+        (destroy root)
+        (set! root (build-locator))))
+
+(clear)
+(clear-colour (vector 0.2 0.4 0.3))
+(set-camera-transform (mtranslate (vector 0 0 -10)))
+(light-diffuse 0 (vector 0 0 0))
+(define l (make-light 'point 'free))
+(light-diffuse l (vector 1 1 1))
+(light-position l (vector -50 50 0))
+
+(every-frame (animate))

treetris/treetris.scm

@@ -0,0 +1,470 @@
+; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+; treetris game prototype
+; -----------------------
+;
+; use the cursor keys to play tetris and grow a tree
+; 
+
+(clear-texture-cache)
+(define-struct grid (width height root bgcol))
+
+(define (feq? a b)
+    (let ((dif (vsub a b)))
+        (and 
+            (< (abs (vx dif)) 0.01)
+            (< (abs (vy dif)) 0.01)
+            (< (abs (vz dif)) 0.01))))
+
+(define (build-grid w h bgcol)
+    (with-state  
+        (hint-unlit)
+        (hint-vertcols)
+        ;(texture (load-texture "textures/tetris.png"))
+        (let ((p (build-polygons (* w h 4) 'quad-list)))
+            
+            (with-primitive p
+                (pdata-index-map!
+                    (lambda (i p)
+                        (let* ((v (modulo i 4))
+                                (b (quotient i 4))
+                                (q (quotient b w))
+                                (c (cond 
+                                        ((eq? v 0) b)
+                                        ((eq? v 1) (+ b 1))
+                                        ((eq? v 2) (+ b 1))
+                                        ((eq? v 3) b)))
+                                (rq (if (or (eq? v 2) (eq? v 3)) (+ q 1) q)))
+                            
+                            (vector 
+                                (* rq (sin (* (/ (modulo c w) w) 6.282)))
+                                (* rq (cos (* (/ (modulo c w) w) 6.282)))
+                                0)))
+                    "p")
+                (pdata-index-map!
+                    (lambda (i t)
+                        (let ((v (modulo i 4)))
+                            (cond 
+                                ((eq? v 0) (vector 0 0 0))
+                                ((eq? v 1) (vector 1 0 0))
+                                ((eq? v 2) (vector 1 1 0))
+                                ((eq? v 3) (vector 0 1 0)))))
+                    "t")
+                (pdata-map!
+                    (lambda (c)
+                        bgcol)
+                    "c"))
+            
+            (let ((g (make-grid w h p bgcol)))
+                (for ((i (in-range 0 w)))
+                    (grid-poke g i 5 (vector 0 0.3 0)))
+                g))))
+
+(define (grid-row-filled? grid row)
+    (not (foldl
+            (lambda (pos gap-found)
+                (if gap-found
+                    #t
+                    (feq? (grid-bgcol grid) 
+                        (grid-peek grid (vector-ref pos 0) (vector-ref pos 1)))))
+            #f
+            (build-list (grid-width grid) (lambda (x) (vector x row))))))
+
+(define (grid-row-block? grid row)
+    (foldl
+        (lambda (pos block-found)
+            (if block-found
+                #t
+                (not (feq? (grid-bgcol grid)
+                        (grid-peek grid (vector-ref pos 0) (vector-ref pos 1))))))
+        #f
+        (build-list (grid-width grid) (lambda (x) (vector x row)))))
+
+(define (grid-copy-row grid src dst)
+    (for ((col (in-range 0 (grid-width grid))))
+        (grid-poke grid col dst (grid-peek grid col src))))
+
+(define (grid-delete-row grid row)
+    (for ((y (in-range 6 (- (grid-height grid) 1))))
+        (when (>= y row)
+            (grid-copy-row grid (+ y 1) y))))
+
+(define (grid-look-for-rows grid on-row)
+    (for ((row (in-range 6 (grid-height grid))))
+        (when (grid-row-filled? grid row)
+            (grid-delete-row grid row)
+            (on-row row))))
+
+(define (grid-clear grid)
+    (for ((row (in-range 6 (grid-height grid))))
+        (for ((col (in-range 0 (grid-width grid))))
+            (grid-poke grid col row (grid-bgcol grid)))))
+
+(define (grid-poke grid x y s)
+    (let* ((x (modulo x (grid-width grid)))
+            (b (* 4 (+ x (* y (grid-width grid))))))
+        (when (and (>= y 0) (< y (grid-height grid)))
+            (with-primitive (grid-root grid)
+                (pdata-set! "c" b s)
+                (pdata-set! "c" (+ b 1) s)
+                (pdata-set! "c" (+ b 2) s)
+                (pdata-set! "c" (+ b 3) s)))))
+
+(define (grid-peek grid x y)
+    (let* ((x (modulo x (grid-width grid)))
+            (b (* 4 (+ x (* y (grid-width grid))))))
+        (if (and (>= y 0) (< y (grid-height grid)))
+            (with-primitive (grid-root grid)
+                (pdata-ref "c" b))
+            (vector 0 0 0))))
+
+; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+(define-struct shape (cells colour))
+
+(define shapes
+    (list (make-shape (list (vector 0 1) (vector 0 0) (vector 1 0) (vector -1 0)) (vector 0 1 0))
+        (make-shape (list (vector -1 1) (vector -1 0) (vector 0 0) (vector 0 -1)) (vector 1 0 0))
+        (make-shape (list (vector -1 0) (vector 0 0) (vector 1 0) (vector 2 0)) (vector 0 0 1))
+        (make-shape (list (vector 0 0) (vector 1 0) (vector 0 1) (vector 1 1)) (vector 1 1 0))
+        (make-shape (list (vector 0 0) (vector 1 0) (vector 0 1) (vector 0 2)) (vector 0 1 1))))
+
+(define (random-shape)
+    (list-ref shapes (random (length shapes))))
+
+; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+(define-struct block ((pos #:mutable) (shape #:mutable) colour))
+
+(define (block-write block grid s)
+    (for-each
+        (lambda (pos)
+            (grid-poke grid (+ (vector-ref (block-pos block) 0) (vector-ref pos 0))
+                (+ (vector-ref (block-pos block) 1) (vector-ref pos 1)) s))
+        (block-shape block)))
+
+(define (block-rotate-ccw block)
+    (set-block-shape! block
+        (map
+            (lambda (pos)
+                (vector (vector-ref pos 1) (- (vector-ref pos 0))))
+            (block-shape block))))
+
+(define (block-rotate-cw block)
+    (set-block-shape! block
+        (map
+            (lambda (pos)
+                (vector (- (vector-ref pos 1)) (vector-ref pos 0)))
+            (block-shape block))))
+
+(define (block-move! block vec)
+    (set-block-pos! block (vector (+ (vector-ref vec 0) (vector-ref (block-pos block) 0))
+            (+ (vector-ref vec 1) (vector-ref (block-pos block) 1)))))
+
+(define debounce #t)
+
+(define (block-deal-with-input block grid)
+    (block-write block grid (grid-bgcol grid)) ; clear the block
+    
+    ; do rotations here...
+    (when (and debounce (key-special-pressed 103)) ; rotate ccw
+        (set! debounce #f)
+        (block-move! b (vector 0 -1))
+        (when (block-check block grid)
+            (block-move! b (vector 0 1))))
+    
+    (when (and debounce (key-special-pressed 101)) ; rotate cw
+        (set! debounce #f)
+        (block-rotate-cw b)
+        (when (block-check block grid)
+            (block-rotate-ccw b))) ; can't rotate
+    
+    (when (and debounce (key-special-pressed 100)) ; move left
+        (set! debounce #f)
+        (block-move! block (vector -1 0))
+        (when (block-check block grid)
+            (block-move! block (vector 1 0))))
+    
+    (when (and debounce (key-special-pressed 102)) ; move right
+        (set! debounce #f)
+        (block-move! block (vector 1 0))
+        (when (block-check block grid)
+            (block-move! block (vector -1 0))))
+    
+    (when (null? (keys-special-down))
+        (set! debounce #t))
+    
+    (block-write block grid (block-colour block))) ; write the block
+
+; hack
+(define reset #f)
+
+(define (block-update block grid)
+    (block-write block grid (grid-bgcol grid)) ; clear the block
+    
+    (block-move! block (vector 0 -1))
+    
+    (cond ((block-check block grid)
+            ; reverse!
+            (block-move! block (vector 0 1))            
+            (block-write block grid (block-colour block)) ; write the block
+            (when (grid-row-block? grid (- (grid-height grid) 1))
+                (grid-clear grid)
+                (set! reset #t))
+            #f)
+        (else
+            (block-write block grid (block-colour block)) ; write the block
+            #t)))
+
+(define (block-check block grid)
+    (foldl
+        (lambda (pos found)
+            (if (not found)
+                (not (feq? (grid-bgcol grid) (grid-peek grid (+ (vector-ref (block-pos block) 0) (vector-ref pos 0))
+                            (+ (vector-ref (block-pos block) 1) (vector-ref pos 1)))))
+                #t))
+        #f
+        (block-shape block)))
+
+; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+; try all the rules on this character - 
+; returns #f if none are matched
+(define (lsys-run-rules char rules)
+    (foldl
+        (lambda (rule str)
+            (if str ; if str is not #f
+                str ; then we have already found a rule, return it
+                (if (char=? char (string-ref (car rule) 0)) ; check this rule
+                    (cadr rule) ; return the string
+                    #f))) ; no match
+        #f
+        rules))
+
+; runs the lsystem rules on every character in a string, 
+; returns the new string
+(define (lsys-search-replace str rules pos result)
+    (cond 
+        ((>= pos (string-length str)) result)
+        (else
+            (let ((ret (lsys-run-rules (string-ref str pos) rules)))
+                (if (string? ret)
+                    (lsys-search-replace str rules (+ pos 1) 
+                        (string-append result ret))
+                    (lsys-search-replace str rules (+ pos 1) 
+                        (string-append result (string (string-ref str pos)))))))))
+
+; runs the search-replace multiple (n) times on a string
+(define (ls-generate n str rules)
+    (cond 
+        ((zero? n) str)
+        (else
+            (ls-generate (- n 1) 
+                (lsys-search-replace str rules 0 "") rules))))
+
+; builds objects from a string
+(define (ls-build string angle branch-scale branch-col leaf-col)
+    (with-state
+    (rotate (vector 0 180 0))
+    (hint-depth-sort)
+    (for-each 
+        (lambda (char)
+            (cond 
+                ((char=? #\F char)
+                    (with-state
+                        (translate (vmul (crndvec) 0.01))
+                        (scale (vector 1.2 1 1))
+                        (rotate (vector 0 90 0))         
+                        (colour branch-col)
+                        
+                        (with-primitive (build-ribbon 2)
+                            ;                            (texture (load-texture "../textures/fade4.png"))
+                            ;                                       (hint-unlit)
+                            (pdata-set! "w" 0 0.1)
+                            (pdata-set! "w" 1 0.07)
+                            (pdata-set! "p" 0 (vector 0 0 0.9))
+                            (pdata-set! "p" 1 (vector 0 0 0))))
+                    (translate (vector 1 0 0)))
+                ((char=? #\L char)
+                    (for ((i (in-range 1 2)))
+                        (with-state
+                            (translate (vmul (srndvec) 0.3))
+                            (scale (* (rndf) 0.5))
+                            (colour leaf-col)
+                            ;                    (texture (load-texture "../textures/leaf.png"))
+                            (build-sphere 3 3)))
+                    #;(translate (vector 1 0 0)))
+                ((char=? #\f char)
+                    (translate (vector 1 0 0)))
+                ((char=? #\/ char)
+                    (rotate (vector angle 0 0)))
+                ((char=? #\\ char)
+                    (rotate (vector (- angle) 0 0)))
+                ((char=? #\+ char)
+                    (rotate (vector 0 angle 0)))
+                ((char=? #\- char)
+                    (rotate (vector 0 (- angle) 0)))
+                ((char=? #\^ char)
+                    (rotate (vector 0 0 (- angle))))
+                ((char=? #\& char)
+                    (rotate (vector 0 0 angle)))
+                ((char=? #\| char)
+                    (rotate (vector 0 0 180)))
+                ((char=? #\[ char)
+                        (push)
+                        (scale (vector branch-scale branch-scale branch-scale)))
+                    ((char=? #\] char)
+                    (pop))))
+        (string->list string))))
+
+(define (make-plant p n)
+    (let ((root (build-locator)))
+        (with-state
+            (parent root)
+            (translate p)
+            (scale 10)
+            (rotate (vector 0 90 0))
+            ;        (concat (maim n (vector 0 1 0)))
+            (scale 0.4)
+            (ls-build (ls-generate 1 "F" '(("F" "F[^F][+/&FL]"))) 45 0.77
+                ;(vector 1 0.5 0.2)
+                ;(vector 0.5 1 0.5)
+                (vector 1 (rndf) (* (rndf) 0.4)) 
+                (vector (rndf) 1 (rndf))
+                root
+                ))))
+
+(define (build-tree size)
+    (let ((root (build-locator)))
+        (with-state
+            (parent root)
+            (scale 3)
+            ;(opacity 0.5)
+            (hint-depth-sort)
+            (rotate (vector 0 90 0))
+            (ls-build (ls-generate size "F" '(("F" "F[^F][+/&FL]"))) 45 0.77
+                (vector 1 (rndf) (* (rndf) 0.4)) 
+                (vector (rndf) 1 (rndf))))
+        root))
+
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+(define (particles-init particles)
+    (with-primitive particles
+        (pdata-add "vel" "v")
+        (pdata-map!
+            (lambda (c)
+                (vector 0 (rndf) 0))
+            "c")
+        (pdata-map!
+            (lambda (c)
+                (vector 1 1 0))
+            "s")
+        (pdata-map!
+            (lambda (vel)
+                (vmul (vector (crndf) (crndf) (rndf)) 0.5))
+            "vel")))
+
+
+(define (particles-explode particles)
+    (with-primitive particles
+        (pdata-map!
+            (lambda (p)
+                (vector 0 0 0))
+            "p")))
+
+(define (particles-update particles)
+    (with-primitive particles
+        (pdata-op "+" "p" "vel")))
+
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+(define grass (vector 0.2 0.4 0.2))
+(define sky (vector 0.5 0.6 1))
+
+(clear)
+;(hint-unlit)
+(clear-colour sky)
+(define grid-x 30)
+(define grid-y 20)
+(define g (build-grid grid-x grid-y grass))
+(define b (make-block (vector 2 (- grid-y 2)) 
+        (shape-cells (car shapes)) 
+        (shape-colour (car shapes))))
+(define next-time (flxtime))
+
+(define particles (with-state
+        (hint-none)
+        (hint-points)
+        (hint-anti-alias)
+        (point-width 10)
+        ;    (texture (load-texture "textures/blob.png"))
+        (build-particles 200)))
+(particles-init particles)
+
+(define camera (with-state
+        ;    (hint-origin)
+        (build-locator)))
+(lock-camera camera)
+(set-camera-transform (mrotate (vector -90 0 0)))
+;(camera-lag 0.5)
+
+(light-diffuse 0 (vector 0 0 0))
+(define l (make-light 'point 'free))
+(light-diffuse l (vector 1 1 1))
+(light-position l (vector 10 50 20))
+
+(for ((i (in-range 1 100)))
+    (with-state
+        (rotate (vector 0 0 (random 360)))
+        (translate (vector (+ 20 (random 5)) 0 0))
+        (scale 3)
+        (rotate (vector 0 90 0))
+        (ls-build (ls-generate (+ 1 (random 3)) "F" '(("F" "F[^F][+/&FL]"))) (+ 10 (random 25)) 0.77
+            (vmul (vector 1 (rndf) (* (rndf) 0.4)) 0.4)
+            (vector (* 0.5 (rndf)) 1 (* 0.5 (rndf))))))
+
+(define tree-size 1)
+(define tree (build-tree tree-size))
+
+(with-state
+    (hint-unlit)
+    (colour grass)
+    (translate (vector 0 0 -0.2))
+    (rotate (vector 90 0 0))
+    (scale (vector 30 0.1 30))
+    (build-cylinder 1 30))
+
+(define tick 0.5)
+
+(define (update)
+    (particles-update particles)
+    (block-deal-with-input b g)
+    
+    (with-primitive camera
+        (identity)
+        (rotate (vector 0 0 (* -360 (/ (vx (block-pos b)) grid-x))))
+        (rotate (vector -50 0 0))
+        (translate (vector 0 -20 8)))
+    
+    (when (> (flxtime) next-time)
+        (set! next-time (+ next-time tick))
+        (when (not (block-update b g))
+            (let ((x (random grid-x))
+                    (s (random-shape)))
+                (set! b (make-block (vector x (- grid-y 2)) (shape-cells s) 
+                        (shape-colour s)))))
+        (when reset
+            (set! reset #f)
+            (destroy tree)
+            (set! tree-size 1)
+            (set! tree (build-tree tree-size)))
+        
+        (grid-look-for-rows g
+            (lambda (n)
+                (destroy tree)
+                (set! tree-size (+ tree-size 1))
+                (set! tree (build-tree tree-size))
+                (particles-explode particles)))))
+
+(every-frame (update))