camera stuff

plant-eyes/plant-eyes.scm

@@ -1,5 +1,5 @@
-;#lang scheme/base
-;(require fluxus-016/drflux)
+#lang scheme/base
+(require fluxus-016/drflux)
 (require scheme/class)
 
 ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -40,7 +40,7 @@
 (define twig-jitter 0.1)
 (define branch-jitter 0.5)
 (define max-twig-points 10)
-(define start-twig-width 0.1)
+(define start-twig-width 0.2)
 (define default-max-twigs 10)
 (define default-scale-factor 1.05)
 (define default-grow-speed 1)
@@ -963,7 +963,7 @@
        (widths '()))
       
       (define/override (build)
-       (set! profile (build-circle-profile 5 1))
+       (set! profile (build-circle-profile 7 1))
        (set! path (build-list num-points (lambda (n) (vector 0 0 0))))
        (set! widths (build-list num-points (lambda (n) (if (eq? n (- num-points 1)) 0
                                                            (* radius (- 1 (/ n num-points)))))))
@@ -1139,10 +1139,12 @@
 
 (define game-view%
   (class object%
+    (init-field
+     (controller #f))
+    
     (field
      (plants '()) ; map of ids -> plants     
      (pickups '()) ; map of ids -> pickups
-     (camera (build-locator))
      (player-plant-id #f)
      (current-twig-id #f)
      (camera-dist 1)
@@ -1178,11 +1180,7 @@
                                 "s"))
                         p)))
     
-    (define/public (setup)
-      (lock-camera camera)
-      (camera-lag 0.05)      
-      (set-camera-position (vector 0 0 -1))
-      
+    (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))
@@ -1248,13 +1246,10 @@
       
       (if current-twig-id
         (let ((twig (send (get-player) get-twig current-twig-id)))
-          (with-primitive camera
-                          (identity)
-                          (translate (vadd (send twig get-end-pos) 
+          (send controller set-pos (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)))
+                                           (vcross (send twig get-dir) (vector 0 1 0)))))
+        (send controller set-pos (vector 0 0 0)))
       
       
       
@@ -1363,14 +1358,72 @@
 
     (super-new)))
 
+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
+(define controller%
+  (class object%
+    (field 
+     (fwd (vector 0 0 1))
+     (up (vector 0 1 0))
+     (pos (vector 0 0 0))
+     (mtx (mident))
+     (cam (build-locator))
+     (tilt 0)
+     (yaw 0))   
+    
+    (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.1)
+      (clip 1 1000)
+      (set-camera-transform (mtranslate (vector 0 0 -1))))
+    
+    (define/public (update)
+      (when (key-pressed "a") (set! yaw (+ yaw 1)))
+      (when (key-pressed "d") (set! yaw (- yaw 1)))
+      (when (key-pressed "w") (set! tilt (+ tilt 1)))
+      (when (key-pressed "s") (set! tilt (- tilt 1)))      
+      
+      ; clamp tilt to prevent gimbal lock
+      (when (> tilt 88) (set! tilt 88))
+      (when (< tilt -88) (set! tilt -88))
+      
+      (set! fwd (vtransform (vector 0 0 1) 
+                           (mmul 
+                            (mrotate (vector 0 yaw 0))
+                            (mrotate (vector tilt 0 0)))))
+      
+      (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 c (make-object controller%))
 (define gl (make-object game-logic%))
-(define gv (make-object game-view%))
+(define gv (make-object game-view% c))
 
+(send c setup)
 (send gv setup)
 (send gl setup)
 
@@ -1395,7 +1448,7 @@
 (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))) 
+                        (vmul (send c get-fwd) -1)
                         start-twig-width max-twig-points 'extruded))
     (set! tick-time 0)
     (set! debounce #f)
@@ -1411,6 +1464,7 @@
     (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)))