272 lines
9.4 KiB
Scheme
272 lines
9.4 KiB
Scheme
;; 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")
|
|
(require fluxus-016/joylisten)
|
|
|
|
(provide (all-defined-out))
|
|
|
|
; mapping for saitek p2600 joypad
|
|
(define joymap-a 0)
|
|
(define joymap-b 1)
|
|
(define joymap-c 2)
|
|
(define joymap-d 3)
|
|
(define joymap-e 8)
|
|
(define joymap-f 9)
|
|
(define joymap-l1 4)
|
|
(define joymap-l2 6)
|
|
(define joymap-r1 5)
|
|
(define joymap-r2 7)
|
|
(define joymap-select 11)
|
|
(define joymap-dpad 2)
|
|
(define joymap-lstick 0)
|
|
(define joymap-rstick 1)
|
|
|
|
(osc-source "4444")
|
|
|
|
; 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)
|
|
(joylisten (make-object joylisten%)))
|
|
|
|
(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 (any-joybutton)
|
|
(or (> (send joylisten get-button joymap-a) 0)
|
|
(> (send joylisten get-button joymap-b) 0)
|
|
(> (send joylisten get-button joymap-c) 0)
|
|
(> (send joylisten get-button joymap-d) 0)))
|
|
|
|
(define/public (update t d)
|
|
|
|
(send joylisten update)
|
|
|
|
(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 the left stick" 4)
|
|
(send game-view display "press button 1 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 (key-pressed "c")
|
|
(send game-logic clear))
|
|
|
|
(when (and (or (key-pressed " ") (any-joybutton)) 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 button 1 to go forward" 4)
|
|
(send game-view display "use the left stick 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 (or (key-pressed " ") (any-joybutton)) 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 (or (key-pressed " ") (any-joybutton))))
|
|
(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)))
|
|
|
|
(let ((x (vector-ref (send joylisten get-axis joymap-lstick) 1))
|
|
(y (vector-ref (send joylisten get-axis joymap-lstick) 0)))
|
|
(when (or (< x -0.1) (> x 0.1))
|
|
(set! yaw (- yaw x)))
|
|
(when (or (< y -0.1) (> y 0.1))
|
|
(set! tilt (+ tilt y))))
|
|
|
|
(let ((x (vector-ref (send joylisten get-axis joymap-rstick) 0))
|
|
(y (vector-ref (send joylisten get-axis joymap-rstick) 1)))
|
|
(when (or (< x -0.1) (> x 0.1))
|
|
(set! yaw (- yaw x)))
|
|
(when (or (< y -0.1) (> y 0.1))
|
|
(set! tilt (+ tilt y))))
|
|
|
|
; 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 the left stick" 4)
|
|
(send game-view display "press button 1 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)))
|