added

hayfever/hayfever.scm

@@ -0,0 +1,421 @@
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+(require scheme/class)
+(require mzlib/string)
+
+(osc-destination "osc.udp://127.0.0.255:4001")
+(osc-source "4002")
+
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+; pixel primitive things for getting connection points
+
+; 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)))))
+
+(define (i->pos i)
+    (vector (modulo i (pixels-width)) 
+        (quotient i (pixels-width)) 0))
+
+(define (pos->i pos)
+    (+ (* (round (vy pos)) (pixels-width)) (round (vx pos))))
+
+(define (pixels-ref name pos)
+    (pdata-ref name (pos->i pos)))
+
+(define (pixels-set! name pos s)
+    (pdata-set! name (pos->i pos) s))
+
+(define (search i)
+    (cond
+        ((eq? i (pdata-size)) i)
+        ((< (vr (pdata-ref "c" i)) 0.5) i)
+        (else (search (+ i 1)))))
+
+(define (flood pos tc av)
+    (define (rec-flood pos)
+        (pixels-set! "c" pos (vector 1 0 1))
+        (set! tc (+ tc 1))
+        (set! av (vadd av pos))
+        (when (< (vr (pixels-ref "c" (vadd pos (vector -1 0 0)))) 0.5)
+            (rec-flood (vadd pos (vector -1 0 0))))
+        (when (< (vr (pixels-ref "c" (vadd pos (vector 1 0 0)))) 0.5)
+            (rec-flood (vadd pos (vector 1 0 0))))
+        (when (< (vr (pixels-ref "c" (vadd pos (vector 0 1 0)))) 0.5)
+            (rec-flood (vadd pos (vector 0 1 0))))
+        (when (< (vr (pixels-ref "c" (vadd pos (vector 0 -1 0)))) 0.5)
+            (rec-flood (vadd pos (vector 0 -1 0)))))
+    (rec-flood pos)
+    (vmul av (/ 1 tc)))
+
+(define (find-centroids pos l)
+    (let ((i (search pos)))
+        (cond ((eq? i (pdata-size)) l)
+            (else
+                (find-centroids i 
+                    (cons (flood (i->pos i) 0 (vector 0 0 0)) l))))))
+
+(define (convert-to-pos l)
+    (map 
+        (lambda (cp)
+            (vector (- (- (/ (vx cp) (pixels-width)) 0.5))
+                (- 1 (/ (vy cp) (pixels-height))) 0))
+        l))
+
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+; a cache for the connection points - should save this out 
+
+(define connection-cache '())
+
+(define (get-connection-list id)
+    (let ((ret (assoc id connection-cache)))
+        (cond 
+            (ret (cdr ret))
+            (else
+                (let* ((tex (load-primitive (string-append "textures/comp-cp-" id ".png")))
+                        (connections (with-primitive tex (convert-to-pos (find-centroids 0 '())))))
+                    (set! connection-cache (cons (cons id connections) connection-cache))
+                    (destroy tex)
+                    connections)))))
+
+
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+; a plant component
+
+(define-struct component (root children))
+
+(define (build-component id children)
+    (cond 
+        ((null? children) 
+            (let ((root (with-state
+                            (translate (vector 0 0.5 0))
+                            (rotate (vector 0 0 180))
+                            (texture (load-texture (string-append "textures/comp-" id ".png")))
+                            (build-plane))))
+                (make-component root '())))
+        (else
+            (let* ((connection-list (get-connection-list id))
+                    (root (with-state
+                            (translate (vector 0 0.5 (* 0.1 (rndf))))
+                            (rotate (vector 0 0 180))
+                            (texture (load-texture (string-append "textures/comp-" id ".png")))
+                            (build-plane)))
+                    (comp (make-component root
+                            (map
+                                (lambda (child connection)
+                                    (with-state                                        
+                                        (parent root)
+                                        (translate (vadd connection (vector 0 0 (* 0.1 (rndf)))))
+                                        (rotate (vector 0 0 (2dvec->angle 
+                                                    (vx connection) (- (vy connection) 0.5))))
+                                        (rotate (vector 0 0 0))
+                                        (build-component (car child) (cadr child))))
+                                children
+                                connection-list))))
+                (with-primitive root (apply-transform))
+                comp))))
+
+(define (random-leaf component)
+    (cond
+        ((null? (component-children component)) component)
+        (else (random-leaf (choose (component-children component))))))
+
+
+(define (component-print component)
+    (printf "~a~n" (component-children component)))
+
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+; utils for building random plants
+
+(define (choose l)
+    (list-ref l (random (length l))))
+
+(define (make-random-plant depth)        
+    (let ((num-children (if (> depth 3) 0 (choose (list 0 1 2 3)))))
+        (cond 
+            ((eq? num-children 0) (list (choose (list "2" "3" "4" "5" "6" "7" "8" "9" "10")) (list)))
+            ((eq? num-children 1) (list "1-0" (list (make-random-plant (+ depth 1)))))
+            ((eq? num-children 2) (list "2-0" (list (make-random-plant (+ depth 1))
+                        (make-random-plant (+ depth 1)))))
+            ((eq? num-children 3) (list "3-0" (list (make-random-plant (+ depth 1))
+                        (make-random-plant (+ depth 1)) (make-random-plant (+ depth 1)))))
+            ((eq? num-children 4) (list "4-0" (list (make-random-plant (+ depth 1))
+                        (make-random-plant (+ depth 1)) (make-random-plant (+ depth 1)) 
+                        (make-random-plant (+ depth 1)))))
+            ((eq? num-children 5) (list "5-0" (list (make-random-plant (+ depth 1))
+                        (make-random-plant (+ depth 1)) (make-random-plant (+ depth 1))
+                        (make-random-plant (+ depth 1)) (make-random-plant (+ depth 1))))))))
+
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+; the world things live in
+
+(define world%
+    (class object%
+        (init-field (size 1))
+        
+        (field
+            (root 0)
+            (entity-list '())
+            (id 0)
+            (pollen 0))
+        
+        (define/public (init)
+            
+            (set! pollen (with-state
+                    (translate (vector 0 0 0.1))
+                    (texture (load-texture "textures/pollen.png"))
+                    (build-particles 300)))
+            
+            (with-primitive pollen
+                (hint-depth-sort)
+                (pdata-map!
+                    (lambda (p)
+                        (vmul (vector (crndf) (crndf) 0) 10))
+                    "p")
+                (pdata-map!
+                    (lambda (c)
+                        (vector (rndf) (rndf) (rndf) 0.5))
+                    "c")
+                (pdata-map!
+                    (lambda (c)
+                        (let ((s (* 0.1 (grndf))))
+                            (vector s s 1)))
+                    "s"))
+            
+            
+            #;(set! root (with-state
+                    (rotate (vector 90 0 0))
+                    (scale 100)
+                    (build-plane)))
+            (with-state 
+                (hint-depth-sort)
+                ;                (parent root)
+                (with-state
+                    (colour 0.5)
+                    (scale (vector 20 13 1))
+                    (translate (vector 0 0.4 0))
+                    (rotate (vector 0 0 180))
+                    (texture (load-texture "textures/bg.png"))
+                    (hint-unlit)
+                    (build-plane))
+                (with-state
+                    (scale (vector 19 8 1))
+                    (translate (vector 0 0.2 1.5))
+                    (rotate (vector 0 0 180))
+                    (texture (load-texture "textures/mid.png"))
+                    (hint-unlit)
+                    (build-plane))))
+        
+        (define (inc-id!)
+            (set! id (+ id 1)))
+        
+        (define/public (get-entity-list)
+            entity-list)
+        
+        (define/public (get-entity id)
+            (foldl
+                (lambda (entity ret)
+                    (if (eq? (send entity get-id) id)
+                        entity
+                        ret))
+                #f
+                entity-list))
+        
+        (define/public (choose)
+            (list-ref entity-list (random (length entity-list))))
+        
+        (define/public (add-entity entity)
+            (inc-id!)
+            (send entity set-id! id)
+            (set! entity-list (cons entity entity-list))
+            id)
+        
+        (define/public (destroy-entity id)
+            (set! plants
+                (filter
+                    (lambda (entity)
+                        (cond ((eq? (send entity get-id) id)
+                                (send entity destroy)
+                                #f)
+                            (else #t)))
+                    entity-list)))
+        
+        (define/public (update)
+            (with-primitive pollen
+                (animate-pollen))
+            (for-each
+                (lambda (entity)
+                    (send entity update this))
+                entity-list))
+        
+        ; pollen stuff
+        
+        (define (animate-pollen)
+            (pdata-map! 
+                (lambda (p)
+                    (let* ((pp (vmul p 0.5))
+                            (v (vector (- (noise (vx pp) (vy pp) (time)) 0.5)
+                                    (- (noise (vx pp) (+ (vy pp) 112.3) (time)) 0.5) 0)))
+                        (vadd (vadd p (vmul v 0.2))
+                            (vmul (vector (crndf) (crndf) 0) 0.01))))
+                "p"))
+        
+        (define (cirndvec)
+            (let ((o (srndvec)))
+                (vector (vx o) (vy o) 0)))
+        
+        (define/public (puff-pollen pos col size np)
+            (with-primitive pollen
+                (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)))))))
+        
+        (super-new)
+        (init)))
+
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+; the entity base class
+
+(define entity%
+    (class object%
+        (init-field (id 0))
+        
+        (define/public (get-id)
+            id)
+        
+        (define/public (set-id! s)
+            (set! id s))
+        
+        (super-new)))
+
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+; finally, a plant...
+
+(define plant% 
+    (class entity%  
+        (init-field
+            (pos (vector 0 0 0))
+            (col (vector 1 1 1))
+            (plant-desc '()))
+        
+        (field
+            (root-component 0)
+            (spray-t 0))
+        
+        (define/public (init)
+            (with-state
+                (hint-depth-sort)
+                ;(parent (send world get-root))
+                ;(colour col)
+                (hint-unlit)
+                (translate pos)
+                (printf "building from:~a~n" plant-desc)
+                (set! root-component (build-component "1-0" plant-desc))))
+        
+        (define/public (destroy-plant)
+            (destroy root))
+        
+        (define/public (update world) 
+            0 
+            #;(with-primitive root
+                (colour col)
+                (when (> spray-t 1)
+                    (set! spray-t (* spray-t 0.9))
+                    (colour spray-t))))
+        
+        (define/public (spray world type)
+            (let ((pos (vtransform (vector 0 0 0)
+                            (with-primitive (component-root (random-leaf root-component))
+                                (get-global-transform)))))
+                (send world puff-pollen pos (vector 1 1 1) 0.2 100)))
+        
+        (super-new)
+        (init)))
+
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+(define network-dispatch%
+    (class object%
+
+(define (stringify l)
+  (cond 
+    ((null? l) l)
+    ((symbol? (car l))
+     (cons (symbol->string (car l))
+           (stringify (cdr l))))
+    ((number? (car l))
+     (cons (number->string (car l))
+           (stringify (cdr l))))
+    ((list? (car l))
+     (cons (stringify (car l)) (stringify (cdr l))))
+    (else (error "oops"))))
+        
+
+        (define/public (dispatch world)
+            (cond
+                ((osc-msg "/add-plant")
+                    (printf "add plant message recieved : ~a~n" (osc 6))
+                    (send world add-entity (make-object plant%
+                            (vector (osc 0) (osc 1) (osc 2))
+                            (vector (osc 3) (osc 4) (osc 5)) 
+                                (stringify (eval-string (osc 6))))))
+                ((osc-msg "/destroy-plant")
+                    (printf "destroy plant message recieved...~n")
+                    (send world destroy-entity (osc 0)))
+                ((osc-msg "/spray")
+                    ; (printf "destroy plant message recieved...~n")
+                    (send (send world get-entity (osc 0)) spray world (osc 1)))))
+        
+        (define/public (add-plant world)
+            (printf "sending add plant...~n")
+
+            (let* ((pos (vector (* (crndf) 5) 2 1)) 
+                  (col (rndvec))
+                  (desc (list (make-random-plant 0)))
+                  (desc-str (format "'~a" desc)))
+                (printf "sending:~a~n" desc-str)
+                (osc-send "/add-plant" "ffffffs" (list (vx pos) (vy pos) (vz pos)
+                        (vx col) (vy col) (vz col) desc-str))
+                (send world add-entity (make-object plant% pos col desc))))
+        
+        (define/public (destroy-plant world id)
+            (printf "sending destroy plant...~n")
+            (osc-send "/destroy-plant" "i" (list id))
+            (send world destroy-entity id))
+        
+        (define/public (spray world id type)
+            ;    (printf "sending destroy plant...~n")
+            (osc-send "/spray" "ii" (list id type))
+            (send (send world get-entity id) spray world type))
+        
+        (super-new)))
+
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+(clear)
+(clear-colour 0)
+(set-camera-transform (mtranslate (vector 0 -5 -10)))
+
+(define w (make-object world% 1))
+(define n (make-object network-dispatch%))
+
+
+(define (animate)
+    (when (key-pressed " ") (send n add-plant w))
+    (send n dispatch w)
+    (send w update)
+    (when (and (zero? (random 50)) (not (null? (send w get-entity-list))) )
+        (send n spray w (send (send w choose) get-id) 0)))
+
+(every-frame (animate))
+
+