camera fixes, ready for v3

plant-eyes/plant-eyes.scm

@@ -1,5 +1,5 @@
-#lang scheme/base
+;#lang scheme/base
-(require fluxus-016/drflux)
+;(require fluxus-016/drflux)
 (require scheme/class)
 
 ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -33,14 +33,18 @@
 ;   side - eg. lsystem, or different methods per plant (or per twig even)
 
 (define debug-messages #f) ; prints out all the messages sent to the renderer
+(define logic-tick 1) ; time between logic updates
 
-(define branch-probability 5) ; as in one in branch-probability chance
+(define branch-probability 2) ; as in one in branch-probability chance
 (define branch-width-reduction 0.5)
 (define twig-jitter 0.5)
 (define branch-jitter 1)
-(define max-twig-points 40)
+(define max-twig-points 10)
 (define start-twig-width 0.1)
-(define default-max-twigs 5)
+(define default-max-twigs 10)
+(define default-scale-factor 1.05)
+(define default-grow-speed 1)
+(define root-camera-time (* default-max-twigs logic-tick))
 
 ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 ; a message for sending betwixt logic and render side
@@ -105,14 +109,15 @@
      (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
+     (render-type 'extruded) ; the way to tell the view to render this twig
+     (dist 1))               ; distance between points          
     
     (field
      (points '())     ; the 3d points for this twig
      (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
-     (last-point (vector 0 0 0))
+     (last-point (vector 0 0 0)) ; distance between points     
-     (dist 1))             ; distance between points     
+     (branch #f))       ; are we a main branch twig?
     
     (inherit send-message)
     
@@ -137,19 +142,22 @@
     (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 (scale a)
       (set! width (* width a))
-      (set! dist (* dist a))
+      (set! dist (* dist a)))
-      (printf "~a~n" dist))
     
     (define/public (grow)
       (when (< (length points) num-points)
         (let ((new-point (if (zero? (length points))
-                             (vector 0 0 0) ; first point should be at the origin
+                             ; first point should be at edge of the seed if we are a branch
-                             (vadd last-point (vmul dir dist) (vmul (srndvec) twig-jitter)))))
+                             (if branch (vmul dir dist) (vector 0 0 0))
+                             (vadd last-point (vmul dir dist) (vmul (srndvec) (* dist twig-jitter))))))
           (set! last-point new-point)
           (set! points (append points (list new-point)))
           (send-message 'twig-grow (list 
@@ -164,7 +172,8 @@
                       (vadd dir (vmul (srndvec) branch-jitter))
                       (* width branch-width-reduction)
                       (quotient num-points 2)
-                      render-type))))
+                      render-type
+                      dist))))
       (for-each
        (lambda (twig)
          (send (cadr twig) grow))
@@ -286,7 +295,7 @@
      (size 1)         ; the age of this plant
      (max-twigs default-max-twigs) ; the maximum twigs allowed at any time - oldest removed first
      (next-twig-id 0)
-     (grow-amount 1.1))
+     (grow-amount default-scale-factor))
     
     (inherit send-message)
     
@@ -337,9 +346,10 @@
       (send twig set-id! (get-next-twig-id))
       (set! size (* size grow-amount))
       (send twig scale size)  
+      (send twig set-branch! #t)
 
       (send-message 'grow-seed (list 
-                                (list 'pland-id id)
+                                (list 'plant-id id)
                                 (list 'amount grow-amount)))
       (send-message 'new-branch-twig (list 
                                (list 'plant-id id)
@@ -490,20 +500,29 @@
                     (- path-size 1)
                     in)))))
 
-(define (build-extrusion profile path)
+(define (build-tex-coords profile-size path-size vscale)
+  (pdata-index-map!
+   (lambda (i t)
+     (vector (* vscale (/ (quotient i profile-size) path-size))
+             (/ (modulo i profile-size) profile-size) 0))
+   "t"))
+
+(define (build-extrusion profile path tex-vscale)
     (let ((p (build-polygons (* (length profile) (length path)) 'quad-list)))
         (with-primitive p
             (poly-set-index (stitch-indices 0 (length profile) (length path) '()))
+            (build-tex-coords (length profile) (length path) tex-vscale)
             (extrude 0 profile path (vector 0 0 0))
             (recalc-normals 0))
         p))
 
 ; partial extrusions are for animating
 
-(define (build-partial-extrusion profile path)
+(define (build-partial-extrusion profile path tex-vscale)
     (let ((p (build-polygons (* (length profile) (length path)) 'quad-list)))
         (with-primitive p
-            (poly-set-index (stitch-indices 0 (length profile) (length path) '())))
+            (poly-set-index (stitch-indices 0 (length profile) (length path) '()))
+            (build-tex-coords (length profile) (length path) tex-vscale))
         p))
 
 (define (chop-front l n)
@@ -582,6 +601,9 @@
       (define/public (get-id)
         id)
       
+      (define/public (get-dir)
+        dir)
+      
       (define/public (build)
         0)
 
@@ -627,9 +649,8 @@
       (define/override (build)
         (set! root (let ((p (with-state
                        (translate pos)
-                       ;(hint-unlit)
                        (colour (vector 0.8 1 0.6))
-                       ;(concat (maim dir (vector 0 0 1)))
+                       (texture (load-texture "textures/root.png")) 
                        (build-ribbon num-points))))
                (with-primitive p
                                (pdata-map! 
@@ -673,33 +694,31 @@
 (define extruded-twig-view%
     (class twig-view%
       
-      (inherit-field index radius num-points pos)
+      (inherit-field index radius num-points pos dir)
       
       (field
        (profile '())
        (path '())
        (root 0)
        (v (vector 0 0 0))
-       (grow-speed 2)
+       (grow-speed default-grow-speed)
        (anim-t 0))
       
       (define/override (build)
        (set! profile (build-circle-profile 5 radius))
-       (set! path (build-list num-points (lambda (_) (vector 0 0 0))))
+       (set! path (build-list num-points (lambda (n) (vector 0 0 0))))
        (set! root (let ((p (with-state
+                            (backfacecull 0)
                        (translate pos)
                        (colour (vector 0.8 1 0.6))
-                       (texture (load-texture "textures/skin.png")) 
+                       (texture (load-texture "textures/root.png")) 
-                       ;(hint-unlit)
+                       (build-partial-extrusion profile path 6))))
-                       ;(concat (maim dir (vector 0 0 1)))
-                       (build-partial-extrusion profile path))))
                p)))
       
       (define/override (get-root)
         root)
       
       (define/override (get-point point-index)
-        (when (> point-index index) (error "asked for point before we've set it"))
         (list-ref path point-index))
             
       (define (list-set l c s)
@@ -708,6 +727,7 @@
               (else (cons (car l) (list-set (cdr l) (- c 1) s)))))
       
       (define/override (grow point)
+        (when (zero? index) (set! path (list-set path index point)))
         (set! path (list-set path (+ index 1) point))
         (set! anim-t 0)
         (set! v (partial-extrude root index v profile path))
@@ -746,6 +766,7 @@
                (opacity 0.6)
                (colour (vector 0.8 1 0.6))
                (hint-depth-sort)
+               (scale 0.5)
                (hint-unlit)
                (load-primitive "meshes/seed.obj"))))
         
@@ -796,6 +817,9 @@
       (define/public (grow-twig twig-id point)
         (send (get-twig twig-id) grow point)) 
       
+      (define/public (grow-seed amount)
+        (with-primitive seed (scale amount)))
+      
       (define/public (update t d)
         
         (with-primitive seed
@@ -811,8 +835,10 @@
 ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
 (define (build-env-box top bottom left right front back)    
+  (let ((p (build-locator)))
+    (with-state
+     (parent p)
   (hint-unlit)  
-  (scale 40)
   (with-state
         (texture (load-texture top))
         (translate (vector 0 0.5 0))
@@ -847,7 +873,8 @@
         (texture (load-texture bottom))
         (translate (vector 0 -0.5 0))
         (rotate (vector 90 0 0))
-        (build-plane)))
+        (build-plane))
+    p)))
 
 (define game-view%
   (class object%
@@ -856,18 +883,21 @@
      (camera (build-locator))
      (player-plant-id #f)
      (current-twig-id #f)
+     (camera-dist 1)
+     (env-root (with-state (scale 20) (build-locator)))
+     (root-camera-t 0)
      (upper-env (with-state
+                 (parent env-root)
                  (hint-depth-sort)
                  (colour 2)
-                 (scale 5)                 
+                 (translate (vector 0 0.28 0))
-                 (translate (vector 0 20.01 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)
-                 (scale 4.9)                 
+                 (translate (vector 0 -0.22001 0))
-                 (translate (vector 0 -20 0))
                  (build-env-box "textures/bottom-trans.png" "textures/bottom.png" 
                                 "textures/sleft.png" "textures/sright.png"
                                 "textures/sfront.png" "textures/sback.png")))
@@ -889,15 +919,16 @@
     (define/public (setup)
       (lock-camera camera)
       (camera-lag 0.05)      
+      (set-camera-position (vector 0 0 -1))
       
       (let ((l (make-light 'point 'free)))
-      (light-diffuse 0 (vector 0 0 0))
+      (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 (vector 0.1 0.3 0.2))
 
-      (fog (vector 0.2 0.5 0.3) 0.01 1 100))
+      (fog (vector 0.2 0.5 0.3) 0.02 1 100))
 
     (define/public (get-player)
       (get-plant player-plant-id))
@@ -911,7 +942,8 @@
     
     (define/public (add-branch-twig plant-id twig)
       (when (eq? plant-id player-plant-id)
-        (set! current-twig-id (send twig get-id)))
+        (set! current-twig-id (send twig get-id))
+        (set! root-camera-t 0))
       (send (get-plant plant-id) add-branch-twig twig))
     
     (define/public (destroy-branch-twig plant-id twig-id)
@@ -920,6 +952,13 @@
     (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)
+      (when (eq? plant-id player-plant-id)
+        (set! camera-dist (* camera-dist amount))
+        (with-primitive env-root (scale amount))
+        #;(fog (vector 0.2 0.5 0.3) (* 0.01 (* amount amount amount)) 1 100))      
+      (send (get-plant plant-id) grow-seed amount))
+    
     (define/public (update t d messages)      
                         
       (for-each 
@@ -927,13 +966,24 @@
          (send (cadr plant) update t d))
        plants)
       
-      (when current-twig-id
+      (if current-twig-id
         (let ((twig (send (get-player) get-twig current-twig-id)))
           (with-primitive camera
                           (identity)
-                          (translate (send twig get-end-pos)))))
+                          (translate (vadd (send twig get-end-pos) 
+                                           (vmul (send twig get-dir) (* camera-dist -2))
+                                           (vcross (send twig get-dir) (vector 0 1 0))))
+                          ))
+        (with-primitive camera (identity)))
       
       
+      
+      (when (> root-camera-t root-camera-time)
+        ;(set-camera-position (vector 0 0 (- camera-dist)))
+        (set! current-twig-id #f))
+      
+      (set! root-camera-t (+ root-camera-t d))
+      
       (when debug-messages
         (for-each
          (lambda (msg)
@@ -952,6 +1002,10 @@
                          (send msg get-data 'plant-id) 
                          (send msg get-data 'pos)) #f))    
            
+           ((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)))
            
@@ -1023,36 +1077,42 @@
 (send gv setup)
 
 (define plant1 (make-object plant-logic% "dave@fo.am" (vector 0 0 0)))
-(define plant2 (make-object plant-logic% "plant00001@fo.am" (vector 60 0 0)))
+(define plant2 (make-object plant-logic% "plant00001@fo.am" (vector 0 0 9)))
 
 (send gl add-player plant1)
 (send gl add-plant plant2)
 
-#;(send plant1 add-twig (make-object twig-logic% 0 plant1 'root (vector 0 -1 0) start-twig-width 10 'extruded))
 (send plant2 add-twig (make-object twig-logic% 0 plant2 'root (vector 0 -1 0) start-twig-width 10 'ribbon))
 
 (define tick-time 0)
-(define tick 0.5)
 (define debounce #t)
 (define debounce-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 (and debounce (key-pressed " "))
     (send plant1 add-twig (make-object twig-logic% 0 plant1 'root 
                         (vtransform-rot (vector 0 0 -1) (minverse (get-camera-transform))) 
-                        start-twig-width 20 'extruded))
+                        start-twig-width max-twig-points 'extruded))
+    (set! tick-time 0)
     (set! debounce #f)
-    (set! debounce-time (+ (flxtime) 0.2)))
+    (set! debounce-time (+ (pe-time) 0.2)))
             
-  (when (> (flxtime) debounce-time)
+  (when (> (pe-time) debounce-time)
     (set! debounce #t)) 
     
-  (when (< tick-time (flxtime))
+  (when (< tick-time (pe-time))
-    (set! tick-time (+ (flxtime) tick))
+    (set! tick-time (+ (pe-time) logic-tick))
     (send plant1 grow)
     (send plant2 grow)
-    (send gv update (flxtime) (delta) (send gl update)))
+    (send gv update (pe-time) (pe-delta) (send gl update)))
 
-  (send gv update (flxtime) (delta) '()))
+  (send gv update (pe-time) (pe-delta) '())
+  (pt-update))
 
 (every-frame (animate))