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 (col #:mutable) children))

(define (build-component id col children)
    (cond 
        ((null? children) 
            (let ((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))))
                (make-component root col '())))
        (else
            (let* ((connection-list (get-connection-list id))
                    (root (with-state
                            (translate (vector 0 0.5 (* 0.01 (rndf))))
                            (rotate (vector 0 0 180))
                            (texture (load-texture (string-append "textures/comp-" id ".png")))
                            (build-plane)))
                    (comp (make-component root col
                            (map
                                (lambda (child connection)
                                    (with-state                                        
                                        (parent root)
                                        (translate (vadd connection (vector 0 0 (* 0.01 (rndf)))))
                                        (rotate (vector 0 0 (2dvec->angle 
                                                    (vx connection) (- (vy connection) 0.5))))
                                        (rotate (vector 0 0 0))
                                        (build-component (car child) col (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-leaves component)
    (cond
        ((null? (component-children component)) (list component))
        (else 
            (foldl
                (lambda (child r)
                    (append (component-leaves child) r))
                '()
                (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 (cond ((> depth 2) 0)
                              ((< depth 1) (choose (list 2 3)))
                              (else (choose (list 0 1 2 3))))))
        (cond 
            ((eq? num-children 0) (list (choose (list "11")) (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)
            (my-id 0))
        
        (define/public (init)
            
            (set! pollen (with-state
                    (translate (vector 0 0 0.2))
                    (texture (load-texture "textures/pollen.png"))
                    (build-particles 1000)))
            
            (with-primitive pollen
                (pdata-map!
                    (lambda (p)
                        (vmul (vector (crndf) (crndf) (+ 0.2 (* (rndf) 0.01))) 10))
                    "p")
                (pdata-map!
                    (lambda (c)
                        (vector (rndf) (rndf) (rndf) 0.5))
                    "c")
                (pdata-map!
                    (lambda (c)
                        (let ((s (* 0.2 (grndf))))
                            (vector s s 1)))
                    "s"))
            
            
            #;(set! root (with-state
            
                (rotate (vector 90 0 0))
                    (scale 100)
                    (build-plane)))
            (with-state 
                ;                (parent root)
                (with-state
                    (colour (vector 0.5 1 0.5))
                    (scale (vector 20 13 1))
                    (translate (vector 0 0.2 0))
                    (rotate (vector 0 0 180))
;                    (texture (load-texture "textures/hills.png"))
                    (hint-unlit)
                    (build-plane))
                #;(with-state
                    (scale (vector 14 15 1))
                    (translate (vector 0 0.3 4.5))
                    (rotate (vector 0 0 180))
                    (texture (load-texture "textures/fg.png"))
                    (hint-unlit)
                    (build-plane))))
        
        (define/public (get-entity-list)
            entity-list)
        
        (define/public (get-my-id)
            my-id)
        
        (define/public (make-my-plant)
            (let* ((pos (vector (* (crndf) 5) 2 0.1)) 
                    (col (hsv->rgb (vector (rndf) 0.8 1)))
                    (desc (list (make-random-plant 0))))
                (set! my-id (length entity-list))
                (set-entity my-id (make-object plant% pos col desc))))
        
        (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 (set-entity id entity)
            ; if it already exists, destroy it
            ; (do we want to do this all the time?)
            (when (get-entity id)
                (destroy-entity id))
            
            (send entity set-id! id)
            (set! entity-list (cons entity entity-list)))
        
        (define/public (destroy-entity id)
            (set! entity-list
                (filter
                    (lambda (entity)
                        (cond ((eq? (send entity get-id) id)
                                (send entity destroy-me)
                                #f)
                            (else #t)))
                    entity-list)))
        
        (define/public (update network)
            (with-primitive pollen
                (animate-pollen))
            
            ; update my plant with player input
            (when (get-entity my-id)
                (send (get-entity my-id) player-update this network))
            
            (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 (vmul col 1)))
                        (pdata-set! "p" c (vadd (vmul (cirndvec) size) 
                            (vadd pos (vector 0 0 (+ 0.2 (* (rndf) 0.01))))))
                        (pdata-set! "c" c (vector (vx cc) (vy cc) (vz cc) 0.5))))))
        
        (define/public (suck-pollen pos size)
            (with-primitive pollen
                (pdata-index-fold
                    (lambda (i p c r)
                        (cond ((< (vdist pos p) (/ size 10))
                                (pdata-set! "p" i (vector -1000 0 0))   
                                (cons c r))
                            ((< (vdist pos p) size)
                                (pdata-set! "p" i (vadd p 
                                        (vmul (vnormalise (vsub pos p)) 0.1)))
                                r)
                            (else r)))
                    '()
                    "p" "c")))
        
        (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 '())
            (flower-list '())
            (current-flower 0))
        
        (field
            (root-component 0)
            (spray-t 0))
        
        (define/public (get-pos)
            pos)
        
        (define/public (get-col)
            col)
        
        (define/public (get-desc)
            plant-desc)
        
        (define/public (init)
            (with-state
                ;(parent (send world get-root))
                (colour col)
                (hint-unlit)
                (translate pos)
                (printf "building from:~a~n" plant-desc)
                (set! root-component (build-component "1-1" col plant-desc))
                (set! flower-list (component-leaves root-component))))
        
        (define/public (destroy-me)
            (destroy (component-root root-component)))
        
        
        (define/public (player-update world network)
            (when (key-special-pressed 100)
                (set! current-flower (modulo (+ current-flower 1) (length flower-list))))
            
            (when (key-special-pressed 102)
                (set! current-flower (modulo (- current-flower 1) (length flower-list))))
            
            
            ; bit odd, have to go through network to tell other clients to
            ; spray, and need to get the id of the player plant from the world...
            (when (key-special-pressed 101)
                (send network spray world (send world get-my-id) current-flower 0))
            
            (let ((flower (list-ref flower-list current-flower)))
                
                (with-primitive (component-root flower)
                    (when (key-special-pressed 103)
                        (rotate (vector 0 0 20))
                        (let ((colours (suck world current-flower)))
                            (when (not (zero? (length colours)))
                                (let
                                    ((av-col (vdiv (foldl vadd (vector 0 0 0) colours) (length colours))))
                                    
                                    (set-component-col! flower
                                        (vadd (vmul (component-col flower) 0.9)
                                            (vmul av-col 0.1)))
                                    
                                    (send network flower-update world (send world get-my-id) 
                                        current-flower (component-col flower))))))
                    
                    
                    (rotate (vector 0 0 2)))))
        
        (define/public (flower-update flower col)
            (let ((flower (list-ref flower-list flower)))
                (set-component-col! flower col)
                (with-primitive (component-root flower)
                    (colour (component-col flower)))))

        (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 flower type)
            (let ((pos (vtransform (vector 0 0 0)
                            (with-primitive (component-root (list-ref flower-list flower))
                                (get-global-transform)))))
                (send world puff-pollen pos (component-col (list-ref flower-list flower))
                     0.2 1)))
        
        (define/public (suck world flower)
            (let ((pos (vtransform (vector 0 0 0)
                            (with-primitive (component-root (list-ref flower-list flower))
                                (get-global-transform)))))
                (send world suck-pollen pos 5)))
        
        (super-new)
        (init)))

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

(define network-dispatch%
    (class object%
        
        (field
            (waiting #f)
            (wait-till 0))
        
        (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))))
                ((vector? (car l))
                    (cons (car l)
                        (stringify (cdr l))))
                ((list? (car l))
                    (cons (stringify (car l)) (stringify (cdr l))))
                (else (error "oops"))))
        
        
        (define (dispatch world)
            (cond
                ((osc-msg "/join-game")
                    (printf "a new plant has joined the game~n")
                    ; send a plant update for the new player
                    (update-plant world) )
                
                ((osc-msg "/plant")
                    (printf "add plant message recieved : ~a~n" (osc 0))
                    (send world set-entity (osc 0) (make-object plant%
                            (vector (osc 1) (osc 2) (osc 3))
                            (vector (osc 4) (osc 5) (osc 6)) 
                            (stringify (eval-string (osc 7))))))

                ((osc-msg "/flower")
                    ;(printf "flower change msg recieved~n")
                    (send (send world get-entity (osc 0)) flower-update 
                        (osc 1) (vector (osc 2) (osc 3) (osc 4))))
                
                ((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")
                    (let ((e (send world get-entity (osc 0))))
                        ; it's possible to get spray events before the 
                        ; plant has been created...
                        (when e
                            (send e spray world (osc 1) (osc 2)))))))
        
        (define/public (join-game world)
            (printf "sending join-game~n")           
            (osc-send "/join-game" "" (list))
            (set! wait-till (+ (time) 2))
            (set! waiting #t))
        
        (define/public (update-plant world)
            (printf "sending /plant...~n")
            
            (let* ((my-plant (send world get-entity (send world get-my-id)))
                    (pos (send my-plant get-pos)) 
                    (col (send my-plant get-col))
                    (desc-str (format "'~a" (send my-plant get-desc))))
                
                (osc-send "/plant" "iffffffs" (list (send world get-my-id) 
                        (vx pos) (vy pos) (vz pos)
                        (vx col) (vy col) (vz col) 
                        desc-str))))
        
        (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 flower type)
            (osc-send "/spray" "iii" (list id flower type))
            (send (send world get-entity id) spray world flower type))

        (define/public (flower-update world id flower col)
            (osc-send "/flower" "iifff" (list id flower (vx col) (vy col) (vz col)))
            (send (send world get-entity id) flower-update flower col))

        
        (define/public (update world)
            ; wait for all other players to register their plants
            (when (and waiting (< wait-till (time)))
                (set! waiting #f)
                (send world make-my-plant) 
                (update-plant world))
            (dispatch world))
        
        
        (super-new)))

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

(clear)
(clear-colour (vector 0.5 0.5 1))
(hint-depth-sort)
(set-camera-transform (mtranslate (vector 0 -5 -10)))

(define w (make-object world% 1))
(define n (make-object network-dispatch%))

(send n join-game w)

(define (animate)
    (send n update w)
    (send w update n)) 

(every-frame (animate))