groworld/hayfever/hayfever2.scm

;#lang scheme
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; h a y f e v e r

;(require fluxus-016/drflux)
(require scheme/class)
(require mzlib/string)
(require openssl)
(require "xmpp-dave.ss")
;(require (prefix-in xmpp: (planet zzkt/xmpp)))

(define plant2 #f)
;(set! plant2 #t)

(define debug-jab #t)
(define debug-netloop #f)
(define pollen-particles 300)
(define max-pollen-radius 12)
(define suck-pollen-radius 8)
(define deterministic #t)
(define minimal-mode #f)
(define jid "plant0000003@fo.am")
(define pass "plant0000003")
(define jto "plant0000002@fo.am")

(when plant2
    (set! jid "plant0000002@fo.am")
    (set! pass "plant0000002")
    (set! jto "plant0000003@fo.am"))

(printf "I am ~a~n" jid)

(when deterministic
    (flxseed 1)
    (random-seed 2))


;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; 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))
                (/ (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.01 (rndf))))
                            (hint-none)
                            (hint-solid)
                            (hint-unlit)
                            (hint-depth-sort)
                            (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
                            (hint-depth-sort)
                            (translate (vector 0 0.5 (* 0.01 (rndf))))
                            ;                            (rotate (vector 0 0 90))
                            (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 (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 ""))
        
        (define/public (init)
            
            (set! pollen (with-state
                    (translate (vector 0 0 0.2))
                    (texture (load-texture "textures/pollen.png"))
                    (build-particles pollen-particles)))
            
            (with-primitive pollen
                (pdata-map!
                    (lambda (p)
                        (vmul (vector (crndf) (crndf) 0)  5))
                    "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")))
        
        (define/public (get-entity-list)
            entity-list)
        
        (define/public (get-my-id)
            my-id)
        
        (define/public (make-my-plant)
            
            (when deterministic
                (flxseed 3)
                (random-seed 1) ; 2 5 
                )
            
            
            (let* ((pos (vector -4 #;(* (crndf) 5) 0 0.1))
                    (col (hsv->rgb (vector (rndf) 0.8 1)))
                    (desc (list (make-random-plant 0))))
                (set! my-id jid)
                (set-entity my-id (make-object plant% pos col desc)))


            (let* ((pos (vector 4 #;(* (crndf) 5) 0 0.1)) 
                    (col (hsv->rgb (vector (rndf) 0.8 1)))
                    (desc (list (make-random-plant 0))))
                (set-entity "other" (make-object plant% pos col desc))))
        
        (define/public (get-entity id)
            (foldl
                (lambda (entity ret)
                    (if (string=? (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-all-but-me)
            (set! entity-list
                (filter
                    (lambda (entity)
                        (cond ((not (string=? (send entity get-id) my-id))
                                (send entity destroy-me)
                                #f)
                            (else #t)))
                    entity-list)))
        
        (define/public (destroy-entity id)
            (set! entity-list
                (filter
                    (lambda (entity)
                        (cond ((string=? (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 (vadd (vmul p 1) (vector 0 (- (flxtime)) 0)))
                            (v (cond 
                                    ((< (vy p) 0) (vmul (vector (crndf) 1 (crndf)) 0.1))
                                    ((> (vmag p) max-pollen-radius) (vmul p -0.1))
                                    (else
                                        (vector (- (noise (vx pp) (vy pp) (vz pp)) 0.5)
                                            (- (noise (vx pp) (+ (vy pp) 112.3) (vz pp)) 0.5)
                                            0 #;(- (noise (+ (vx pp) 393.2) (vy pp) (vz pp)) 0.5))))))
                        (vadd (vadd p (vmul v 0.2))
                            (vmul (srndvec) 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 (vector (vx pos) (vy pos) 0)
                                    (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) 0.5)
                                (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-this-frame 100)
                (set! current-flower (modulo (+ current-flower 1) (length flower-list))))
            
            (when (key-special-pressed-this-frame 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-this-frame 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-this-frame 103)
                        (rotate (vector 0 0 20))
                        (let ((colours (suck world current-flower)))
                            (when (not (zero? (length colours)))
                                (let
                                    ((av-col (vdiv (foldl (lambda (c1 c2)
                                                        (vadd c1 c2)) (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 10)))
        
        (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 suck-pollen-radius)))
        
        (super-new)
        (init)))

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

; things changed in xmpp
; * removed printf
; * renamed send to xmpp-send

(define jabberer%
    (class object%
        (field 
            (incoming '())
            (outgoing '())
            (thr 0))
        
        (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" (message-from sz) (message-body sz)))
            (set! incoming (cons (list (message-from sz) (message-body sz)) incoming)))
        
        (define/public (start)
            (set! thr (thread run)))
        
        (define/public (stop)
            (kill-thread thr))
        
        (define (run)
            (with-xmpp-session jid pass
                (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 (message (car msg) (cadr msg))))
                            outgoing)
                        (set! outgoing '()))
                    (sleep 0.5)
                    (loop))))
        (super-new)))

(define network-dispatch%
    (class object%
        
        (field
            (waiting #f)
            (wait-till 0)
            (jab (make-object jabberer%))
            (send-to jto))
        
        (define/public (start)
            (send jab start))
        
        
        (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 (split-string str)
            (let* ((l (string->list str))
                    (cur "")
                    (r (reverse (foldl 
                                (lambda (c l)
                                    (cond 
                                        ((char=? #\  c)
                                            (let ((r (cons cur l)))
                                                (set! cur "")
                                                r))
                                        (else
                                            (set! cur (string-append cur (string c)))
                                            l)))
                                '()
                                l))))
                (if (not (string=? cur ""))
                    (append r (list cur))
                    r)))
        
        (define (join-end n l s)
            (cond
                ((null? l) s)
                ((not (zero? n)) (join-end (- n 1) (cdr l) s))
                (else
                    (join-end n (cdr l) (string-append s " " (car l))))))
        
        (define (dispatch world)
            (for-each
                (lambda (msg)
                    (let* ((chopped (split-string (cadr msg)))
                            (command (list-ref chopped 0))
                            (args (cdr chopped)))
                        (cond
                            ((string=? command "ping")
                                (printf "pong~n"))
                            
                            ((string=? command "join-game")
                                (send world destroy-all-but-me)
                                (printf "a new plant has joined the game~n")
                                ; send a plant update for the new player
                                (update-plant world) )
                            
                            ((string=? command "plant")
                                (printf "add plant message recieved : ~a~n" (list-ref args 0))
                                (send world set-entity (list-ref args 0) (make-object plant%
                                        (vector (string->number (list-ref args 1)) 
                                            (string->number (list-ref args 2)) 
                                            (string->number (list-ref args 3)))
                                        (vector (string->number (list-ref args 4))
                                            (string->number (list-ref args 5)) 
                                            (string->number (list-ref args 6)))
                                        (stringify (eval-string (join-end 7 args ""))))))
                            
                            ((string=? command "flower")
                                ;(printf "flower change msg recieved~n")
                                (send (send world get-entity (list-ref args 0)) flower-update 
                                    (string->number (list-ref args 1)) (vector (string->number (list-ref args 2)) 
                                        (string->number (list-ref args 3)) 
                                        (string->number (list-ref args 4)))))
                            
                            ((string=? command "destroy-plant")
                                (printf "destroy plant message recieved...~n")
                                (send world destroy-entity (list-ref args 0)))
                            
                            ((string=? command  "spray")
                                ; (printf "destroy plant message recieved...~n")
                                (let ((e (send world get-entity (list-ref args 0))))
                                    ; it's possible to get spray events before the 
                                    ; plant has been created...
                                    (when e
                                        (send e spray world (string->number (list-ref args 1)) 
                                            (string->number (list-ref args 2))))))
                            (else
                                (printf "unknown command ~a ~n" command)))))
                (send jab get-incoming))
            (send jab clear-incoming))
        
        (define/public (join-game world)
            (printf "ping~n")
            (send jab send-msg send-to "ping")
            (send jab send-msg send-to "join-game ")
            (set! wait-till (+ (flxtime) 5))
            (set! waiting #t))
        
        (define/public (update-plant world)      
            (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))))
                
                (send jab send-msg send-to (string-append "plant " (send world get-my-id) " "
                        (number->string (vx pos)) " "
                        (number->string (vy pos)) " "
                        (number->string (vz pos)) " "
                        (number->string (vx col)) " "
                        (number->string (vy col)) " "
                        (number->string (vz col)) " " 
                        desc-str))))
        
        (define/public (destroy-plant world id)
            (send jab send-msg send-to (string-append "destroy-plant " id))
            (send world destroy-entity id))
        
        (define/public (spray world id flower type)
            (send jab send-msg send-to (string-append "spray " 
                    id " "
                    (number->string flower) " "
                    (number->string type))) " "
            (send (send world get-entity id) spray world flower type))
        
        (define/public (flower-update world id flower col)
            (send jab send-msg send-to (string-append "flower " 
                    id " "
                    (number->string flower) " "
                    (number->string (vx col))  " "
                    (number->string (vy col)) " "
                    (number->string (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 (flxtime)))
                (set! waiting #f)
                (send world make-my-plant) 
                (update-plant world))
            (dispatch world))
        
        (super-new)))



;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; things needed for the set

(define (build-shells obj count dist col)
    (when (not (zero? count))
        (with-state
            (parent obj)
            (colour col)
            (let ((shell (build-copy obj)))
                (with-primitive shell                    
                    (pdata-map!
                        (lambda (p n)
                            (vadd p (vmul (vector 0 1 0) dist)))
                        "p" "n"))
                (build-shells shell (- count 1) dist (vmul col 1))))))

(define (build-shrub p n)
    (with-state
        (translate p)
        (colour (vector 0.5 0.7 0.4))
        (let ((shrub (build-ribbon (+ (random 10) 2))))
            (with-primitive shrub
                (pdata-index-map!
                    (lambda (i p)
                        (let ((j (* 0.2 (* i 0.2))))
                            (vector (* (crndf) j) (* i 0.2) (* (crndf) j))))
                    "p")
                (pdata-index-map!
                    (lambda (i w)
                        (* (/ 1 (+ i 1)) 0.2))
                    "w")))))

(define (choose l)
    (list-ref l (random (length l))))

(define (build-flower p n obj)
    (with-state 
        (backfacecull 0)
        (hint-depth-sort)
        ;        (hint-unlit)
        (translate p)
        (rotate (vector 0 (random 360) 0))
        (scale (+ 1 (* (rndf) 1.5)))
        (texture (load-texture (choose (list 
                        "textures/bgplant-1.png"
                        "textures/bgplant-2.png"
                        ;"textures/bgplant-3.png"
                        "textures/bgplant-4.png"
                        "textures/bgplant-5.png"
                        "textures/bgplant-6.png"
                        ))))
        (let ((o (build-copy obj)))
            (with-primitive o (hide 0)))
        ;        (load-primitive "meshes/freeplant.obj")
        ))

(define (load-model tex obj)
    (with-state
        (texture (load-texture (string-append "textures/" tex)))
        (load-primitive (string-append "meshes/" obj))))

(define (build-set)
    (with-state                
        (let ((l (make-light 'spot 'free)))
            (light-diffuse 0 (vector 0 0 0))
            (light-diffuse l (vector 1 1 1))
            (light-position l (vector 0 10 0))
            (light-direction l (vector 0 -1 0))
            (light-spot-angle l 55)
            (light-spot-exponent l 1))
        
        (let ((l2 (make-light 'point 'free)))
            (light-position l2 (vector 0 20 0))
            (light-diffuse l2 (vector 0.4 0.9 0.5)))
        
        (with-state
            (backfacecull 0)
            (hint-depth-sort)
            (hint-unlit)
            (texture-params 0 '(wrap-s repeat wrap-t repeat))
            (load-model "bgplant-1.png" "plant-0.obj")
            (load-model "bgplant-1.png" "plant-1.obj")
            (load-model "bgplant-1.png" "plant-2.obj")
            (load-model "bgplant-1.png" "plant-3.obj")
            (load-model "bgplant-1.png" "plant-4.obj")
            (load-model "bgplant-1.png" "plant-5.obj")
            (load-model "bgplant-1.png" "plant-6.obj")
            ;    (load-model "bgplant-2.png" "plant-7.obj")
            
            )
        
        (with-state
            (backfacecull 0)
            (load-model "car-base.png" "car.obj")
            (load-model "car-base.png" "car-2.obj")
            (load-model "telly-base.png" "telly-2.obj"))
        
        (with-state
            (load-model "telly-base2.png" "telly-0.obj")     
            (load-model "telly-base.png" "telly-1.obj")
            (load-model "telly-base.png" "telly-2.obj")
            (load-model "telly-base.png" "telly-3.obj")
            (load-model "telly-base.png" "telly-4.obj"))
        
        
        (with-state
            (load-model "washer-base.png" "washer-0.obj")
            (load-model "washer-base.png" "washer-1.obj")
            (load-model "washer-base.png" "washer-2.obj")
            (load-model "washer-base.png" "washer-3.obj"))
        
        (let ((terrain (with-state
                        (texture (load-texture "textures/ground-base.png"))
                        (load-primitive "meshes/ground.obj")))
                (flower-obj (load-primitive "meshes/freeplant.obj")))
            
            ;(define grassmap (load-primitive "textures/set-grass.png"))
            
            #;(define (tx->pi tx)
                (+ (vy tx) (* (vx tx) (pixels-width))))
            
            
            (with-primitive flower-obj
                (pdata-map!
                    (lambda (n p)
                        (vnormalise p))
                    "n" "p")
                (hide 1))
            
            
            (with-state
                (backfacecull 0)
                (hint-depth-sort)
                (hint-unlit)
                (translate (vector -15 2 10))
                (scale 15)
                (texture (load-texture "textures/bgplant-1.png"))
                (let ((o (build-copy flower-obj)))
                    (with-primitive o (hide 0))))
            
            
            (with-primitive terrain
                (poly-for-each-tri-sample    
                    (lambda (indices bary)
                        (let ((tc (vadd 
                                        (vmul (pdata-ref "t" (list-ref indices 0)) (vx bary))
                                        (vmul (pdata-ref "t" (list-ref indices 1)) (vy bary))
                                        (vmul (pdata-ref "t" (list-ref indices 2)) (vz bary)))))
                            (when (zero? (random 2)) #;(> (va (with-primitive grassmap (pdata-ref "c" (tx->pi tc)))) 0.5)                                
                                (let ((pos (vadd 
                                                (vmul (pdata-ref "p" (list-ref indices 0)) (vx bary))
                                                (vmul (pdata-ref "p" (list-ref indices 1)) (vy bary))
                                                (vmul (pdata-ref "p" (list-ref indices 2)) (vz bary)))))
                                    (when (> (vmag pos) 3)
                                        (build-flower pos (vector 0 1 0) flower-obj))))))
                    1))
            
            (let ((shell0 (build-copy terrain)))
                
                (with-primitive shell0
                    (pdata-copy "t" "t1")
                    (pdata-map!
                        (lambda (t)
                            (vmul t 4))
                        "t"))
                
                (with-state
                    (multitexture 0 (load-texture "textures/shell.png"))
                    ;    (multitexture 1 (load-texture "textures/ground-grassmap.png"))
                    (build-shells shell0 4 0.05 (vector 1 0.5 1)))))))

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

(clear)

(clear-colour (vmul (vector 0.4 0.9 0.5) 0.2))
(fog (vector 0.4 0.9 0.5) 0.01 1 100)

(define set-root (with-state 
        (scale 2) 
        (rotate (vector 0 -100 0))
        (build-locator)))

(when (not minimal-mode)
    (with-state
        (parent set-root)
        (build-set)))

(hint-depth-sort)

(define camera (build-locator))
(with-primitive camera
    (translate (vector 0 5 0)))

(lock-camera camera)

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

(send n start)

(send n join-game w)

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

(every-frame (animate))