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)
     (player-pos (vector 0 0 0))
	 (last-pos (vector 0 0 0)))   
    
    (define/public (set-player-plant s)
      (set! pos (send s get-pos))
      (set! player-pos (send s get-pos))
      (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))))
    
	    ; moveme
    (define (collide? line objs)
        (foldl
         (lambda (ob r)
           (if r r
               (with-primitive ob
                               (cond ((bb/point-intersect? (cadr line) 0)
                                      (cond
                                        ((not (null? (geo/line-intersect 
                                                      (car line) (cadr line))))
                                         #t)                                        
                                        (else #f)))
                                     (else #f)))))
                                      
         #f
         objs))

	
	
    (define/public (update t d)
      (when (and (key-pressed " ") (not current-twig-growing))
	      (set! last-pos pos)
          (cond (current-twig      
               (let ((new-twig (send player-plant add-sub-twig current-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 (and (key-pressed "f") current-twig-growing)	  
	  (let ((vel (vmul fwd (* d -3))))
		  (when 
            (not (collide? (list pos (vadd pos vel)) (send game-view get-stones)))
  	  	    (set! pos (vadd pos vel))
		    (when (> (vdist last-pos pos) (send current-twig get-dist))
		  		(set! last-pos pos)		  		
		  		(send player-plant grow (vsub pos player-pos))))))
      
      (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 "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 "z")
          (cond (current-twig
                 (set! current-point (- current-point 1))
                 (when (< current-point 2)
                   (set! current-twig #f)
                   (set! pos player-pos)
                   #;(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 (vadd player-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 (vadd player-pos (vsub (send twig-view get-end-pos) 
                                   (vmul (send current-twig get-dir) 1))))))
               (when (not (send current-twig growing?))
                 (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)))