broke apart the source, added jabberer and xmpp

flatgarden/flatgarden.scm

@@ -142,5 +142,4 @@
         (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))))
 
-(start-framedump "wind" "jpg")
 (every-frame (animate trees))

plant-eyes/controller.ss

@@ -0,0 +1,125 @@
+#lang scheme/base
+(require scheme/class fluxus-016/drflux "logic.ss" "view.ss")
+(provide (all-defined-out))
+
+; reads input events and tells the logic side what to do
+
+(define controller%
+  (class object% 
+    (init-field
+     (game-view #f))
+   
+    (field 
+     (fwd (vector 0 0 1))
+     (up (vector 0 1 0))
+     (pos (vector 0 0 0))
+     (mtx (mident))
+     (cam (build-locator))
+     (current-twig #f)
+     (current-twig-growing #f)
+     (current-point 0)
+     (tilt 0)
+     (yaw 0)
+     (player-plant #f))   
+    
+    (define/public (set-player-plant s)
+      (set! player-plant s))
+    
+    (define/public (get-cam-obj)
+      cam)
+    
+    (define/public (set-pos s)
+      (set! pos s))
+    
+    (define/public (set-fwd s)
+      (set! fwd s))
+    
+    (define/public (get-fwd)
+      fwd)
+    
+    (define/public (setup)
+      (lock-camera cam)
+      (camera-lag 0.2)
+      (clip 1 1000)
+      (set-camera-transform (mtranslate (vector 0 0 -4))))
+    
+    (define/public (update)
+      (when (key-pressed-this-frame " ")
+        (cond ((and current-twig (not current-twig-growing))      
+                 (let ((new-twig (send current-twig add-twig current-point 
+                                       (vector 0 1 0) #;(vsub (send current-twig get-point current-point)
+                                             (send current-twig get-point (- current-point 1))))))
+                 (set! current-twig-growing #t)
+                 (set! current-twig new-twig)))
+              (else
+               (set! current-twig (make-object twig-logic%  (vector 0 0 0) 0 player-plant 'root 
+                                    (vmul fwd -1)
+                                    start-twig-width max-twig-points 'extruded))
+        (send player-plant add-twig current-twig)
+        (set! current-twig-growing #t))))
+      
+      (when (or (key-pressed "a") (key-special-pressed 100)) (set! yaw (+ yaw 2)))
+      (when (or (key-pressed "d") (key-special-pressed 102)) (set! yaw (- yaw 2)))
+      (when (or (key-pressed "w") (key-special-pressed 101)) (set! tilt (+ tilt 2)))
+      (when (or (key-pressed "s") (key-special-pressed 103)) (set! tilt (- tilt 2)))      
+      
+      ; clamp tilt to prevent gimbal lock
+      (when (> tilt 88) (set! tilt 88))
+      (when (< tilt -88) (set! tilt -88))
+      
+	  (when (not current-twig-growing)
+      (when (key-pressed-this-frame "q")
+        (cond ((not current-twig)
+               (set! current-twig (send player-plant get-twig-from-dir (vmul fwd -1)))
+               (set! current-point 2))
+              (else
+               (when (< current-point (- (send current-twig get-num-points) 1))
+                 (set! current-point (+ current-point 1))))))
+      
+      (when (key-pressed-this-frame "z")
+        (cond (current-twig
+               (set! current-point (- current-point 1))
+               (when (< current-point 2)
+                 (set! current-twig #f)
+                 (set! pos (vector 0 0 0))
+                 #;(set-camera-transform (mtranslate (vector 0 0 -1))))))))                   
+
+                   ; get camera fwd vector from key-presses                   
+             (set! fwd (vtransform (vector 0 0 1) 
+                                   (mmul 
+                            (mrotate (vector 0 yaw 0))
+                            (mrotate (vector tilt 0 0)))))
+
+      
+      ; if we are on a twig not growing
+      (cond ((and current-twig (not current-twig-growing))
+             (set! pos (send current-twig get-point current-point))
+             #;(when (> current-point 0)
+               (set! fwd (vmix fwd (vnormalise (vsub (send current-twig get-point 
+                                                           (- current-point 1))
+                                           pos)) 0.5))))
+            
+            (else
+             (when current-twig-growing
+               (let ((twig-view (send (send game-view get-plant (send player-plant get-id))
+                                      get-twig (send current-twig get-id))))
+                 (when twig-view
+                   (set! pos (vsub (send twig-view get-end-pos) 
+                                   (vmul (send current-twig get-dir) 1)))))
+               (when (eq? (send current-twig get-num-points) 
+                          (send current-twig get-length))
+                 (set! current-twig-growing #f)
+                 (set! current-point (- (send current-twig get-num-points) 1))))))
+                     
+      
+      (let* ((side (vnormalise (vcross up fwd)))
+             (up (vnormalise (vcross fwd side))))
+
+        (with-primitive cam
+                        (identity)
+                        (concat (vector (vx side) (vy side) (vz side) 0
+                          (vx up) (vy up) (vz up) 0
+                          (vx fwd) (vy fwd) (vz fwd) 0
+                          (vx pos) (vy pos) (vz pos) 1)))))
+    
+    (super-new)))

plant-eyes/jabberer.ss

@@ -0,0 +1,63 @@
+#lang scheme/base
+(require scheme/class fluxus-016/drflux openssl (prefix-in xmpp: "xmpp.ss"))
+(provide (all-defined-out))
+
+; a class which wraps the xmpp in a thread and allows messages to be picked up
+; and sent by the game
+
+(define debug-netloop #f)
+
+(define jabberer%
+    (class object%
+      (init-field
+       (jid "none@nowhere")
+       (pass "xxxx"))
+      
+        (field 
+            (incoming '())
+            (outgoing '())
+            (thr 0)
+            (debug-jab #f))
+        
+        (define/public (get-incoming)
+            incoming)
+        
+        (define/public (clear-incoming)
+            (set! incoming '()))
+        
+        (define/public (msg-waiting?)
+            (not (null? incoming)))
+        
+        (define/public (get-msg)
+            (let ((msg (car incoming)))
+                (set! incoming (cdr incoming))
+                msg))
+        
+        (define/public (send-msg to msg)
+            (set! outgoing (cons (list to msg) outgoing)))
+        
+        (define (message-handler sz)
+            (when debug-jab (printf "rx <---- ~a ~a~n" (xmpp:message-from sz) (xmpp:message-body sz)))
+            (set! incoming (cons (list (xmpp:message-from sz) (xmpp:message-body sz)) incoming)))
+        
+        (define/public (start)
+            (set! thr (thread run)))
+        
+        (define/public (stop)
+            (kill-thread thr))
+        
+        (define (run)
+            (xmpp:with-xmpp-session jid pass
+                (xmpp:set-xmpp-handler 'message message-handler)
+                (let loop () 
+                    (when debug-netloop (printf ".~n"))
+                    (when (not (null? outgoing))                             
+                        (for-each                                
+                            (lambda (msg)                                
+                                (when debug-jab (printf "tx ----> ~a ~a~n" (car msg) (cadr msg)))
+                                (xmpp:send (xmpp:message (car msg) (cadr msg))))
+                            outgoing)
+                        (set! outgoing '()))
+                    (sleep 0.5)
+                    (loop))))
+        (super-new)))

plant-eyes/list-utils.ss

@@ -0,0 +1,20 @@
+#lang scheme/base
+(provide (all-defined-out))
+
+(define (assoc-remove k l)
+  (cond
+    ((null? l) '())
+    ((eq? (car (car l)) k)
+     (assoc-remove k (cdr l)))
+    (else
+     (cons (car l) (assoc-remove k (cdr l))))))
+
+(define (choose l)
+  (list-ref l (random (length l))))
+
+(define (list-contains k l)
+  (cond 
+    ((null? l) #f)
+    ((eq? (car l) k) #t)
+    (else (list-contains k (cdr l)))))
+

plant-eyes/logic.ss

@@ -0,0 +1,499 @@
+#lang scheme
+(require scheme/class fluxus-016/drflux "message.ss" "list-utils.ss")
+(provide (all-defined-out))
+
+(define branch-probability 6) ; as in one in branch-probability chance
+(define branch-width-reduction 0.5)
+(define twig-jitter 0.1)
+(define branch-jitter 0.5)
+(define max-twig-points 30)
+(define start-twig-dist 0.05)
+(define start-twig-width 0.2)
+(define default-max-twigs 10)
+(define default-scale-factor 1.05)
+(define num-pickups 10)
+(define pickup-dist-radius 200)
+(define pickup-size 1)
+(define ornament-grow-probability 4)
+(define curl-amount 40)
+(define start-size 50)
+
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+; the base class logic object - all logic side objects can 
+; send messages to the render side at any time by calling add-message
+; this takes care of the propagation of information. (not just oo fetish, I hope)
+(define game-logic-object%
+  (class object%
+    (field
+     (messages '())
+     (children '()))
+    
+    (define/public (send-message name data)
+      (set! messages (cons (make-object message% name data) messages)))
+        
+    ; convert a list of lists in to just a single list - needed to convert
+    ; the update lists into one big list of messages
+    (define (flatten l)
+      (cond
+        ((null? l) '())
+        ((list? (car l)) (append (flatten (car l)) (flatten (cdr l))))
+        (else (cons (car l) (flatten (cdr l))))))
+
+    (define/pubment (update) ; need to augement this if we have child logic objects, 
+      (let ((m messages))    ; and call update on them too.
+        (set! messages '())        
+         (append
+          m
+          (flatten (inner '() update))))) ; the augmented method gets called here
+    
+    (super-new)))
+
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+; a twig, which can contain other twigs things.
+; (roots and shoots are both twigs)
+(define twig-logic%
+  (class game-logic-object%
+    (init-field
+     (last-point (vector 0 0 0))      
+     (id #f)               ; our id (for matching up with the renderer geometry)
+     (plant #f)            ; the plant we belong to
+     (type 'root)          ; or 'shoot
+     (dir (vector 0 1 0))  ; the general direction we are pointing in
+     (width 0)            ; the width of this root
+     (num-points max-twig-points) ; number of points in this twig
+     (render-type 'extruded) ; the way to tell the view to render this twig
+     (dist start-twig-dist))               ; distance between points          
+    
+    (field
+     (points '())     ; the 3d points for this twig
+     (widths '())
+     (twigs '())      ; children are stored with the point number they are connected to.
+     (ornaments '())  ; the things attached to this twig, an assoc list with point index
+     (branch #f)   ; are we a main branch twig?
+     (w 0)                ; the width of this segment
+     (curl (vmul (crndvec) curl-amount))) ; the angles to turn each point, if curly  
+    
+    (inherit send-message)
+
+    (define/public (set-pos s)
+      (set! last-point s))
+    
+    (define/public (get-id)
+      id)
+    
+    (define/public (set-id! s)
+      (set! id s))
+    
+    (define/public (get-type)
+      type)
+    
+    (define/public (get-dir)
+      dir)
+    
+    (define/public (get-width)
+      width)
+    
+    (define/public (get-num-points)
+      num-points)      
+    
+    (define/public (get-render-type)
+      render-type)
+    
+    (define/public (set-branch! s)
+      (set! branch s))
+    
+    (define/public (get-point point-index)
+      (list-ref points point-index))
+    
+    (define/public (get-length)
+      (length points))
+    
+    (define/public (get-end-pos)
+      (if (not (null? points))
+          (list-ref points (- (get-length) 1))
+          #f))
+    
+    (define/public (scale a)
+      (set! width (* width a))
+      (set! dist (* dist a)))
+    
+    (define/public (grow ndir)
+      (when (< (length points) num-points)
+        (let ((new-point (if (zero? (length points))
+                             ; first point should be at edge of the seed if we are a branch
+                             (if branch (vadd last-point (vmul dir dist)) 
+                                 last-point)
+                             (vadd last-point (vmul dir dist)))))
+          
+          (set! dir ndir)
+          (set! w (* width (- 1 (/ (length points) num-points))))                  
+          
+          (set! last-point new-point)
+          (set! points (append points (list new-point)))
+          (set! widths (append widths (list w)))
+          (send-message 'twig-grow (list 
+                                    (list 'plant-id (send plant get-id))
+                                    (list 'twig-id id)
+                                    (list 'point new-point)
+                                    (list 'width w)))
+        #;(when (and (> (length points) 1) (> num-points 1) 
+                   (zero? (random branch-probability)))
+          (add-twig (- (length points) 1) (vadd dir (vmul (srndvec) branch-jitter))))))
+      (for-each
+       (lambda (twig)
+         (send (cadr twig) grow ndir))
+       twigs))
+    
+    (define/public (add-twig point-index dir)
+      (let ((twig (make-object twig-logic% 
+                    (get-point point-index)
+                      (send plant get-next-twig-id)
+                      plant 
+                      type 
+                      dir
+                      (list-ref widths point-index)
+                      (quotient num-points 2)
+                      render-type
+                      dist)))
+      
+      (send-message 'new-twig (list 
+                               (list 'plant-id (send plant get-id))
+                               (list 'parent-twig-id id)
+                               (list 'point-index point-index)
+                               (list 'twig-id (send twig get-id))
+                               (list 'type (send twig get-type))
+                               (list 'dir (send twig get-dir))
+                               (list 'width (send twig get-width))
+                               (list 'num-points (send twig get-num-points))
+                               (list 'render-type (send twig get-render-type))
+                               ))
+      (set! twigs (cons (list point-index twig) twigs))
+        twig))
+    
+    (define/public (get-twig point-index)
+      (cadr (assq point-index twigs)))
+    
+    (define/public (get-random-twig)
+      (if (or (null? twigs) (zero? (random 10)))
+          this
+          (send (cadr (choose twigs)) get-random-twig)))
+    
+    (define/public (add-ornament point-index ornament)
+      ; todo - check max ornaments
+      (send-message 'new-ornament 
+                     (list 
+                      (list 'plant-id (send plant get-id))
+                      (list 'twig-id id)
+                      (list 'point-index point-index)
+                      (list 'property (send ornament get-property))))
+      (set! ornaments (cons (list point-index ornament) ornaments)))
+    
+    (define/public (get-ornament point-index)
+      (cadr (assq point-index ornaments)))
+    
+    ; adds the ornament if it's close, and checks sub-twigs
+    ; returns true if it's succeded
+    (define/public (check-pickup pickup) 
+      ; check each point in our twig      
+      (let* ((i -1) (found (foldl
+                    (lambda (point found)
+                      (set! i (+ i 1))
+                      ; if we havent found anything yet and it's intersecting
+                      (cond ((and (not found) (< (vdist point (send pickup get-pos)) 
+                                                 (+ width (send pickup get-size))))
+                             (send plant add-property (send pickup get-type))
+                             (send pickup pick-up) ; this will remove the pickup for us
+                             (send-message 'pick-up-pickup 
+                                           (list 
+                                            (list 'pickup-id (send pickup get-id))))
+                             #t)
+                            (else #f)))
+                    #f
+                    points)))
+        ; now check each sub-twig
+        (if (not found)
+          (foldl
+           (lambda (twig found) 
+             (if (not found) 
+                 (send (cadr twig) check-pickup pickup)
+                 #f))
+           #f
+           twigs)
+          found)))
+      
+    (define/augment (update)
+      (append
+       (map
+        (lambda (ornament)
+          (send (cadr ornament) update))
+        ornaments)
+       (map
+        (lambda (twig)
+          (send (cadr twig) update))
+        twigs)))
+        
+    (super-new)))
+
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+; abilities live on twigs, and can do things. 
+; this is the base class for all abilities.
+(define ornament-logic%
+  (class game-logic-object%
+    (init-field
+     (id -1)
+     (property 'none)
+     (plant #f)        ; the plant we belong to
+     (twig #f)         ; the twig we are on
+     (point-index -1)) ; the index to the point on our twig
+  
+    (field
+     (pos (send twig get-point point-index))) ; figure out the position here
+    
+    (define/public (get-property)
+      property)
+    
+    (define/public (get-pos)
+      pos)
+    
+    (super-new)))
+
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+; pickups map to abilities, and live out in space
+; this is the base class for all pickups.
+(define pickup-logic%
+  (class game-logic-object%
+    (init-field
+     (id -1)
+     (type 'none)
+     (pos (vector 0 0 0)))
+    
+    (field 
+     (size pickup-size)
+     (picked-up #f))
+    
+    (define/public (picked-up?)
+      picked-up)
+    
+    (define/public (pick-up)
+      (set! picked-up #t))
+    
+    (define/public (get-id)
+      id)
+    
+    (define/public (get-type)
+      type)
+    
+    (define/public (get-pos)
+      pos)
+    
+    (define/public (get-size)
+      size)
+    
+    (super-new)))
+
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+(define plant-logic%
+  (class game-logic-object%
+    (init-field
+     (id #f)
+     (pos (vector 0 0 0)))
+    
+    (field
+     (twigs '())     ; a assoc list map of ages to twigs
+     (properties '()) ; a list of symbols - properties come from pickups
+     (ornaments '()) ; map of ids to ornaments on the plant
+     (size start-size)         ; the age of this plant
+     (max-twigs default-max-twigs) ; the maximum twigs allowed at any time - oldest removed first
+     (next-twig-id 0)
+     (next-ornament-id 0)
+     (grow-amount default-scale-factor))
+    
+    (inherit send-message)
+    
+    (define/public (get-id)
+      id)
+
+    (define/public (get-pos)
+      pos)
+    
+    (define/public (get-size)
+      size)
+
+    (define/public (grow dir)      
+        (for-each
+         (lambda (twig)
+           (send twig grow dir))
+         twigs))
+    
+    (define/public (add-property name)
+      (set! properties (cons name properties)))
+    
+    ; we need to maintain our list of twig ids here, for this plant
+    (define/public (get-next-twig-id)
+      (let ((id next-twig-id))
+        (set! next-twig-id (+ next-twig-id 1))
+        next-twig-id))
+
+    ; we need to maintain our list of ornament ids here, for this plant
+    (define/public (get-next-ornament-id)
+      (let ((id next-ornament-id))
+        (set! next-ornament-id (+ next-ornament-id 1))
+        next-ornament-id))
+    
+    (define/public (check-pickup pickup) 
+      (foldl
+       (lambda (twig found)
+         (if (not found)
+             (send twig check-pickup pickup)
+             #f))
+       #f
+       twigs))
+    
+    (define/public (destroy-twig twig)
+      (send-message 'destroy-branch-twig (list
+                                   (list 'plant-id id)
+                                   (list 'twig-id (send twig get-id))
+                                   )))
+
+    ; a util to keep a fixed size list of twigs, calling destroy twig when needed.
+    (define (cons-twig thing in count out)
+      (cond 
+        ((null? in) 
+         (cons thing out))
+        ((zero? count)
+         (destroy-twig (car in))
+         (cons thing out))
+        (else (cons-twig thing (cdr in) (- count 1) (append out (list (car in)))))))
+    
+    (define/public (add-twig twig)
+      (send twig set-id! (get-next-twig-id))
+      (set! size (* size grow-amount))
+      (send twig scale size)  
+      (send twig set-branch! #t)
+      (send twig set-pos pos)
+
+      (send-message 'grow-seed (list 
+                                (list 'plant-id id)
+                                (list 'amount grow-amount)))
+      (send-message 'new-branch-twig (list 
+                               (list 'plant-id id)
+                               (list 'twig-id (send twig get-id))
+                               (list 'type (send twig get-type))
+                               (list 'dir (send twig get-dir))
+                               (list 'width (send twig get-width))
+                               (list 'num-points (send twig get-num-points))             
+                               (list 'render-type (send twig get-render-type))
+                               ))
+      
+      (set! twigs (cons-twig twig twigs max-twigs '())))
+
+    
+    (define/public (get-random-twig)
+      (if (not (null? twigs))
+          (send (choose twigs) get-random-twig)
+          #f))
+    
+    (define/public (get-twig-from-dir dir)
+      (let ((dir (vnormalise dir)))
+      (cadr (foldl
+             (lambda (twig l)
+               (let ((d (vdot (vnormalise (send twig get-dir)) dir)))
+                 (if (> d (car l))
+                     (list d twig)
+                     l)))
+             (list -99 #f)
+             twigs))))
+      
+    
+    (define/augment (update)      
+      ; grow a new ornament?
+      (when (and (not (null? properties)) (zero? (random ornament-grow-probability)))
+        (let ((twig (get-random-twig)))
+          (when twig
+            (let
+                ((property (choose properties))
+                 (point-index (random (send twig get-length))))
+         
+              (when (not (eq? property 'curly))
+                (send twig add-ornament point-index
+                                   (cond 
+                                     ((or 
+                                       (eq? property 'leaf)
+                                       (eq? property 'wiggle))
+                                     (make-object ornament-logic% 
+                                        (get-next-ornament-id) 
+                                        property
+                                        this
+                                        twig
+                                        point-index))
+                                     (else
+                                      (error "property not understood " property)))))))))
+       (map
+        (lambda (twig)
+          (send twig update))
+        twigs))
+    
+    (super-new)))
+
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+(define game-logic%
+  (class game-logic-object%
+    (field
+     (plants '())
+     (pickups '()))
+   
+    (inherit send-message)
+    
+    (define/public (setup)
+      (for ((i (in-range 0 num-pickups)))
+           (add-pickup (make-object pickup-logic% i (choose (list 'leaf 'curly 'wiggle))
+                                     (vmul (srndvec) pickup-dist-radius)))))
+    
+    (define/public (add-player plant)
+      (send-message 'player-plant (list
+                                (list 'plant-id (send plant get-id))
+                                (list 'pos (send plant get-pos))))
+      (set! plants (cons plant plants)))
+    
+    (define/public (add-plant plant)
+      (send-message 'new-plant (list
+                                (list 'plant-id (send plant get-id))
+                                (list 'pos (send plant get-pos))
+                                (list 'size (send plant get-size))))
+      (set! plants (cons plant plants)))
+    
+    (define/public (add-pickup pickup)
+                            (send-message 'new-pickup
+                                      (list
+                                       (list 'pickup-id (send pickup get-id))
+                                       (list 'type (send pickup get-type))
+                                       (list 'pos (send pickup get-pos))))
+      (set! pickups (cons pickup pickups)))
+    
+    
+    ; todo - distribute the checking of stuff like
+    ; this to a random selection of pickups/plants
+    ; to distribute the cpu load
+    (define/augment (update)           
+      (for-each
+       (lambda (pickup)
+         (for-each 
+          (lambda (plant)
+            (send plant check-pickup pickup))
+          plants))
+       pickups)      
+      
+      ; remove the pickups that have been 'picked up'
+      (set! pickups (filter 
+                     (lambda (pickup)
+                       (not (send pickup picked-up?)))
+                     pickups))
+      
+       (map
+        (lambda (plant)
+          (send plant update))
+        plants))
+    
+    (super-new)))

plant-eyes/message.ss

@@ -0,0 +1,24 @@
+#lang scheme/base
+(require scheme/class)
+(provide (all-defined-out))
+
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+; a message for sending betwixt logic and view side
+(define message%
+  (class object%
+    (init-field
+     (name 'none) ; a symbol denoting the type of the message 
+     (data '()))  ; should be an assoc list map of name to values, eg:
+                  ; '((name "archibold") (age 53))
+                  ; shouldn't put logic objects in here - 'raw' data only
+    
+    (define/public (get-name)
+      name)
+    
+    (define/public (get-data arg-name)
+      (cadr (assoc arg-name data)))
+    
+    (define/public (print)
+      (printf "msg: ~a ~a~n" name data))
+    
+    (super-new)))

plant-eyes/ornament-view.ss

@@ -0,0 +1,41 @@
+#lang scheme
+#lang scheme/base
+
+(require scheme/class fluxus-016/drflux "common.ss" "message.ss" "list-utils.ss")
+(provide (all-defined-out))
+
+(define ornament-view%
+  (class object%
+    (init-field
+     (pos (vector 0 0 0))
+     (property 'none)
+     (time 0))
+    
+    (field
+     (rot (vmul (rndvec) 360))
+     (root (with-state
+            (translate pos)
+            (rotate rot)
+            (scale 0.01)            
+            (cond 
+              ((eq? property 'wiggle) 
+;               (opacity 1)
+               (hint-depth-sort)
+               (colour (vector 0.5 0.0 0.0))
+               (load-primitive "meshes/wiggle.obj"))
+              ((eq? property 'leaf) 
+               (colour (vector 0.8 1 0.6))
+               (texture (load-texture "textures/leaf2.png"))
+               (load-primitive "meshes/leaf.obj"))
+              (else (error ""))))))
+    
+    (define/public (update t d)
+      (when (< time 1)
+        (with-primitive root
+                        (identity)
+                        (translate pos)
+                        (rotate rot)
+                        (scale (* 0.2 time)))
+        (set! time (+ time (* 0.1 d)))))
+    
+    (super-new)))

plant-eyes/pickup-view.ss

@@ -0,0 +1,49 @@
+#lang scheme/base
+(require scheme/class fluxus-016/drflux "common.ss" "message.ss" "list-utils.ss")
+(provide (all-defined-out))
+
+(define pickup-view%
+  (class object%
+    (init-field
+     (id -1)
+     (type 'none)
+     (pos (vector 0 0 0)))
+    
+    (field
+     (rot (vmul (rndvec) 360))
+     (root (with-state
+            (translate pos)
+            (rotate rot)
+            (colour (pickup-colour))
+            (scale 0.3)
+            (texture
+             (cond 
+              ((eq? type 'wiggle) (load-texture "textures/wiggle.png"))
+              ((eq? type 'leaf) (load-texture "textures/leaf.png"))
+              ((eq? type 'curly) (load-texture "textures/curl.png"))))
+            (load-primitive "meshes/pickup.obj")))
+     (from pos)
+     (destination (vector 0 0 0))
+     (speed 0.05)
+     (t -1))
+    
+    (define/public (pick-up)
+      (destroy root))
+    
+    (define/public (move-to s)
+      (set! t 0)
+      (set! from pos)
+      (set! destination s))
+    
+    (define/public (update t d)
+      (with-primitive root
+                      (rotate (vector (* d 10) 0 0)))
+      #;(when (and (>= t 0) (< t 1))
+        (set! pos (vadd pos (vmul (vsub destination from) speed)))
+        (with-primitive root
+                        (identity)
+                        (translate pos)
+                        (rotate rot))
+        (set! t (+ t speed))))
+    
+    (super-new)))

plant-eyes/view.ss

@@ -0,0 +1,649 @@
+#lang scheme/base
+(require scheme/class fluxus-016/drflux "message.ss" "list-utils.ss")
+(provide (all-defined-out))
+
+; the fluxus code to make things look the way they do
+
+(define debug-messages #f) ; prints out all the messages sent to the renderer
+(define audio-on #f)
+
+(define (ornament-colour) (vector 0.5 1 0.4))
+(define (pickup-colour) (vector 1 1 1))
+(define (earth-colour) (vector 0.2 0.1 0))
+
+(define wire-mode #f)
+(define fog-col (earth-colour))
+(define fog-strength 0.001)
+(define max-ornaments 2) ; per twig
+(define default-grow-speed 2)
+
+(when audio-on (oa-start)) ;; start openAL audio
+
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+(define ornament-view%
+  (class object%
+    (init-field
+     (pos (vector 0 0 0))
+     (property 'none)
+     (time 0))
+    
+    (field
+     (rot (vmul (rndvec) 360))
+     (root (with-state
+            (translate pos)
+            (rotate rot)
+            (scale 0.01)            
+            (cond 
+              ((eq? property 'wiggle) 
+;               (opacity 1)
+               (hint-depth-sort)
+               (colour (vector 0.5 0.0 0.0))
+               (load-primitive "meshes/wiggle.obj"))
+              ((eq? property 'leaf) 
+               (colour (vector 0.8 1 0.6))
+               (texture (load-texture "textures/leaf2.png"))
+               (load-primitive "meshes/leaf.obj"))
+              (else (error ""))))))
+    
+    (define/public (update t d)
+      (when (< time 1)
+        (with-primitive root
+                        (identity)
+                        (translate pos)
+                        (rotate rot)
+                        (scale (* 0.2 time)))
+        (set! time (+ time (* 0.1 d)))))
+    
+    (super-new)))
+
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+(define pickup-view%
+  (class object%
+    (init-field
+     (id -1)
+     (type 'none)
+     (pos (vector 0 0 0)))
+    
+    (field
+     (rot (vmul (rndvec) 360))
+     (root (with-state
+            (translate pos)
+            (rotate rot)
+            (colour (pickup-colour))
+            (scale 0.3)
+            (texture
+             (cond 
+              ((eq? type 'wiggle) (load-texture "textures/wiggle.png"))
+              ((eq? type 'leaf) (load-texture "textures/leaf.png"))
+              ((eq? type 'curly) (load-texture "textures/curl.png"))))
+            (load-primitive "meshes/pickup.obj")))
+     (from pos)
+     (destination (vector 0 0 0))
+     (speed 0.05)
+     (t -1))
+    
+    (define/public (pick-up)
+      (destroy root))
+    
+    (define/public (move-to s)
+      (set! t 0)
+      (set! from pos)
+      (set! destination s))
+    
+    (define/public (update t d)
+      (with-primitive root
+                      (rotate (vector (* d 10) 0 0)))
+      #;(when (and (>= t 0) (< t 1))
+        (set! pos (vadd pos (vmul (vsub destination from) speed)))
+        (with-primitive root
+                        (identity)
+                        (translate pos)
+                        (rotate rot))
+        (set! t (+ t speed))))
+    
+    (super-new)))
+
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+(define twig-view%
+    (class object%
+      (init-field
+       (id 0)
+       (pos (vector 0 0 0))
+       (type 'none)
+       (dir (vector 0 1 0))
+       (radius 1)
+       (num-points 0)) 
+      
+      (field
+       (index 0)
+       (parent-twig-id -1)
+       (child-twig-ids '())
+       (ornaments '()))
+      
+      (define/public (get-id)
+        id)
+      
+      (define/public (get-dir)
+        dir)
+      
+      (define/public (build)
+        0)
+
+      (define/public (set-pos! s)
+        (set! pos s))
+      
+      (define/public (get-child-twig-ids)
+        child-twig-ids)
+      
+      (define/public (get-root)
+        (error "need to overide this"))
+      
+      (define/public (destroy-twig)
+        (destroy (get-root)))
+
+      (define/public (set-parent-twig-id s)
+        (set! parent-twig-id s))
+      
+      (define/public (get-point point-index)
+        (error "need to overide this"))
+      
+      (define/public (add-child-twig-id twig-id)
+        (set! child-twig-ids (cons twig-id child-twig-ids)))
+      
+      (define/pubment (grow point width)
+    (when audio-on (let ((growing-noise (oa-load-sample (fullpath "snd/event01.wav")))) 
+      (oa-play growing-noise (vector 0 0 0) (rndf) 0.3)))
+        (inner (void) grow point width))
+
+      (define/public (add-ornament point-index property)
+        (when (< (length ornaments) max-ornaments)
+          (with-state
+           (parent (get-root))
+           ; todo - different ornament-view objects per property needed?
+           ; todo - delete existing ornaments here
+           (set! ornaments (cons (list point-index 
+                                       (make-object ornament-view% 
+                                         (get-point point-index)
+                                         property))
+                                 ornaments)))))
+      
+      (define/pubment (update t d)        
+        (for-each
+         (lambda (ornament)
+           (send (cadr ornament) update t d))
+         ornaments)
+                
+        (inner (void) update t d))
+      
+      (super-new)))
+
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+(define ribbon-twig-view%
+    (class twig-view%
+      
+      (inherit-field pos radius num-points index)
+      
+      (field
+       (root 0))
+      
+      (define/override (build)
+        (set! root (let ((p (with-state
+                       (translate pos)
+                       (colour (vector 0.8 1 0.6))
+                       (texture (load-texture "textures/root.png")) 
+                       (build-ribbon num-points))))
+               (with-primitive p
+                               (pdata-map! 
+                                (lambda (w)
+                                  0)
+                                "w")
+                               (pdata-set! "w" 0 radius))
+               p)))
+      
+      
+      (define/override (get-root)
+        root)
+
+      (define/override (get-point point-index)
+        (with-primitive root
+                        (pdata-ref "p" point-index)))
+     
+      (define/augment (grow point width)
+        (with-primitive root
+                        (pdata-index-map! ; set all the remaining points to the end
+                         (lambda (i p)    ; in order to hide them
+                           (if (< i index)
+                               p
+                               point))
+                         "p")
+                        (pdata-index-map! ; do a similar thing with the width
+                         (lambda (i w)    
+                           (if (< i (+ index 1))
+                               w
+                               width))
+                         "w"))
+        (set! index (+ index 1)))
+
+      (define/augment (update t d)
+        0)
+
+      (super-new)))
+
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+(define extruded-twig-view%
+    (class twig-view%
+      
+      (inherit-field index radius num-points pos dir)
+      
+      (field
+       (profile '())
+       (path '())
+       (root 0)
+       (grow-speed default-grow-speed)
+       (anim-t 0)
+       (widths '()))
+      
+      (define/override (build)
+       (set! profile (build-circle-profile 12 1))
+       (set! path (build-list num-points (lambda (_) (vector 0 0 0))))
+       (set! widths (build-list num-points (lambda (_) 1)))
+       (set! root (let ((p (with-state
+                            (backfacecull 0)
+                            (when wire-mode 
+                              (hint-none)
+                              (hint-wire))
+                       (texture (load-texture "textures/root2.png"))
+                       ;(opacity 0.6)
+                       (colour (vmul (vector 0.8 1 0.6) 2))
+                       #;(colour (vector 1 1 1))
+                       #;(texture (load-texture "textures/root.png")) 
+                       (build-partial-extrusion profile path 3))))
+               p)))
+      
+      (define/override (get-root)
+        root)
+      
+      (define/override (get-point point-index)
+        (list-ref path point-index))
+            
+      (define (list-set l c s)
+        (cond ((null? l) '())
+              ((zero? c) (cons s (list-set (cdr l) (- c 1) s)))
+              (else (cons (car l) (list-set (cdr l) (- c 1) s)))))
+      
+      (define/augment (grow point width)
+        (set! path (list-set path index point))
+        (set! widths (list-set widths index width))
+        (set! anim-t 0)
+        (set! index (+ index 1)))
+
+      (define/augment (update t d)                   
+        (when (< anim-t 1)
+          (with-primitive root
+            (partial-extrude (+ (- index 2) anim-t) 
+                             profile path widths (vector 1 0 0) 0.05)))
+        (set! anim-t (+ anim-t (* d grow-speed))))
+      
+      (define/public (get-end-pos)
+        (with-primitive root (pdata-ref "p" (- (* index (length profile)) 1))))
+
+      (super-new)))
+
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+(define plant-view%
+    (class object%
+      
+      (init-field
+       (id "none")
+       (pos (vector 0 0 0))
+       (size 0))
+       
+       (field 
+        (twigs '()) ; a assoc list map between ids and twigs stored flat here,       
+                    ; for fast access, but prims heirachically in the scenegraph
+        (root (with-state 
+               (translate pos)
+               (build-locator)))
+        (seed (with-state
+               (parent root)
+               (texture (load-texture "textures/root2.png"))
+               (backfacecull 0)
+               (opacity 0.6)
+               (colour (vector 0.8 1 0.6))
+               (hint-depth-sort)
+               (scale (* 0.12 size))
+                            (when wire-mode 
+                              (hint-none)
+                              (hint-wire))
+               ;(hint-unlit)
+               (load-primitive "meshes/seed.obj"))))
+        
+      (define/public (get-id)
+        id)
+      
+      (define/public (get-twig twig-id)
+        (let ((l (assq twig-id twigs)))
+          (if l              
+              (cadr (assq twig-id twigs))
+              #f)))
+
+      (define/public (add-branch-twig twig)     
+        ; attach to seed
+        (with-primitive (send twig get-root)
+                        (parent root))
+        (send twig build)
+        (set! twigs (cons (list (send twig get-id) twig) twigs)))
+      
+      (define/public (destroy-branch-twig twig-id)
+        (for-each
+         (lambda (twig-id)
+           (destroy-branch-twig twig-id))
+         (send (get-twig twig-id) get-child-twig-ids))
+        (send (get-twig twig-id) destroy-twig)
+        (set! twigs (assoc-remove twig-id twigs)))
+      
+      (define/public (add-twig parent-twig-id point-index twig)     
+        (let ((ptwig (get-twig parent-twig-id)))
+          ; attach to parent twig              
+          (send twig set-pos! (send ptwig get-point point-index))
+          (send twig build)
+          (with-primitive (send twig get-root)
+                          (parent (send ptwig get-root)))
+   
+          
+          ; tell the twigs about this relationship (might turn out to be overkill)
+          (send ptwig add-child-twig-id (send twig get-id))
+          (send twig set-parent-twig-id parent-twig-id)
+          
+          (set! twigs (cons (list (send twig get-id) twig) twigs))))      
+      
+      (define/public (grow-twig twig-id point width)
+        (send (get-twig twig-id) grow point width)) 
+      
+      (define/public (grow-seed amount)
+        (with-primitive seed (scale amount)))
+      
+      (define/public (add-ornament twig-id point-index property)
+        (send (get-twig twig-id) add-ornament point-index property))
+        
+      (define/public (update t d)
+        
+        (with-primitive seed
+                        (scale (+ 1 (* 0.001 (sin (* 2 t))))))                       
+        
+        (for-each 
+         (lambda (twig)
+           (send (cadr twig) update t d))
+         twigs))
+        
+      (super-new)))
+
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+(define (build-env-box top bottom left right front back lower)    
+  (let ((p (build-locator)))
+    (with-state
+     (parent p)
+  (hint-unlit)  
+  
+  (let ((t (with-state
+        (texture (load-texture top))
+        (translate (vector 0 0.5 0))
+        (rotate (vector 90 0 0))
+        (build-plane))))
+      (when lower (with-primitive t
+                      (pdata-map!
+                       (lambda (t)
+                         (vmul t 10))
+                       "t"))))
+    
+    (with-state
+        (texture (load-texture left))
+        (translate (vector 0 0 -0.5))
+        (rotate (vector 0 0 0))
+        (build-plane))
+    
+    (with-state
+        (texture (load-texture back))
+        (translate (vector 0.5 0 0))
+        (rotate (vector 0 90 0))
+        (build-plane))
+    
+    (with-state
+        (texture (load-texture right))
+        (translate (vector 0 0 0.5))
+        (rotate (vector 0 0 0))
+        (build-plane))
+    
+    (with-state
+        (texture (load-texture front))
+        (translate (vector -0.5 0 0))
+        (rotate (vector 0 90 0))
+        (build-plane))
+    
+    (when lower
+      (with-state
+        (texture (load-texture bottom))
+        (translate (vector 0 -0.5 0))
+        (rotate (vector 90 0 0))        
+        (build-plane)))
+                         
+    p)))
+
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+(define game-view%
+  (class object%
+    
+    (field
+     (plants '()) ; map of ids -> plants     
+     (pickups '()) ; map of ids -> pickups
+     (camera-dist 1)
+     (env-root (with-state (scale 1000) (build-locator)))
+     (root-camera-t 0)
+     #;(upper-env (with-state
+                 (parent env-root)
+                 (hint-depth-sort)
+                 (colour 2)
+                 (translate (vector 0 0.28 0))
+                 (build-env-box "textures/top.png" "textures/bottom-trans.png" 
+                                "textures/left.png" "textures/right.png"
+                                "textures/front.png" "textures/back.png")))
+    #;(lower-env (with-state
+                (parent env-root)
+                 (hint-depth-sort)
+                 (translate (vector 0 -0.22001 0))
+                 (build-env-box "textures/bottom-trans.png" "textures/bottom.png" 
+                                "textures/sleft.png" "textures/sright.png"
+                                "textures/sfront.png" "textures/sback.png")))
+    (upper-env (with-state
+                 (parent env-root)
+                 ;(hint-depth-sort)
+                 (hint-unlit)
+                 (translate (vector 0 0.28 0))
+                 (build-env-box "textures/sky-top.png" "textures/floor.png" 
+                                "textures/sky-side.png" "textures/sky-side.png"
+                                "textures/sky-side.png" "textures/sky-side.png" #f)))
+    (lower-env (with-state
+                (parent env-root)
+                 ;(hint-depth-sort)
+                 (hint-unlit)
+                 (colour (earth-colour))
+                 (translate (vector 0 -0.22001 0))
+                 (build-env-box "textures/floor.png" "textures/earth-bottom.png" 
+                                "textures/earth-side.png" "textures/earth-side.png"
+                                "textures/earth-side.png" "textures/earth-side.png" #t)))
+    (nutrients (let ((p (with-state
+                            (hint-depth-sort)
+                            (texture (load-texture "textures/particle.png"))
+                            (build-particles 5000))))
+                        (with-primitive p
+                            (pdata-map! 
+                                (lambda (p)
+                                    (vmul (vadd (crndvec) (vector 0 -1 0)) 900))
+                                "p")
+                            (pdata-map! 
+                                (lambda (s)
+                                    (vector 1 1 1))
+                                "s"))
+                        p)))
+    
+    (define/public (setup)      
+      (let ((l (make-light 'point 'free)))
+      (light-diffuse 0 (vector 0.5 0.5 0.5))
+      (light-diffuse l (vector 1 1 1))
+      (light-position l (vector 10 50 -4)))
+
+      (clear-colour fog-col)
+      (clip 0.5 10000)
+      (fog fog-col fog-strength 1 100))
+    
+    (define/public (add-plant plant)
+      (set! plants (cons (list (send plant get-id) plant) plants)))
+    
+    (define/public (get-plant plant-id)
+      (cadr (assq plant-id plants)))
+    
+    (define/public (add-branch-twig plant-id twig)
+      (send (get-plant plant-id) add-branch-twig twig))
+    
+    (define/public (destroy-branch-twig plant-id twig-id)
+      (send (get-plant plant-id) destroy-branch-twig twig-id))
+    
+    (define/public (add-twig plant-id parent-twig-id point-index twig)
+      (send (get-plant plant-id) add-twig parent-twig-id point-index twig))
+    
+    (define/public (grow-seed plant-id amount)    
+      (send (get-plant plant-id) grow-seed amount))
+    
+    (define/public (get-pickup pickup-id)
+      (cadr (assq pickup-id pickups)))
+    
+    (define/public (add-pickup pickup-id type pos)
+      (set! pickups (cons (list pickup-id (make-object pickup-view% pickup-id type pos)) pickups)))
+    
+    (define/public (pick-up-pickup pickup-id)
+      (send (get-pickup pickup-id) pick-up)
+      (set! pickups (assoc-remove pickup-id pickups)))
+    
+    (define/public (add-ornament plant-id twig-id point-index property)
+      (send (get-plant plant-id) add-ornament twig-id point-index property))
+                                 
+    (define/public (update t d messages)      
+                        
+      (for-each 
+       (lambda (plant)
+         (send (cadr plant) update t d))
+       plants)
+
+      (for-each 
+       (lambda (pickup)
+         (send (cadr pickup) update t d))
+       pickups)
+      
+      (when debug-messages
+        (for-each
+         (lambda (msg)
+           (send msg print))
+         messages))      
+      (for-each
+       (lambda (msg)
+         (cond
+           ((eq? (send msg get-name) 'player-plant) ; not really any difference now
+            (add-plant (make-object plant-view% 
+                         (send msg get-data 'plant-id) 
+                         (send msg get-data 'pos)
+                         (send msg get-data 'size))))
+                      
+           ((eq? (send msg get-name) 'new-plant)
+            (add-plant (make-object plant-view% 
+                         (send msg get-data 'plant-id) 
+                         (send msg get-data 'pos))))    
+           
+           ((eq? (send msg get-name) 'grow-seed)
+            (grow-seed (send msg get-data 'plant-id) 
+                       (send msg get-data 'amount)))
+           
+           ((eq? (send msg get-name) 'destroy-branch-twig)
+            (destroy-branch-twig (send msg get-data 'plant-id) (send msg get-data 'twig-id)))
+           
+           ((eq? (send msg get-name) 'new-branch-twig)
+            (add-branch-twig (send msg get-data 'plant-id) 
+                             (cond 
+                               ((eq? (send msg get-data 'render-type) 'ribbon)
+                                (make-object ribbon-twig-view%                               
+                                  (send msg get-data 'twig-id)
+                                  (vector 0 0 0)
+                                  (send msg get-data 'type)                               
+                                  (send msg get-data 'dir)
+                                  (send msg get-data 'width)
+                                  (send msg get-data 'num-points)))
+
+                             ((eq? (send msg get-data 'render-type) 'extruded)
+                              (make-object extruded-twig-view%                               
+                                (send msg get-data 'twig-id)
+                                (vector 0 0 0)
+                                (send msg get-data 'type)                               
+                                (send msg get-data 'dir)
+                                (send msg get-data 'width)
+                                (send msg get-data 'num-points))))))
+           
+           ((eq? (send msg get-name) 'new-twig)
+            (add-twig (send msg get-data 'plant-id)
+                      (send msg get-data 'parent-twig-id)
+                      (send msg get-data 'point-index)
+                      (cond                         
+                        ((eq? (send msg get-data 'render-type) 'ribbon)
+                         (make-object ribbon-twig-view%                               
+                           (send msg get-data 'twig-id)
+                           (vector 0 0 0) ; will be filled in by add-twig
+                           (send msg get-data 'type)                               
+                           (send msg get-data 'dir)
+                           (send msg get-data 'width)
+                           (send msg get-data 'num-points)))
+                        
+                        ((eq? (send msg get-data 'render-type) 'extruded)
+                         (make-object extruded-twig-view%                               
+                           (send msg get-data 'twig-id)
+                           (vector 0 0 0) ; will be filled in by add-twig
+                           (send msg get-data 'type)                               
+                           (send msg get-data 'dir)
+                           (send msg get-data 'width)
+                           (send msg get-data 'num-points))))))
+           
+           ((eq? (send msg get-name) 'twig-grow)
+            (send (get-plant (send msg get-data 'plant-id)) grow-twig
+                  (send msg get-data 'twig-id)
+                  (send msg get-data 'point)
+                  (send msg get-data 'width)))
+           
+           ((eq? (send msg get-name) 'new-pickup)
+            (add-pickup 
+             (send msg get-data 'pickup-id) 
+             (send msg get-data 'type) 
+             (send msg get-data 'pos)))
+           
+           ((eq? (send msg get-name) 'pick-up-pickup)
+            (pick-up-pickup 
+             (send msg get-data 'pickup-id)))
+
+           ((eq? (send msg get-name) 'new-ornament)
+            (add-ornament 
+             (send msg get-data 'plant-id)
+             (send msg get-data 'twig-id)
+             (send msg get-data 'point-index)
+             (send msg get-data 'property)))            
+                      
+           ))
+       messages))
+    
+    
+
+
+    (super-new)))

plant-eyes/xmpp.ss

@@ -0,0 +1,421 @@
+;;; A basic XMPP library which should conform to RFCs 3920 and 3921
+;;;
+;;; Copyright (C) 2009 FoAM vzw.
+;;;
+;;; This package is free software: you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public
+;;; License as published by the Free Software Foundation, either
+;;; version 3 of the License, or (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;; Lesser General Public License for more details.
+;;;
+;;; You can find a copy of the GNU Lesser General Public License at
+;;; http://www.gnu.org/licenses/lgpl-3.0.html.
+;;;
+;;; Authors
+;;;
+;;; nik gaffney <nik@fo.am>
+;;;
+;;; Requirements
+;;;
+;;; PLT for now. TLS requires a version of PLT > 4.1.5.3
+;;;
+;;; Commentary
+;;;
+;;; Still a long way from implementing even a minimal subset of XMPP
+;;;
+;;; features implemented
+;;; - plaintext sessions on port 5222
+;;; - "old sytle" ssl sessions on port 5223 (default)
+;;; - authenticate using an existing account
+;;; - send messages (rfc 3921 sec.4)
+;;; - send presence (rfc 3921 sec.5)
+;;; - parse (some) xml reponses from server
+;;; - handlers for responses
+;;; - basic roster handling (rfc 3921 sec.7)
+;;;
+;;; features to implement
+;;; - account creation
+;;; - managing subscriptions & rosters (rfc 3921 sec.6 & 8)
+;;; - error handling for rosters (rfc 3921 sec.7)
+;;; - plaintext/tls/sasl negotiation (rfc 3920 sec.5 & 6)
+;;; - encrypted connections using tls on port 5222
+;;; - correct namespaces in sxml
+;;; - message types
+;;; - maintain session ids
+;;; - maintain threads
+;;; - error handling
+;;; - events
+;;; - [...]
+;;; - rfc 3920
+;;; - rfc 3921
+;;;
+;;; bugs and/or improvements
+;;; - start & stop functions for multiple sessions
+;;; - pubsub (XEP-0060) & group chats (XEP-0045)
+;;; - 'send' using call/cc & parameterize'd i/o ports
+;;; - coroutines for sasl negotiation
+;;; - read-async & repsonse-handler
+;;; - ssax:xml->sxml or lazy:xml->sxml
+;;; - default handlers
+;;; - syntax for defining sxpath based handlers
+;;; - improve parsing
+;;; - chatbot exmples
+;;;
+ 
+(module xmpp scheme
+  
+  (require (planet lizorkin/sxml:2:1/sxml)) ;; encoding xml
+  (require (planet lizorkin/ssax:2:0/ssax)) ;; decoding xml
+  (require mzlib/os) ;; hostname
+  (require scheme/tcp) ;; networking
+  (require openssl) ;; ssl/tls
+  (require srfi/13) ;; jid decoding
+  
+  (provide (all-defined-out))
+  
+  ;;;; ; ;; ;
+  ;;
+  ;; debugging
+  ;;
+  ;;;; ; ;
+  
+  (define debug? #t)
+  
+  (define debugf
+    (case-lambda
+      ((str) (when debug? (printf str)))
+      ((str . dir) (when debug? (apply printf (cons str dir))))))
+  
+  ;;;;;;;;;;; ; ;;;; ; ;;; ; ; ;; ;
+  ;;
+  ;; networking
+  ;;
+  ;;;;;; ;; ;; ; ; ; ;
+  
+  (define port 5222)
+  (define ssl-port 5223)
+  
+  (define (open-connection machine port handler)
+    (let-values (((in out)
+                  (tcp-connect machine port)))
+      (handler in out)
+      (close-output-port out)
+      (close-input-port in)))
+  
+  (define (open-ssl-connection machine port handler)
+    (let-values (((in out)
+                  (ssl-connect machine port 'tls)))
+      (handler in out)
+      (close-output-port out)
+      (close-input-port in)))
+  
+  (define (read-async in)
+    (bytes->string/utf-8 (list->bytes (read-async-bytes in))))
+  
+  (define (read-async-bytes in)
+    (let ((bstr '()))
+      (when (sync/timeout 0 in)
+        (set! bstr (cons (read-byte in) (read-async-bytes in)))) bstr))
+  
+  (define ssxml srl:sxml->xml-noindent)
+  
+  ;;;;;; ; ; ; ; ;; ;;;;;; ;
+  ;;
+  ;; XMPP stanzas
+  ;;
+  ;;;;;;;;;; ;;; ; ;; ; ;
+  
+  ;; intialization
+  (define (xmpp-stream host)
+    (string-append "<?xml version='1.0'?>" ;; version='1.0' is a MUST for SASL on 5222 but NOT for ssl on 5223
+                   "<stream:stream xmlns:stream='http://etherx.jabber.org/streams' to='"
+                   host
+                   "' xmlns='jabber:client' >"))
+  
+  ;; authentication
+  (define (xmpp-auth username password resource)
+    (ssxml `(iq (@ (type "set") (id "auth"))
+                (query (@ (xmlns "jabber:iq:auth"))
+                       (username ,username)
+                       (password ,password)
+                       (resource ,resource)))))
+  
+  (define (xmpp-session host)
+    (ssxml `(iq (@ (to ,host) (type "set") (id "session"))
+                (session (@ (xmlns "urn:ietf:params:xml:ns:xmpp-session"))))))
+  
+  ;; messages
+  (define (message to body)
+    (ssxml `(message (@ (to ,to)) (body ,body))))
+  
+  ;; presence
+  (define (presence #:from (from "")
+                    #:to (to "")
+                    #:type (type "")
+                    #:show (show "")
+                    #:status (status ""))
+    (cond ((not (string=? status ""))
+           (ssxml `(presence (@ (type "probe")) (status ,status))))
+          ((string=? type "") "<presence/>")
+          (else (ssxml `(presence (@ (type ,type)))))))
+  
+  ;; queries
+  (define (iq body
+              #:from (from "")
+              #:to (to "")
+              #:type (type "")
+              #:id (id ""))
+    (ssxml `(iq (@ (to ,to) (type ,type) ,body))))
+  
+  ;; curried stanza disection (sxml stanza -> string)
+  (define ((sxpath-element xpath (ns "")) stanza)
+    (let ((node ((sxpath xpath (list (cons 'ns ns))) stanza)))
+      (if (empty? node) "" (car node))))
+  
+  ;; message
+  (define message-from (sxpath-element "message/@from/text()"))
+  (define message-to (sxpath-element "message/@to/text()"))
+  (define message-id (sxpath-element "message/@id/text()"))
+  (define message-type (sxpath-element "message/@type/text()"))
+  (define message-body (sxpath-element "message/body/text()"))
+  (define message-subject (sxpath-element "message/subject/text()"))
+  
+  ;; info/query
+  (define iq-type (sxpath-element "iq/@type/text()"))
+  (define iq-id (sxpath-element "iq/@id/text()"))
+  (define iq-error-type (sxpath-element "iq/error/@type/text()"))
+  (define iq-error-text (sxpath-element "iq/error/text()"))
+  (define iq-error (sxpath-element "iq/error"))
+  
+  ;; presence
+  (define presence-show (sxpath-element "presence/show/text()"))
+  (define presence-from (sxpath-element "presence/@from/text()"))
+  (define presence-status (sxpath-element "presence/status/text()"))
+  
+  
+  ;;;;;;;;;; ; ; ; ;; ;
+  ;;
+  ;; rosters
+  ;;
+  ;;;;;; ; ;; ;
+  
+  ;; request the roster from server
+  (define (request-roster from)
+    (ssxml `(iq (@ (from ,from) (type "get") (id "roster_1"))
+                (query (@ (xmlns "jabber:iq:roster"))))))
+  
+  ;; add an item to the roster
+  (define (add-to-roster from jid name group)
+    (ssxml `(iq (@ (from ,from) (type "set") (id "roster_2"))
+                (query (@ (xmlns "jabber:iq:roster"))
+                       (item (@ (jid ,jid) (name ,name))
+                             (group ,group))))))
+  
+  ;; update an item in the roster
+  (define (update-roster from jid name group)
+    (ssxml `(iq (@ (from ,from) (type "set") (id "roster_3"))
+                (query (@ (xmlns "jabber:iq:roster"))
+                       (item (@ (jid ,jid) (name ,name))
+                             (group ,group))))))
+  
+  ;; remove an item from the roster
+  (define (remove-from-roster from jid)
+    (ssxml `(iq (@ (from ,from) (type "set") (id "roster_4"))
+                (query (@ (xmlns "jabber:iq:roster"))
+                       (item (@ (jid ,jid) (subscription "remove")))))))
+  
+  
+  ;;;;; ; ; ;; ; ;
+  ;;
+  ;; in-band registration
+  ;;
+  ;;;;;; ;; ;; ;
+  
+  (define (reg1)
+    (ssxml `(iq (@ (type "get") (id "reg1"))
+                (query (@ (xmlns "jabber:iq:register"))))))
+  
+  ;;;; ;; ; ;;; ;
+  ;;
+  ;; tls & sasl
+  ;; - http://xmpp.org/rfcs/rfc3920.html#tls
+  ;; - http://xmpp.org/rfcs/rfc3920.html#sasl
+  ;;
+  ;;;; ;;
+  
+  (define session->tls? #f) ;; changes state when a tls proceed is recived
+  
+  ;; moved to xmpp-sasl until it 'works'
+  
+  
+  ;;;;;;;;; ; ;; ; ; ;; ;; ; ;
+  ;;
+  ;; parsing & message/iq/error handlers
+  ;; - minimal parsing
+  ;; - handlers match on a tag (eg. 'message)
+  ;; - handlers are called with a single relevant xmpp stanza
+  ;;
+  ;;;;;; ;; ; ; ;; ;
+  
+  (define xmpp-handlers (make-hash)) ;; a hash of tags and functions (possibly extend to using sxpaths and multiple handlers)
+  
+  (define (set-xmpp-handler type fcn)
+    (dict-set! xmpp-handlers type fcn))
+  
+  (define (remove-xmpp-handler type fcn)
+    (dict-remove! xmpp-handlers type fcn))
+  
+  (define (run-xmpp-handler type sz)
+    (let ((fcn (dict-ref xmpp-handlers type #f)))
+      (when fcn (begin
+                  (debugf "attempting to run handler ~a.~%" fcn)
+                  (fcn sz)))))
+  
+  ;; no real parsing yet. dispatches any received xml stanzas as sxml
+  
+  (define (parse-xmpp-response str)
+    (when (> (string-length str) 0)
+      (let ((sz (ssax:xml->sxml (open-input-string (clean str)) '())))
+        ;;(let ((sz (lazy:xml->sxml (open-input-string str) '())))
+        (cond
+          ((equal? '(null) (cadr sz))
+           (newline))
+          ((equal? 'message (caadr sz))
+           (run-xmpp-handler 'message sz))
+          ((equal? 'iq (caadr sz))
+           (run-xmpp-handler 'iq sz))
+          ((equal? 'presence (caadr sz))
+           (run-xmpp-handler 'presence sz))
+          (else (run-xmpp-handler 'other sz))))))
+  
+  ;; example handlers to print stanzas or their contents
+  (define (print-message sz)
+    (printf "a ~a message from ~a which says '~a.'~%" (message-type sz) (message-from sz) (message-body sz)))
+  
+  (define (print-iq sz)
+    (printf "an iq response of type '~a' with id '~a.'~%" (iq-type sz) (iq-id sz)))
+  
+  (define (print-presence sz)
+    (printf " p-r-e-s-e-n-e-c--> ~a is ~a" (presence-from sz) (presence-status)))
+  
+  (define (print-stanza sz)
+    (printf "? ?? -> ~%~a~%" sz))
+  
+  ;; handler to print roster
+  
+  (define (roster-jids sz)
+    ((sxpath "iq/ns:query/ns:item/@jid/text()" '(( ns . "jabber:iq:roster"))) sz))
+ 
+  (define (roster-items sz)
+    ((sxpath-element "iq/ns:query/ns:item" '(( ns . "jabber:iq:roster"))) sz))
+  
+  (define (print-roster sz)
+    (when (and (string=? (iq-type sz) "result")
+               (string=? (iq-id sz) "roster_1"))
+      (printf "~a~%" (roster-jids sz))))
+  
+  ;; QND hack to filter out anything not a message, iq or presence
+  (define (clean str)
+    (let ((test (substring str 0 3)))
+      (cond ((string-ci=? test "<me") str)
+            ((string-ci=? test "<iq") str)
+            ((string-ci=? test "<pr") str)
+            ((string-ci=? test "<ur") str)
+            (else
+             (debugf "~%recieved: ~a ~%parsed as <null/>~%~%" str)
+             "<null/>"))))
+  
+  
+  ;; response handler
+  (define (xmpp-response-handler in)
+    (thread (lambda ()
+              (let loop ()
+                (parse-xmpp-response (read-async in))
+                (sleep 0.1) ;; slight delay to avoid a tight loop
+                (loop)))))
+  
+  ;; jid splicing (assuming the jid is in the format user@host/resource)
+  (define (jid-user jid)
+    (string-take jid (string-index jid #\@)))
+  
+  (define (jid-host jid)
+    (let* ((s (string-take-right jid (- (string-length jid) (string-index jid #\@) 1)))
+           (v (string-index s #\/)))
+      (if v (string-take s v) s )))
+  
+  (define (jid-resource jid)
+    (let ((r (jid-resource-0 jid)))
+      (if (void? r) (gethostname) r)))
+  
+  (define (jid-resource-0 jid)
+    (let ((v (string-index jid #\/)))
+      (when v (string-take-right jid (- (string-length jid) v 1)))))
+  
+  
+  ;;;; ;; ; ; ;; ;; ;;;; ;
+  ;;
+  ;; interfaces
+  ;;
+  ;;;;; ;; ;;;; ; ;; ;
+  
+  (define xmpp-in-port (make-parameter #f))
+  (define xmpp-out-port (make-parameter #F))
+  
+  (define (send str)
+    (debugf "sending: ~a ~%~%" str)
+    (let* ((p-out (xmpp-out-port))
+           (out (if p-out p-out xmpp-out-port-v)))
+      (fprintf out "~A~%" str) (flush-output out)))
+  
+  (define-syntax with-xmpp-session
+    (syntax-rules ()
+      ((_ jid pass form . forms)
+       (let ((host (jid-host jid))
+             (user (jid-user jid))
+             (resource (jid-resource jid)))
+         (let-values (((in out)
+                       (ssl-connect host ssl-port 'tls)))
+           ;;(tcp-connect host port)))
+           (parameterize ((xmpp-in-port in)
+                          (xmpp-out-port out))
+             (file-stream-buffer-mode out 'line)
+             (xmpp-response-handler in)
+             (send (xmpp-stream host))
+             (send (xmpp-session host))
+             ;(starttls in out)
+             (send (xmpp-auth user pass resource))
+             (send (presence))
+             (begin form . forms)
+             (close-output-port out)
+             (close-input-port in)))))))
+  
+  ;; NOTE: this will only work with a single connection to a host, however multiple sessions to that host may be possible
+  (define xmpp-in-port-v (current-input-port))
+  (define xmpp-out-port-v (current-output-port))
+  
+  (define (start-xmpp-session jid pass)
+    (let ((host (jid-host jid))
+          (user (jid-user jid))
+          (resource (jid-resource jid)))
+      (let-values (((in out)
+                    (ssl-connect host ssl-port 'tls)))
+        ;;(tcp-connect host port)))
+        (set! xmpp-in-port-v in)
+        (set! xmpp-out-port-v out)
+        (file-stream-buffer-mode out 'line)
+        (xmpp-response-handler in)
+        (send (xmpp-stream host))
+        (send (xmpp-session host))
+        ;;(starttls in out)
+        (send (xmpp-auth user pass resource))
+        (send (presence)))))
+  
+  (define (close-xmpp-session)
+    (close-output-port xmpp-out-port-v)
+    (close-input-port xmpp-in-port-v))
+  
+  ) ;; end module

pluggable/pluggable.scm

@@ -67,7 +67,7 @@
         (cond 
             (ret (cdr ret))
             (else
-                (let* ((tex (load-primitive (string-append "plant-2/comp-cp-" id ".png")))
+                (let* ((tex (load-primitive (string-append "plant-1/comp-cp-" id ".png")))
                         (connections (with-primitive tex (convert-to-pos (find-centroids 0 '())))))
                     (set! connection-cache (cons (cons id connections) connection-cache))
                     (destroy tex)
@@ -85,7 +85,7 @@
             (let ((root (with-state
                             (translate (vector 0 0.5 0))
                             (hint-ignore-depth)
-                            (texture (load-texture (string-append "plant-2/comp-" id ".png")))
+                            (texture (load-texture (string-append "plant-1/comp-" id ".png")))
                             (build-plane))))
                 (with-primitive root (apply-transform))
                 (make-component root '())))
@@ -93,7 +93,7 @@
             (let* ((connection-list (get-connection-list id))
                     (root (with-state
                             (translate (vector 0 0.5 0))
-                            (texture (load-texture (string-append "plant-2/comp-" id ".png")))
+                            (texture (load-texture (string-append "plant-1/comp-" id ".png")))
                             (build-plane)))
                     (comp (make-component root
                             (map
@@ -127,9 +127,9 @@
         (cond 
             ((eq? num-children 0) (list (choose (list "3" "4" "8" "9")) (list)))
             ((eq? num-children 1) (list "1-1" (list (make-random-plant (+ depth 1)))))
-            ((eq? num-children 2) (list (string-append "2-" (choose (list "1" "2" "6" "10" "13" "16"))) (list (make-random-plant (+ depth 1))
+            ((eq? num-children 2) (list (string-append "2-" (choose (list "1"))) (list (make-random-plant (+ depth 1))
                         (make-random-plant (+ depth 1)))))
-            ((eq? num-children 3) (list (string-append "3-" (choose (list "7")))
+            ((eq? num-children 3) (list (string-append "3-" (choose (list "1")))
                         (list (make-random-plant (+ depth 1))
                         (make-random-plant (+ depth 1)) (make-random-plant (+ depth 1)))))
             ((eq? num-children 4) (list "4-1" (list (make-random-plant (+ depth 1))