groworld/plant-eyes/controller.ss

#lang scheme/base
(require scheme/class fluxus-016/fluxus "logic.ss" "view.ss")
(provide (all-defined-out))

; reads input events and tells the logic side what to do

(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 (not current-twig-growing)
      (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)))