groworld/plant-eyes/scripts/controller.ss

;; p l a n t   e y e s  [ copyright (c) 2009 foam vzw : gpl v3 ]

#lang scheme/base
(require scheme/class 
  fluxus-016/fluxus 
  "logic.ss" 
  "view.ss"
  "sound.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)
	 (game-logic #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))
	 (debounce-space #t)
	 (seed-return #f)
	 (seed-return-timer 0)
	 (seed-return-secs-per-point 3)
	 (twig-stack '())
	 (above-ground #f)
	 (cam-pos (vector 0 0 0))
	 (sent-welcome-text #f)   
	 (sent-return-text #f)   
	 (sent-growing-text #f)
	 (iso-view #f)  
 	 (debounce-i #t))
   
    (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)
	  (send game-logic set-stones (send game-view get-stones))
      (lock-camera cam)
      (camera-lag 0)
	  (send game-view set-cam cam)
      (set-camera-transform (mtranslate (vector 0 0 -4))))
	
    (define/public (update t d)
	
	  (when (not sent-welcome-text)
	  	(send game-view display "going to your seed" 4)
	  	(send game-view display "you are now inside your seed" 4)
	  	(send game-view display "look around with your cursor keys" 4)
	  	(send game-view display "hold down space to grow" 4)
	  	(set! sent-welcome-text #t))

	  (if (or (key-pressed "i") (key-pressed "I"))
	    (when debounce-i 
		  (set! debounce-i #f)
	  	  (cond 
			((not iso-view)
	  			(set! iso-view #t)
			  	(ortho)
				(set-ortho-zoom -500)
				(set-camera-transform (mtranslate (vector 0 0 -40))))
			(else
	  			(set! iso-view #f)
				(persp)
				(set-camera-transform (mtranslate (vector 0 0 -4))))))
	     (set! debounce-i #t))

	
	
      (when (and (key-pressed " ") debounce-space (not current-twig-growing)
	  			; don't want the branch to be too small 
		      (if current-twig (> (send current-twig get-width-at-point current-point) 1) #t))
	      (set! seed-return #f)
	      (set! debounce-space #f)
		  (set! last-pos pos)
		  (send (send game-view get-plant (send player-plant get-id)) hide-twigs 0)

          (cond (current-twig  
		       (set! pos (vadd player-pos (send current-twig get-point current-point)))
               (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! twig-stack (cons (list current-point current-twig) twig-stack))
                 (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 (send player-plant get-twig-size) 'extruded))
               (send player-plant add-twig current-twig)
               (set! current-twig-growing #t)))
		  (send game-view set-grow-mode-on (send current-twig get-num-points))
		  
		  (when (not sent-growing-text)
	  		(send game-view display "growing..." 4)
	  		(send game-view display "keep holding space to go forward" 4)
	  		(send game-view display "use your cursor keys to steer" 4)
	  		(send game-view display "look for nutrients in the soil" 4)
	  		(send game-view display "nutrients allow you to grow further" 4)
	  		(set! sent-growing-text #t)))
			   
	  (when (and (key-pressed " ") current-twig-growing)	  
	    (let ((vel (vmul fwd (* d -3))))
		  (cond ((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 game-view scrub-marker) 		
		  		(send player-plant grow (vsub pos player-pos))))
			(else
				(play-sound 'growth-collide-with-stone pos)))))

				
	  (when (and (not current-twig-growing) (not (key-pressed " ")))
	     (set! debounce-space #t))
      
      (when (or (key-pressed "a") (key-pressed "A") (key-special-pressed 100)) (set! yaw (+ yaw 2)))
      (when (or (key-pressed "d") (key-pressed "D") (key-special-pressed 102)) (set! yaw (- yaw 2)))
      (when (or (key-pressed "w") (key-pressed "W") (key-special-pressed 101)) (set! tilt (- tilt 2)))
      (when (or (key-pressed "s") (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 seed-return
		  (when (not sent-return-text)
	  		(send game-view display "returning to your seed..." 4)
	  		(send game-view display "look around with your cursor keys" 4)
	  		(send game-view display "hold space to grow a new branch" 4)
	  		(set! sent-return-text #t))
			
	  	  (cond ((< current-point 2)
		      (cond ((null? twig-stack)
			  	  (play-sound 'back-in-seed pos)
	              (set! current-twig #f)
    	          (set! pos player-pos) 
				  (send (send game-view get-plant (send player-plant get-id)) hide-twigs 1)
				  (set! seed-return #f))
			   (else
            	 (set! current-point (car (car twig-stack)))
             	 (set! current-twig (cadr (car twig-stack)))
				 (set! twig-stack (cdr twig-stack)))))
			     
			(else
		 (set! seed-return-timer (- seed-return-timer d))
		 (let* ((p (vadd player-pos (vmix (send current-twig get-point current-point)
		 							     (send current-twig get-point (- current-point 1))
										 (/ seed-return-timer seed-return-secs-per-point))))
			   (d (vnormalise (vsub (send current-twig get-point (- current-point 1)) 
			   		(send current-twig get-point current-point))))
			   (dd (vnormalise (vcross d (vector 0 1 0))))
			   (r (vmul (vnormalise (vcross dd d)) (* 2 
			   		(lerp (send current-twig get-width-at-point current-point)
	    				  (send current-twig get-width-at-point (- current-point 1))
						  (/ seed-return-timer seed-return-secs-per-point)
						  )))))
			(set! pos (vadd p r)))
			   
		 (when (< seed-return-timer 0)
		    (set! seed-return-timer seed-return-secs-per-point)
			(set! current-point (- current-point 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
     (when (and current-twig-growing (not (send current-twig growing?)))
	 	 (play-sound 'finished-growing-twig pos)
		 (send game-view set-grow-mode-off)
         (set! current-twig-growing #f)			
		 (set! seed-return #t)
         (set! current-point (- (send current-twig get-num-points) 1)))

	  (cond
	  	((and (not above-ground) (> (vy (vadd player-pos pos)) 0))
			(set! above-ground #t)
			(send game-view above-ground))
		((and above-ground (< (vy (vadd player-pos pos)) 0))
			(set! above-ground #f)
			(send game-view below-ground)))

      (let* ((side (vnormalise (vcross up fwd)))
             (up (vnormalise (vcross fwd side))))
        
		(set! cam-pos (vlerp cam-pos pos 0.9))
		
		(oa-set-head-pos cam-pos fwd)
		
        (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 cam-pos) (vy cam-pos) (vz cam-pos) 1)))))
    
    (super-new)))