groworld/plant-eyes/plant-eyes.scm

;#lang scheme/base
;(require fluxus-016/drflux)
(require scheme/class)

;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; p l a n t   e y e s   
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

; notes:
;
; * keeping with a view/logic separation, although this is quite different to 
;   the hexagon game. the main advantages:
;     - just a divide and conquer strategy for staying sane 
;     - able to debug the logic without the view, or vice versa
;     - the logic can be ticked at a lower frequency - or even different 
;       parts at different rates, whereas the view needs ticking every frame
;
; * need to try to keep all the intensive 'every thing vs every thing' checking 
;   in the logic side, where it can be done over many frames (i'm thinking the
;   lags involved with things like nutrients getting absorbed may not matter 
;   too much in this game)
;
; * using a message passing system to formalise the passing of information on 
;   the logic side. this makes it possible to have objects sending messages
;   at any point, and have them automatically collected up and dispatched to 
;   the view
;
; * line segments are computed in the logic side, and can be represented any
;   way by the view - maybe the players plant will be geometry and everyone
;   elses will be ribbons (stoopid LOD)
;
; * in the same way, the line segments can be created in any way by the logic 
;   side - eg. lsystem, or different methods per plant (or per twig even)

(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 debug-messages #f) ; prints out all the messages sent to the renderer
(define logic-tick 0.5) ; time between logic updates

(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 default-grow-speed (/ 1 logic-tick))
(define root-camera-time (* max-twig-points logic-tick))
(define num-pickups 10)
(define pickup-dist-radius 200)
(define pickup-size 1)
(define max-ornaments 2) ; per twig
(define ornament-grow-probability 4)
(define curl-amount 40)
(define start-size 50)

(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)))))


(oa-start) ;; start openAL audio

;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; a message for sending betwixt logic and render 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)))

;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; 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 (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))))
      (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)))

;==============================================================================
;==============================================================================

(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)
    (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)))
       
       (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 start-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))))
                      
           ((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)))

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

(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 (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)))

;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    
(clear)
(define gl (make-object game-logic%))
(define gv (make-object game-view%))
(define c (make-object controller% gv))

(send c setup)
(send gv setup)
(send gl setup)

(define plant1 (make-object plant-logic% "dave@fo.am" (vector 0 0 0)))
(define plant2 (make-object plant-logic% "plant00001@fo.am" (vector 0 0 90)))

(send c set-player-plant plant1)
      
(send gl add-plant plant1)
(send gl add-plant plant2)

(send plant2 add-twig (make-object twig-logic% (vector 0 0 0) 0 plant2 'root (vector 0 -1 0) start-twig-width 10 'ribbon))

(define tick-time 0)

(define pt 0)
(define pd 0.02)
(define (pe-time) pt)
(define (pe-delta) pd)
(define (pt-update) (set! pt (+ pt pd)))

(define (animate)
    
  (when (< tick-time (pe-time))
    (set! tick-time (+ (pe-time) logic-tick))
    (send plant1 grow (vmul (send c get-fwd) -1))
    (send plant2 grow (vector 0 -1 0))
    (send gv update (pe-time) (pe-delta) (send gl update)))

  (send gv update (pe-time) (pe-delta) '())
  (send c update)
  (pt-update))

#;(for ((i (in-range 0 10000)))
     (animate))

(every-frame (animate))