FoAM/groworld
12
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

Merge branch 'master' of ssh://nik@fo.am/var/git/groworld

Browse source
This commit is contained in:
nik gaffney 2009-07-09 10:28:59 +02:00
commit f111c2c04d
1 changed files with 72 additions and 18 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

90
plant-eyes/plant-eyes.scm
View file

@ -40,7 +40,7 @@
(define twig-jitter 0.1)
(define branch-jitter 0.5)
(define max-twig-points 10)
(define start-twig-width 0.1)
(define start-twig-width 0.2)
(define default-max-twigs 10)
(define default-scale-factor 1.05)
(define default-grow-speed 1)
@ -685,8 +685,8 @@
(set! child-twig-ids (cons twig-id child-twig-ids)))
(define/pubment (grow point)
(let ((growing-noise (oa-load-sample (fullpath "snd/event01.wav"))))
(oa-play growing-noise (vector 0 0 0) (rndf) 0.3))
(let ((growing-noise (oa-load-sample (fullpath "snd/event01.wav"))))
(oa-play growing-noise (vector 0 0 0) (rndf) 0.3))
(inner (void) grow point))
(define/public (add-ornament point-index property)
@ -968,7 +968,7 @@
(widths '()))
(define/override (build)
(set! profile (build-circle-profile 5 1))
(set! profile (build-circle-profile 7 1))
(set! path (build-list num-points (lambda (n) (vector 0 0 0))))
(set! widths (build-list num-points (lambda (n) (if (eq? n (- num-points 1)) 0
(* radius (- 1 (/ n num-points)))))))
@ -1144,10 +1144,12 @@
(define game-view%
(class object%
(init-field
(controller #f))
(field
(plants '()) ; map of ids -> plants
(pickups '()) ; map of ids -> pickups
(camera (build-locator))
(player-plant-id #f)
(current-twig-id #f)
(camera-dist 1)
@ -1183,11 +1185,7 @@
"s"))
p)))
(define/public (setup)
(lock-camera camera)
(camera-lag 0.05)
(set-camera-position (vector 0 0 -1))
(define/public (setup)
(let ((l (make-light 'point 'free)))
(light-diffuse 0 (vector 0.5 0.5 0.5))
(light-diffuse l (vector 1 1 1))
@ -1253,13 +1251,10 @@
(if current-twig-id
(let ((twig (send (get-player) get-twig current-twig-id)))
(with-primitive camera
(identity)
(translate (vadd (send twig get-end-pos)
(send controller set-pos (vadd (send twig get-end-pos)
(vmul (send twig get-dir) (* camera-dist -2))
(vcross (send twig get-dir) (vector 0 1 0))))
))
(with-primitive camera (identity)))
(vcross (send twig get-dir) (vector 0 1 0)))))
(send controller set-pos (vector 0 0 0)))
@ -1368,14 +1363,72 @@
(super-new)))
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
(define controller%
(class object%
(field
(fwd (vector 0 0 1))
(up (vector 0 1 0))
(pos (vector 0 0 0))
(mtx (mident))
(cam (build-locator))
(tilt 0)
(yaw 0))
(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.1)
(clip 1 1000)
(set-camera-transform (mtranslate (vector 0 0 -1))))
(define/public (update)
(when (or (key-pressed "a") (key-special-pressed 100)) (set! yaw (+ yaw 1)))
(when (or (key-pressed "d") (key-special-pressed 102)) (set! yaw (- yaw 1)))
(when (or (key-pressed "w") (key-special-pressed 101)) (set! tilt (+ tilt 1)))
(when (or (key-pressed "s") (key-special-pressed 103)) (set! tilt (- tilt 1)))
; clamp tilt to prevent gimbal lock
(when (> tilt 88) (set! tilt 88))
(when (< tilt -88) (set! tilt -88))
(set! fwd (vtransform (vector 0 0 1)
(mmul
(mrotate (vector 0 yaw 0))
(mrotate (vector tilt 0 0)))))
(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)))
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
(clear)
(define c (make-object controller%))
(define gl (make-object game-logic%))
(define gv (make-object game-view%))
(define gv (make-object game-view% c))
(send c setup)
(send gv setup)
(send gl setup)
@ -1400,7 +1453,7 @@
(define (animate)
(when (and debounce (key-pressed " "))
(send plant1 add-twig (make-object twig-logic% 0 plant1 'root
(vtransform-rot (vector 0 0 -1) (minverse (get-camera-transform)))
(vmul (send c get-fwd) -1)
start-twig-width max-twig-points 'extruded))
(set! tick-time 0)
(set! debounce #f)
@ -1416,6 +1469,7 @@
(send gv update (pe-time) (pe-delta) (send gl update)))
(send gv update (pe-time) (pe-delta) '())
(send c update)
(pt-update))
#;(for ((i (in-range 0 10000)))