161 lines
6.1 KiB
Scheme
161 lines
6.1 KiB
Scheme
#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)
|
|
(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 -0.1)))
|
|
(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)))
|
|
|
|
;; zoom in/out
|
|
(when (key-pressed "-") (set-ortho-zoom 10))
|
|
(when (key-pressed "=") (set-ortho-zoom 100))
|
|
|
|
; 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)))
|