groworld/hayfever/hayfever.scm

;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

(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-1" (list (make-random-plant (+ depth 1)))))
            ((eq? num-children 2) (list "2-1" (list (make-random-plant (+ depth 1))
                        (make-random-plant (+ depth 1)))))
            ((eq? num-children 3) (list "3-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))
                        (make-random-plant (+ depth 1)) (make-random-plant (+ depth 1)) 
                        (make-random-plant (+ depth 1)))))
            ((eq? num-children 5) (list "5-1" (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)))
                          (cc (vadd col (vmul (grndvec) 0.2))))
                        (pdata-set! "p" c (vadd (vmul (cirndvec) size) pos))
                        (pdata-set! "c" c (vector (vx cc) (vy cc) (vz cc) 0.5))))))
        
        (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))