1795 lines
60 KiB
Scheme
1795 lines
60 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
|
|
fluxus-016/shapes
|
|
"sound.ss"
|
|
"message.ss"
|
|
"list-utils.ss"
|
|
"ornament-views.ss"
|
|
"path-gen.ss")
|
|
|
|
(provide (all-defined-out))
|
|
|
|
; the fluxus code to make things look the way they do
|
|
|
|
(define debug-messages #f) ; prints out all the messages sent to the renderer
|
|
|
|
(define (ornament-colour) (vector 0.7 0.7 0.7))
|
|
(define (pickup-colour) (vector 1 1 1))
|
|
(define (earth-colour) (vector 0 0 0))
|
|
(define (dust-colour) (vmul (vector 0.05 0.05 0.05) (* 2 (rndf))))
|
|
(define (stones-colour) (vector 0.55 0.5 0.45))
|
|
(define (alive-colour) (vmul (vector 1 1 1) (+ 0.5 (* (rndf) 0.5))))
|
|
(define (worm-colour) (vmul (vector 1.0 0.8 0.8) (+ 0.5 (* (rndf) 0.5))))
|
|
(define (marker-colour) (vector 0.3 0.8 0.3))
|
|
(define (sky-colour) (vdiv (vector 170 153 135) 256))
|
|
|
|
(define wire-mode #f)
|
|
(define fog-col (earth-colour))
|
|
(define fog-strength 0.01)
|
|
(define default-grow-speed 0.5)
|
|
(define grow-overshoot 10)
|
|
|
|
(define above-fog-col (vector 0.9 0.9 1))
|
|
(define above-fog-strength 0.01)
|
|
(define ground-change-duration 4)
|
|
|
|
(define min-fin-len 3)
|
|
(define fin-length-var 4)
|
|
(define fin-grow-prob 200)
|
|
(define max-fins-per-twig 5)
|
|
|
|
(define max-twiglets-per-twig 10)
|
|
|
|
|
|
(define (pre-ripple)
|
|
(when (not (pdata-exists? "rip-pref"))
|
|
(pdata-copy "p" "rip-pref")))
|
|
|
|
(define (ripple t speed wave-length)
|
|
(pdata-map!
|
|
(lambda (p pref)
|
|
(vadd pref (vmul (srndvec)
|
|
(* 0.1 (+ 1 (sin (+ (* t speed) (* wave-length
|
|
(vdist (vtransform p
|
|
(minverse (get-transform)))
|
|
(vector 0 0 0))))))))))
|
|
"p" "rip-pref"))
|
|
|
|
(define (fract n)
|
|
(- n (floor n)))
|
|
|
|
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
|
|
(define dust%
|
|
(class object%
|
|
(field
|
|
(rate 1)
|
|
(above-ground #f)
|
|
(next-p 0)
|
|
(root (let ((p (with-state
|
|
(colour 0)
|
|
(hint-depth-sort)
|
|
(texture (load-texture "textures/particle.png"))
|
|
(build-particles 500))))
|
|
(with-primitive p
|
|
(pdata-map!
|
|
(lambda (c)
|
|
(vector 0 0 0 0.01))
|
|
"c")
|
|
(pdata-map!
|
|
(lambda (p)
|
|
(vmul (srndvec) 100))
|
|
"p")
|
|
(pdata-map!
|
|
(lambda (s)
|
|
(let ((s (* 4 (rndf))))
|
|
(vector s s s)))
|
|
"s")) p))
|
|
(emitter (with-state (build-locator)))
|
|
(pos (with-primitive root (vtransform (vector 0 0 0) (get-global-transform)))))
|
|
|
|
(define/public (set-above-ground s)
|
|
(set! above-ground s)
|
|
(with-primitive root
|
|
(colour (if s 1 0))
|
|
(pdata-map!
|
|
(lambda (c)
|
|
(if s (vector 1 1 1 0.01) (vector 0 0 0 0.01)))
|
|
"c")))
|
|
|
|
(define/public (update t d)
|
|
|
|
(let ((emitter-pos (with-primitive emitter
|
|
(identity)
|
|
(translate (vmul pos -1)) ; makes the particles relative to the centre of the plant
|
|
(concat (get-locked-matrix)) ; which makes the depth sorting work better
|
|
(translate (vector 0 0 -10))
|
|
(vtransform (vector 0 0 0) (get-transform)))))
|
|
|
|
(with-primitive root
|
|
(for ((i (in-range 0 rate)))
|
|
(pdata-set! "p" next-p (vadd emitter-pos (vmul (srndvec) 10)))
|
|
(pdata-set! "c" next-p (if above-ground (vector 1 1 1 0.01) (vector 0 0 0 0.01)))
|
|
(pdata-set! "s" next-p (let ((s (* 4 (rndf)))) (vector s s s)))
|
|
(set! next-p (+ next-p 1)))
|
|
(pdata-op "*" "c" 1.01)
|
|
(pdata-op "*" "s" 0.995))))
|
|
|
|
(super-new)))
|
|
|
|
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
|
|
(define insect-view%
|
|
(class object%
|
|
(init-field
|
|
(id 0)
|
|
(from (vector 0 0 0))
|
|
(type 'none))
|
|
|
|
(field
|
|
(to from)
|
|
(from-dir (vector 0 0 0))
|
|
(to-dir (vector 0 0 0))
|
|
(time 0)
|
|
(tick 1)
|
|
(speed 0)
|
|
(idle-sound-time (+ 2 (* (rndf) 10))))
|
|
|
|
(define/public (move pos dur)
|
|
(set! from to)
|
|
(set! from-dir to-dir)
|
|
(set! to pos)
|
|
(set! to-dir (vnormalise (vsub from to)))
|
|
(set! time 0)
|
|
(set! tick dur))
|
|
|
|
(define/public (play-idle-sound pos)
|
|
(cond
|
|
((eq? type 'worm) (play-sound 'worm-idle pos))
|
|
((eq? type 'butterfly) (play-sound 'butterfly-idle pos))
|
|
((eq? type 'spider) (play-sound 'spider-idle pos))))
|
|
|
|
(define/public (update t d)
|
|
(set! time (+ time d)))
|
|
|
|
(define/public (do-tx t d)
|
|
(let* ((t (min (/ time tick) 1))
|
|
(h (hermite-tangent from to (vmul from-dir 2) (vmul to-dir 2) t)))
|
|
(translate (car h))
|
|
(when (< idle-sound-time 0)
|
|
(set! idle-sound-time (+ 2 (* (rndf) 10)))
|
|
(play-idle-sound (car h)))
|
|
(set! speed (vmag (cadr h)))
|
|
(concat (maim (vector 0 1 0) (vnormalise (cadr h)))))
|
|
|
|
(set! time (+ time d))
|
|
(set! idle-sound-time (- idle-sound-time d)))
|
|
|
|
(super-new)))
|
|
|
|
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
|
|
(define (add-blendshape key model)
|
|
(let ((b (load-primitive model))
|
|
(pname (string-append "p" (number->string key))))
|
|
(pdata-add pname "v")
|
|
(pdata-index-map!
|
|
(lambda (i p)
|
|
(with-primitive b (pdata-ref "p" i)))
|
|
pname)
|
|
(destroy b)))
|
|
|
|
(define (set-blendshape key)
|
|
(pdata-copy (string-append "p" (number->string key)) "p"))
|
|
|
|
(define spider-insect-view%
|
|
(class insect-view%
|
|
(inherit-field from to from-dir to-dir time tick speed)
|
|
(inherit do-tx)
|
|
|
|
(field
|
|
(root (let ((p (with-state
|
|
(hint-unlit)
|
|
(colour (vector 0 0 0))
|
|
(load-primitive "meshes/spider-1.obj"))))
|
|
(with-primitive p
|
|
(pdata-copy "p" "p0")
|
|
(add-blendshape 1 "meshes/spider-2.obj")
|
|
(add-blendshape 2 "meshes/spider-3.obj") p)))
|
|
(anim-t 0)
|
|
(anim-d (* 0.2 (rndf)))
|
|
(blendshape 0))
|
|
|
|
(define/override (update t d)
|
|
(with-primitive root
|
|
(set! anim-d (* 0.01 (/ 1 (max 0.0001 speed))))
|
|
(when (> anim-t anim-d)
|
|
(set! anim-t 0)
|
|
(set! blendshape (modulo (+ blendshape 1) 3))
|
|
(set-blendshape blendshape))
|
|
(identity)
|
|
(do-tx t d)
|
|
(rotate (vector 0 0 -90))
|
|
(scale 0.1))
|
|
(set! anim-t (+ anim-t d)))
|
|
|
|
(super-new)))
|
|
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
|
|
(define butterfly-insect-view%
|
|
(class insect-view%
|
|
(inherit-field from to from-dir to-dir time tick)
|
|
(inherit do-tx)
|
|
|
|
(field
|
|
(root (let ((p (with-state
|
|
(hint-unlit)
|
|
(colour 0)
|
|
(load-primitive "meshes/butterfly-body.obj"))))
|
|
(with-state
|
|
(colour (rndvec))
|
|
(parent p)
|
|
(hint-depth-sort)
|
|
(hint-unlit)
|
|
(backfacecull 0)
|
|
(texture (load-texture "textures/butterfly.png"))
|
|
(load-primitive "meshes/butterfly.obj")
|
|
(translate (vector 0 0.001 0))
|
|
(load-primitive "meshes/butterfly.obj")) p)))
|
|
|
|
(define/override (update t d)
|
|
(with-primitive root
|
|
(let ((a (* 90 (rndf))))
|
|
(with-primitive (car (get-children))
|
|
(rotate (vector 0 0 a)))
|
|
(with-primitive (cadr (get-children))
|
|
(rotate (vector 0 0 (- a)))))
|
|
(identity)
|
|
(do-tx t d)
|
|
(scale 1))
|
|
(set! time (+ time d)))
|
|
|
|
(super-new)))
|
|
|
|
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
|
|
(define worm-insect-view%
|
|
(class insect-view%
|
|
(inherit-field from to from-dir to-dir time tick)
|
|
|
|
(field
|
|
(hidden #t)
|
|
(from2 from)
|
|
(from-dir2 from-dir)
|
|
(root (let ((p (build-ribbon 20)))
|
|
(with-primitive p
|
|
(translate (vector 0 0 -0.1))
|
|
(hint-depth-sort)
|
|
;(hint-unlit)
|
|
(colour (worm-colour))
|
|
(texture (load-texture "textures/worm.png"))
|
|
(let ((width (+ 0.5 (* 0.5 (rndf)))))
|
|
(pdata-index-map!
|
|
(lambda (i w)
|
|
width #;(+ 0.05 (* (abs (sin (* i 0.5))) 0.1)))
|
|
"w"))
|
|
#;(pdata-map!
|
|
(lambda (c)
|
|
(vector 1 1 1))
|
|
"c"))
|
|
p)))
|
|
|
|
(define/override (move pos dur)
|
|
(set! from2 from)
|
|
(set! from to)
|
|
(set! from-dir2 from-dir)
|
|
(set! from-dir to-dir)
|
|
(set! to pos)
|
|
(set! to-dir (vmul (vsub to from) 5))
|
|
(set! time 0)
|
|
(set! tick dur))
|
|
|
|
(define/override (update t d)
|
|
(let ((nt (/ time tick))) ; normalise time
|
|
(when (< nt 1)
|
|
(with-primitive root
|
|
(pdata-index-map!
|
|
(lambda (i p)
|
|
(let ((st (- nt (* i 0.05))))
|
|
(if (< st 0)
|
|
(hermite from2 from (vmul from-dir2 2) (vmul from-dir 2) (+ st 1))
|
|
(hermite from to (vmul from-dir 2) (vmul to-dir 2) st))))
|
|
"p"))))
|
|
|
|
(set! time (+ time d)))
|
|
|
|
(super-new)))
|
|
|
|
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
|
|
(define (build-squiggle x y)
|
|
(let ((p (build-ribbon 15))
|
|
(x (/ x 10))
|
|
(y (/ y 10)))
|
|
(with-primitive p
|
|
(pdata-add "vel" "v")
|
|
(pdata-map!
|
|
(lambda (vel)
|
|
(vmul (srndvec) 0.1))
|
|
"vel")
|
|
(pdata-index-map!
|
|
(lambda (i p)
|
|
(vector (cos (/ i x)) (sin (/ i y)) (/ i (pdata-size))))
|
|
"p")
|
|
(pdata-index-map!
|
|
(lambda (i p)
|
|
(* 0.5 (sin (* 3.141 (/ i (pdata-size))))))
|
|
"w")
|
|
(pdata-map!
|
|
(lambda (c)
|
|
(vector 1 1 1))
|
|
"c")
|
|
(pdata-copy "p" "pref")
|
|
(recalc-bb))
|
|
p))
|
|
|
|
(define pickup-view%
|
|
(class object%
|
|
(init-field
|
|
(id -1)
|
|
(type 'none)
|
|
(pos (vector 0 0 0))
|
|
(highlit #f))
|
|
|
|
(field
|
|
(rot (vmul (rndvec) 360))
|
|
(root (let ((p (with-state
|
|
(translate pos)
|
|
(rotate rot)
|
|
(colour (pickup-colour))
|
|
(texture (load-texture "textures/spark.png"))
|
|
(shader "shaders/spark.vert.glsl" "shaders/spark.frag.glsl")
|
|
(hint-nozwrite)
|
|
(hint-frustum-cull)
|
|
(blend-mode 'src-alpha 'one)
|
|
(cond
|
|
((eq? type 'nutrient) (colour (vector 1 1 0.5)) (build-squiggle 2 2))
|
|
((eq? type 'leaf) (colour (vector 0.5 1 0.5)) (build-squiggle 2 4))
|
|
((eq? type 'horn) (colour (vector 0.5 1 1)) (build-squiggle 3 4))
|
|
((eq? type 'inflatoe) (colour (vector 1 0.5 0.5)) (build-squiggle 4 5))
|
|
((eq? type 'fork) (colour (vector 0.5 0.5 1)) (build-squiggle 5 2))
|
|
((eq? type 'flower) (colour (vector 1 0.5 0.75)) (build-squiggle 4 3))))))
|
|
(with-primitive p (shader-set! (list "BaseMap" 0))) p))
|
|
(from pos)
|
|
(destination (vector 0 0 0))
|
|
(speed 0.05)
|
|
(t -1)
|
|
(destroy-time -99)
|
|
(dissolve-time -99)
|
|
(delme #f))
|
|
|
|
(define/public (get-type)
|
|
type)
|
|
|
|
(define/public (pick-up point)
|
|
(set! destroy-time point))
|
|
|
|
(define/public (delme?)
|
|
delme)
|
|
|
|
(define/public (highlight)
|
|
(set! highlit #t))
|
|
|
|
(define/public (get-root)
|
|
root)
|
|
|
|
(define/public (move-to s)
|
|
(set! t 0)
|
|
(set! from pos)
|
|
(set! destination s))
|
|
|
|
(define/public (update t d)
|
|
|
|
(with-primitive root
|
|
(rotate (vector (* d (if highlit 50 10)) 0 0)))
|
|
|
|
(when (and highlit (eq? dissolve-time -99))
|
|
(with-primitive root
|
|
(pdata-map!
|
|
(lambda (p pref)
|
|
(vadd pref (vmul (srndvec) 0.1)))
|
|
"p" "pref")))
|
|
|
|
(when (> destroy-time -99)
|
|
(set! destroy-time (- destroy-time (* d default-grow-speed 0.5)))
|
|
(when (< destroy-time 0)
|
|
(set! destroy-time -100)
|
|
(set! dissolve-time 4)))
|
|
|
|
(when (> dissolve-time -99)
|
|
(set! dissolve-time (- dissolve-time d))
|
|
(with-primitive root
|
|
(pdata-op "+" "p" "vel")
|
|
(pdata-op "*" "w" 0.95))
|
|
(when (< dissolve-time 0)
|
|
(destroy root)
|
|
(set! delme #t)))
|
|
|
|
(set! t (+ t speed)))
|
|
|
|
(super-new)))
|
|
|
|
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
|
|
(define twig-view%
|
|
(class object%
|
|
(init-field
|
|
(id 0)
|
|
(pos (vector 0 0 0))
|
|
(type 'none)
|
|
(dir (vector 0 1 0))
|
|
(radius 1)
|
|
(num-points 0))
|
|
|
|
(field
|
|
(index 0)
|
|
(parent-twig-id -1)
|
|
(child-twig-ids '())
|
|
(ornaments '())
|
|
(col (vector 1 1 1))
|
|
(tex "")
|
|
(markers '())
|
|
(shrink-t 0)
|
|
(grow-t -1)
|
|
(marker-destroy-t 0)
|
|
(grow-speed default-grow-speed)
|
|
(delme #f))
|
|
|
|
(define/public (get-id) id)
|
|
(define/public (delme?) delme)
|
|
(define/public (get-dir) dir)
|
|
(define/public (set-dir! s) (set! dir s))
|
|
(define/public (set-col! s) (set! col s))
|
|
(define/public (set-tex! s) (set! tex s))
|
|
(define/public (get-pos) pos)
|
|
(define/public (build sp) 0)
|
|
(define/public (get-num-points) index)
|
|
(define/public (get-grow-t) grow-t)
|
|
(define/public (set-pos! s) (set! pos s))
|
|
(define/public (get-child-twig-ids) child-twig-ids)
|
|
(define/public (get-root) (error "need to overide this"))
|
|
(define/public (destroy-twig) (destroy (get-root)))
|
|
(define/public (set-parent-twig-id s) (set! parent-twig-id s))
|
|
(define/public (get-point point-index) (error "need to overide this"))
|
|
(define/public (get-width point-index) (error "need to overide this"))
|
|
(define/public (set-grow-speed s) (set! grow-speed s))
|
|
|
|
(define/public (add-child-twig-id twig-id)
|
|
(set! child-twig-ids (cons twig-id child-twig-ids)))
|
|
|
|
(define/public (growing?)
|
|
(< grow-t (+ num-points grow-overshoot)))
|
|
|
|
(define/public (start-growing)
|
|
(play-sound 'twig-start-growing
|
|
(with-primitive (get-root) (vtransform (vector 0 0 0) (get-global-transform))))
|
|
(set! grow-t 0)
|
|
(set! markers (cons (build-locator) markers)))
|
|
|
|
(define/pubment (start-shrinking)
|
|
(play-sound 'twig-start-decay
|
|
(with-primitive (get-root) (vtransform (vector 0 0 0) (get-global-transform))))
|
|
(set! shrink-t (if (growing?) grow-t (+ num-points grow-overshoot)))
|
|
(for-each
|
|
(lambda (o)
|
|
(send (cadr o) start-shrinking))
|
|
ornaments)
|
|
(inner (void) start-shrinking))
|
|
|
|
(define/pubment (add-point point width make-marker)
|
|
(when make-marker
|
|
(play-sound 'place-marker (vadd point (with-primitive (get-root)
|
|
(vtransform (vector 0 0 0) (get-global-transform)))))
|
|
(set! markers (append markers (list (let ((p (with-state
|
|
(parent (get-root))
|
|
(translate point)
|
|
(scale 0.001)
|
|
(colour (marker-colour))
|
|
(build-sphere 8 8)))) (with-primitive p (shader-set! (list "Pos" point))) p)))))
|
|
|
|
(inner (void) add-point point width make-marker))
|
|
|
|
(define/pubment (update-markers t d)
|
|
(for-each
|
|
(lambda (marker)
|
|
(with-primitive marker
|
|
(let ((sc (vmag (vtransform-rot (vector 0 1 0) (get-transform)))))
|
|
(when (< sc 0.1)
|
|
(scale (+ 1.0 (* d 1)))))))
|
|
markers))
|
|
|
|
(define/public (add-ornament point-index property)
|
|
(when (< point-index grow-t)
|
|
(play-sound 'twig-new-ornament
|
|
(vadd (get-point point-index)
|
|
(with-primitive (get-root) (vtransform (vector 0 0 0) (get-global-transform)))))
|
|
(with-state
|
|
(parent (get-root))
|
|
(let ((ornament (property->ornament property
|
|
(get-point point-index)
|
|
(get-width point-index)
|
|
(vnormalise (vsub (get-point point-index) (get-point (- point-index 1))))
|
|
col)))
|
|
(set! ornaments (cons (list point-index ornament) ornaments))))))
|
|
|
|
(define/pubment (set-excitations! a b)
|
|
(for-each
|
|
(lambda (ornament)
|
|
(send (cadr ornament) set-excitations! a b))
|
|
ornaments))
|
|
|
|
(define/pubment (update t d)
|
|
(inner (void) update t d)
|
|
|
|
(update-markers t d)
|
|
|
|
(when (> shrink-t 0)
|
|
(set! shrink-t (- shrink-t (* d grow-speed))))
|
|
|
|
(when (< shrink-t 0)
|
|
(set! delme #t))
|
|
|
|
(when (and (not (eq? grow-t -1)) (< grow-t (+ num-points grow-overshoot)))
|
|
(set! grow-t (+ grow-t (* d grow-speed)))
|
|
(when (and (not (null? markers)) (> 0 (- marker-destroy-t grow-t)))
|
|
#;(play-sound 'twig-eat-marker
|
|
(with-primitive (car markers) (vtransform (vector 0 0 0) (get-global-transform))))
|
|
(set! marker-destroy-t (+ 1 marker-destroy-t))
|
|
(destroy (car markers))
|
|
(set! markers (cdr markers))))
|
|
|
|
(when (> grow-t (+ num-points 10))
|
|
(set! grow-t 999)))
|
|
|
|
(super-new)))
|
|
|
|
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
|
|
(define ribbon-twig-view%
|
|
(class twig-view%
|
|
|
|
(inherit-field pos radius num-points index col tex grow-t grow-speed shrink-t)
|
|
(inherit growing?)
|
|
|
|
(field
|
|
(root 0)
|
|
(widths '())
|
|
(points '())
|
|
(global-growth 0)
|
|
(global-growth-time 20)
|
|
(finalised #f))
|
|
|
|
|
|
(define/override (build sp)
|
|
(set! grow-speed (* grow-speed 5))
|
|
(set! root (let ((p (with-state
|
|
(translate pos)
|
|
(hint-frustum-cull)
|
|
(colour col)
|
|
(hint-unlit)
|
|
(shader "shaders/ribbon.vert.glsl" "shaders/ribbon.frag.glsl")
|
|
(texture (load-texture "textures/ribbon-twig.png"))
|
|
(build-ribbon num-points))))
|
|
(with-primitive p
|
|
(shader-set! (list "Base" 0 "Origin" pos))
|
|
(pdata-map!
|
|
(lambda (w)
|
|
0)
|
|
"w")
|
|
(pdata-set! "w" 0 radius))
|
|
p)))
|
|
|
|
|
|
(define/override (get-root)
|
|
root)
|
|
|
|
(define/public (finalised?)
|
|
finalised)
|
|
|
|
#;(define/override (get-point point-index)
|
|
(with-primitive root
|
|
(pdata-ref "p" point-index)))
|
|
|
|
#;(define/override (get-width point-index)
|
|
(with-primitive root
|
|
(pdata-ref "w" point-index)))
|
|
|
|
(define/override (get-point point-index)
|
|
(list-ref points point-index))
|
|
|
|
(define/override (get-width point-index)
|
|
(list-ref widths point-index))
|
|
|
|
(define/augment (add-point point width make-marker)
|
|
#;(with-primitive root
|
|
(pdata-index-map! ; set all the remaining points to the end
|
|
(lambda (i p) ; in order to hide them
|
|
(if (< i index)
|
|
p
|
|
point))
|
|
"p"))
|
|
(set! widths (append widths (list width)))
|
|
(set! points (append points (list point)))
|
|
(set! index (+ index 1)))
|
|
|
|
(define/augment (start-shrinking)
|
|
(set! grow-speed (* grow-speed 3)))
|
|
|
|
(define/augment (update t d)
|
|
(when (and (> grow-t 0) (< grow-t (+ (length points) 10)))
|
|
(with-primitive root
|
|
(identity)
|
|
(translate pos)
|
|
(scale (/ global-growth global-growth-time))
|
|
(pdata-index-map!
|
|
(lambda (i w)
|
|
(* (/ global-growth global-growth-time)
|
|
(cond ((< i (- grow-t 1))
|
|
(list-ref widths i))
|
|
((< i grow-t)
|
|
(* (list-ref widths i) (fract grow-t)))
|
|
(else
|
|
0))))
|
|
"w")
|
|
|
|
(pdata-index-map!
|
|
(lambda (i p)
|
|
(cond ((< i (- grow-t 1))
|
|
(list-ref points i))
|
|
((equal? i (inexact->exact (floor (+ grow-t 1))))
|
|
(vmix
|
|
(list-ref points i)
|
|
(list-ref points (- i 1)) (fract grow-t)))
|
|
(else
|
|
(list-ref points i))))
|
|
"p")
|
|
(recalc-bb)))
|
|
|
|
(when (> shrink-t 0)
|
|
(with-primitive root
|
|
(identity)
|
|
(translate pos)
|
|
(scale (/ shrink-t (+ num-points grow-overshoot)))))
|
|
|
|
(when (and (not (growing?)) (not finalised))
|
|
(with-primitive root
|
|
(recalc-bb)
|
|
(hint-frustum-cull))
|
|
(set! finalised #t))
|
|
|
|
(when (< global-growth global-growth-time)
|
|
(set! global-growth (+ global-growth d))))
|
|
|
|
(super-new)))
|
|
|
|
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
|
|
; bunches of ribbon twigs
|
|
(define twiglets%
|
|
(class object%
|
|
(init-field
|
|
(par 0)
|
|
(col (vector 1 1 1))
|
|
(shape-params '(0 0)))
|
|
|
|
(field
|
|
(twigs '()))
|
|
|
|
(define/public (build pos dir width length)
|
|
(set! twigs (list (build-tree pos dir width length))))
|
|
|
|
(define (build-tree pos dir width length)
|
|
(let ((t (make-object ribbon-twig-view% 0 pos 'ribbon
|
|
dir
|
|
(* width (+ 0.5 (rndf))) length)))
|
|
(send t set-grow-speed 0.1)
|
|
(send t set-col! col)
|
|
(with-state
|
|
(parent par)
|
|
(send t build shape-params))
|
|
(let ((path-gen (make-object path-gen% (car shape-params) (cadr shape-params)
|
|
(vector 0 0 0) (send t get-dir)))
|
|
(ppos (vector 0 0 0)))
|
|
(for ((i (in-range 0 length)))
|
|
(let ((width (if (eq? i (- length 1)) 0 (/ width (+ i 1)))))
|
|
(send t add-point (send path-gen get-pos (* 5 width)) width #f))))
|
|
(send t start-growing)
|
|
t))
|
|
|
|
|
|
|
|
(define/public (update t d)
|
|
(for-each
|
|
(lambda (twig)
|
|
(send twig update t d)
|
|
(when (and
|
|
(< (length twigs) 10)
|
|
(> (send twig get-num-points) 5)
|
|
(zero? (random 400)))
|
|
(let ((pi (inexact->exact (floor (send twig get-grow-t)))))
|
|
(when (and (> pi 0) (< pi (send twig get-num-points)))
|
|
(set! twigs (cons
|
|
(build-tree
|
|
(vadd (send twig get-pos) (send twig get-point pi))
|
|
(send twig get-dir)
|
|
(/ (send twig get-width pi) 1.4)
|
|
(/ (send twig get-num-points) 2))
|
|
twigs))))))
|
|
twigs)
|
|
|
|
#;(set! twigs (filter
|
|
(lambda (twig)
|
|
(not (send twig finalised?)))
|
|
twigs)))
|
|
|
|
(define/public (start-shrinking)
|
|
(for-each
|
|
(lambda (twig)
|
|
(send twig start-shrinking))
|
|
twigs))
|
|
|
|
(super-new)))
|
|
|
|
|
|
|
|
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
|
|
(define fin%
|
|
(class object%
|
|
(init-field
|
|
(fin-size 1)
|
|
(twig-ob #f)
|
|
(col (vector 0 0 0))
|
|
(path-len 0)
|
|
(profile-len 0))
|
|
|
|
(field
|
|
(fin-len (min (- path-len 1) (+ min-fin-len (random fin-length-var))))
|
|
(root (build-polygons (* fin-len 2) 'triangle-strip))
|
|
(pos (random profile-len))
|
|
(start (* (random (- path-len fin-len)) profile-len))
|
|
(grow-t 0)
|
|
(grow-speed (* (rndf) 0.1)))
|
|
|
|
(define/public (build)
|
|
(with-primitive root
|
|
(parent twig-ob)
|
|
(texture (load-texture "textures/fin-roots.png"))
|
|
(hint-unlit)
|
|
(hint-depth-sort)
|
|
(colour col)
|
|
(backfacecull 0)
|
|
(pdata-index-map!
|
|
(lambda (i t)
|
|
(vector (/ (+ (quotient i 2) 1) (/ (pdata-size) 2)) (if (odd? i) 1 0) 0))
|
|
"t")))
|
|
|
|
(define/public (update t d)
|
|
(when (< grow-t 1)
|
|
(with-primitive root
|
|
(pdata-index-map!
|
|
(lambda (i p)
|
|
(let* ((ti (+ start pos (* (quotient i 2) profile-len)))
|
|
(tp (with-primitive twig-ob (pdata-ref "p" ti)))
|
|
(tn (with-primitive twig-ob (pdata-ref "n" ti))))
|
|
(if (even? i)
|
|
tp
|
|
(vadd tp (vmul tn (* grow-t fin-size))))))
|
|
"p"))
|
|
|
|
(set! grow-t (+ grow-t (* d grow-speed)))))
|
|
|
|
(super-new)))
|
|
|
|
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
|
|
(define extruded-twig-view%
|
|
(class twig-view%
|
|
|
|
(inherit growing?)
|
|
(inherit-field index radius num-points pos dir col tex grow-t shrink-t
|
|
ornaments grow-speed delme markers marker-destroy-t)
|
|
|
|
(field
|
|
(profile '())
|
|
(path '())
|
|
(root 0)
|
|
(widths '())
|
|
(fins '())
|
|
(twiglets '())
|
|
(finalised #f)
|
|
(shape-params '(0 0)))
|
|
|
|
(define/override (build sp)
|
|
(set! shape-params sp)
|
|
(set! profile (build-circle-points 7 1))
|
|
(set! path (build-list num-points (lambda (_) (vector 0 0 0))))
|
|
(set! widths (build-list num-points (lambda (_) 1)))
|
|
(set! root (let ((p (with-state
|
|
(backfacecull 1)
|
|
(when wire-mode
|
|
(hint-none)
|
|
(hint-wire))
|
|
(ambient (vmul col 0.5))
|
|
(shader "shaders/tree.vert.glsl" "shaders/tree.frag.glsl")
|
|
(texture (load-texture "textures/root-norm.png"))
|
|
(colour col)
|
|
(build-partial-extrusion profile path 3))))
|
|
(with-primitive p
|
|
(shader-set! (list "NormalMap" 0)))
|
|
|
|
p)))
|
|
|
|
(define/override (get-root)
|
|
root)
|
|
|
|
(define/override (get-point point-index)
|
|
(list-ref path point-index))
|
|
|
|
(define/override (get-width point-index)
|
|
(list-ref widths point-index))
|
|
|
|
(define/augment (start-shrinking)
|
|
(for-each
|
|
(lambda (o)
|
|
(send o start-shrinking))
|
|
twiglets))
|
|
|
|
(define (list-set l c s)
|
|
(cond ((null? l) '())
|
|
((zero? c) (cons s (list-set (cdr l) (- c 1) s)))
|
|
(else (cons (car l) (list-set (cdr l) (- c 1) s)))))
|
|
|
|
(define/augment (add-point point width make-marker)
|
|
(set! path (list-set path index point))
|
|
(set! widths (list-set widths index width))
|
|
(set! index (+ index 1)))
|
|
|
|
(define/augment (update t d)
|
|
|
|
(for-each
|
|
(lambda (ornament)
|
|
(send (cadr ornament) update t d))
|
|
ornaments)
|
|
|
|
|
|
(with-primitive root
|
|
(shader-set! (list "Time" t))
|
|
#;(let ((t (inexact->exact (round (fmod (* 5 t) 3)))))
|
|
(cond
|
|
((eq? t 0) (texture (load-texture "textures/cells-1.png")))
|
|
((eq? t 1) (texture (load-texture "textures/cells-2.png")))
|
|
((eq? t 2) (texture (load-texture "textures/cells-3.png"))))))
|
|
|
|
#;(when (and (zero? (random fin-grow-prob))
|
|
(< (length fins) max-fins-per-twig)
|
|
(not (growing?))
|
|
(> (length path) 1))
|
|
(let ((new-fin (make-object fin% (+ 0.3 (* radius (rndf))) root
|
|
(vmul col (rndf))
|
|
(length path) (length profile))))
|
|
(send new-fin build)
|
|
(set! fins (cons new-fin fins))))
|
|
|
|
#;(for-each
|
|
(lambda (fin)
|
|
(send fin update t d))
|
|
fins)
|
|
|
|
(for-each
|
|
(lambda (twiglet)
|
|
(send twiglet update t d))
|
|
twiglets)
|
|
|
|
(when (and (not (eq? grow-t -1)) (not (eq? grow-t 999)))
|
|
; randomly add twiglets as we are growing
|
|
(when (and (zero? (random 100))
|
|
(< grow-t num-points)
|
|
(> grow-t 3)
|
|
(< (length twiglets) max-twiglets-per-twig))
|
|
(let ((t (make-object twiglets% (get-root) col shape-params))
|
|
(pi (inexact->exact (floor grow-t))))
|
|
(send t build (get-point pi) dir (/ (get-width pi) 2) 20)
|
|
(set! twiglets (cons t twiglets))))
|
|
(with-primitive root
|
|
(partial-extrude grow-t profile path widths (vector 1 0 0) 0.05)))
|
|
|
|
(when (> shrink-t 0)
|
|
(with-primitive root
|
|
(partial-extrude shrink-t profile path widths (vector 1 0 0) 0.05)))
|
|
|
|
(when (and (not (growing?)) (not finalised))
|
|
(with-primitive root
|
|
(recalc-bb)
|
|
(hint-frustum-cull))
|
|
(set! finalised #t))
|
|
|
|
)
|
|
|
|
(define/public (get-end-pos)
|
|
(list-ref path (if (zero? index) 0 (- index 1)))
|
|
#;(with-primitive root (pdata-ref "p" (- (* index (length profile)) 1))))
|
|
|
|
(super-new)))
|
|
|
|
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
|
|
(define plant-view%
|
|
(class object%
|
|
|
|
(init-field
|
|
(id "none")
|
|
(pos (vector 0 0 0))
|
|
(size 0)
|
|
(col (vector 1 1 1))
|
|
(tex "")
|
|
(is-player #f)
|
|
(shape-params '(0 0)))
|
|
|
|
(field
|
|
(twigs '()) ; a assoc list map between ids and twigs stored flat here,
|
|
; for fast access, but prims heirachically in the scenegraph
|
|
(root (with-state
|
|
(translate pos)
|
|
(build-locator)))
|
|
(seed (let ((p (with-state
|
|
(parent root)
|
|
(shader "shaders/seed.vert.glsl" "shaders/seed.frag.glsl")
|
|
(texture (load-texture "textures/cells-1.png"))
|
|
(multitexture 1 (load-texture "textures/cells-2.png"))
|
|
(multitexture 2 (load-texture "textures/cells-3.png"))
|
|
(multitexture 3 (load-texture "textures/root-norm.png"))
|
|
(backfacecull 0)
|
|
(opacity 0.75)
|
|
(colour col)
|
|
(ambient (vmul col 0.5))
|
|
(hint-depth-sort)
|
|
(scale (* 0.06 size))
|
|
(when wire-mode
|
|
(hint-none)
|
|
(hint-wire))
|
|
;(hint-unlit)
|
|
(load-primitive "meshes/seed.obj"))))
|
|
(with-primitive p
|
|
(shader-set! (list "Maps" (list 0 1 2) "NormalMap" 3)))
|
|
p))
|
|
(dust (if is-player (with-state
|
|
(parent root)
|
|
(make-object dust%)) #f))
|
|
(nutrients (if (and #f is-player) (let ((p (with-state
|
|
;(hint-depth-sort)
|
|
(hint-nozwrite)
|
|
(hint-unlit)
|
|
(parent root)
|
|
(blend-mode 'src-alpha 'one)
|
|
(texture (load-texture "textures/smoke.png"))
|
|
(build-particles 100))))
|
|
(with-primitive p
|
|
(pdata-add "twig" "f")
|
|
(pdata-add "point" "f")
|
|
(pdata-add "offset" "v")
|
|
(pdata-add "speed" "f")
|
|
(pdata-map!
|
|
(lambda (point)
|
|
0)
|
|
"point")
|
|
(pdata-map!
|
|
(lambda (point)
|
|
(* 3 (+ 0.1 (rndf))))
|
|
"speed")
|
|
(pdata-map!
|
|
(lambda (offset)
|
|
(vector 0 0 0))
|
|
"offset")
|
|
(pdata-map!
|
|
(lambda (c)
|
|
(vector 1 1 1))
|
|
"c")
|
|
(pdata-map!
|
|
(lambda (p)
|
|
(vmul (vadd (crndvec) (vector 0 -1 0)) 900))
|
|
"p")
|
|
(pdata-map!
|
|
(lambda (s)
|
|
(vmul (vector 1 1 1) (+ 0.1 (rndf))))
|
|
"s"))
|
|
p) #f)))
|
|
|
|
(define/public (is-player?)
|
|
is-player)
|
|
|
|
(define/public (get-id)
|
|
id)
|
|
|
|
(define/public (get-col)
|
|
col)
|
|
|
|
(define/public (get-twig twig-id)
|
|
(let ((l (assq twig-id twigs)))
|
|
(if l
|
|
(cadr (assq twig-id twigs))
|
|
#f)))
|
|
|
|
(define/public (destroy-branch-twig twig-id)
|
|
(when (get-twig twig-id) ; might have destroyed itself already
|
|
(for-each
|
|
(lambda (twig-id)
|
|
(destroy-branch-twig twig-id))
|
|
(send (get-twig twig-id) get-child-twig-ids))
|
|
(send (get-twig twig-id) destroy-twig))
|
|
(set! twigs (assoc-remove twig-id twigs)))
|
|
|
|
(define/public (destroy-plant)
|
|
(destroy root)
|
|
(for-each
|
|
(lambda (twig)
|
|
(destroy-branch-twig (car twig)))
|
|
twigs))
|
|
|
|
(define/public (shrink-twig twig-id)
|
|
(send (get-twig twig-id) start-shrinking)
|
|
(for-each
|
|
(lambda (twig-id)
|
|
(shrink-twig twig-id))
|
|
(send (get-twig twig-id) get-child-twig-ids)))
|
|
|
|
(define/public (add-twig parent-twig-id point-index twig)
|
|
(let ((ptwig (get-twig parent-twig-id)))
|
|
(when ptwig
|
|
(send twig set-pos! (send ptwig get-point point-index)) ; attach to parent twig
|
|
; tell the twigs about this relationship (might turn out to be overkill)
|
|
(send ptwig add-child-twig-id (send twig get-id))
|
|
(send twig set-parent-twig-id parent-twig-id))
|
|
|
|
(send twig set-col! col)
|
|
(send twig set-tex! tex)
|
|
(send twig build shape-params)
|
|
|
|
(with-primitive (send twig get-root)
|
|
(parent root))
|
|
|
|
(set! twigs (cons (list (send twig get-id) twig) twigs))))
|
|
|
|
(define/public (add-twig-point twig-id point width)
|
|
(when (get-twig twig-id)
|
|
(send (get-twig twig-id) add-point point width is-player)))
|
|
|
|
(define/public (start-twig-growing twig-id)
|
|
(when (get-twig twig-id)
|
|
(send (get-twig twig-id) start-growing)))
|
|
|
|
(define/public (grow-seed amount)
|
|
(with-primitive seed (scale amount)))
|
|
|
|
(define/public (add-ornament twig-id point-index property) 0
|
|
(when (get-twig twig-id)
|
|
(send (get-twig twig-id) add-ornament point-index property)))
|
|
|
|
(define/public (hide-twigs s)
|
|
(for-each
|
|
(lambda (twig)
|
|
(with-primitive (send (cadr twig) get-root)
|
|
(hide s)))
|
|
twigs))
|
|
|
|
(define/public (set-excitations! a b)
|
|
(for-each
|
|
(lambda (twig)
|
|
(send (cadr twig) set-excitations! a b))
|
|
twigs))
|
|
|
|
(define/public (nutrient-absorb twig-id twig-point)
|
|
(when nutrients
|
|
(with-primitive nutrients
|
|
(let ((p (random (pdata-size))))
|
|
(pdata-set! "twig" p twig-id)
|
|
(pdata-set! "point" p twig-point)
|
|
(pdata-set! "p" p (send (get-twig twig-id) get-point twig-point))
|
|
(pdata-set! "offset" p (vmul (srndvec) (
|
|
send (get-twig twig-id) get-width twig-point)))))))
|
|
|
|
(define/public (update-nutrients t d)
|
|
(when (and nutrients (not (null? twigs)))
|
|
(with-primitive nutrients
|
|
(pdata-index-map!
|
|
(lambda (i p twig-id point offset speed)
|
|
(let* ((twig-id (inexact->exact twig-id))
|
|
(twig (get-twig twig-id))
|
|
(point (inexact->exact point)))
|
|
(cond
|
|
((or (< point 1) (not twig))
|
|
(let* ((new-twig (choose twigs))
|
|
(num-points (send (cadr new-twig) get-num-points))
|
|
(new-point (if (zero? num-points) 0 (random num-points))))
|
|
(pdata-set! "twig" i (car new-twig))
|
|
(pdata-set! "point" i new-point)
|
|
(pdata-set! "offset" i (vmix offset (vmul (srndvec) (send (cadr new-twig) get-width new-point)) 0.2))
|
|
(send (cadr new-twig) get-point new-point)))
|
|
((< (vdist (vadd (send twig get-point point) offset) p) 0.1)
|
|
(pdata-set! "point" i (- point 1))
|
|
(vadd p (vmul (vnormalise (vsub (vadd (send twig get-point (- point 1)) offset) p)) (* speed d))))
|
|
(else
|
|
(vadd p (vmul (vnormalise (vsub (vadd (send twig get-point point) offset) p)) (* speed d)))))))
|
|
"p" "twig" "point" "offset" "speed"))))
|
|
|
|
(define/public (above-ground)
|
|
(play-sound 'going-above-ground pos)
|
|
(when dust (send dust set-above-ground #t)))
|
|
|
|
(define/public (below-ground)
|
|
(play-sound 'going-below-ground pos)
|
|
(when dust (send dust set-above-ground #f)))
|
|
|
|
(define/public (update t d)
|
|
(when dust (send dust update t d))
|
|
|
|
(with-primitive seed
|
|
(shader-set! (list "Time" t))
|
|
#;(let ((t (inexact->exact (round (fmod (* 5 t) 3)))))
|
|
(cond
|
|
((eq? t 0) (texture (load-texture "textures/cells-1.png")))
|
|
((eq? t 1) (texture (load-texture "textures/cells-2.png")))
|
|
((eq? t 2) (texture (load-texture "textures/cells-3.png"))))))
|
|
|
|
|
|
(update-nutrients t d)
|
|
#;(with-primitive seed
|
|
(scale (+ 1 (* 0.001 (sin (* 2 t))))))
|
|
(for-each
|
|
(lambda (twig)
|
|
(when (send (cadr twig) delme?)
|
|
(destroy-branch-twig (car twig))))
|
|
twigs)
|
|
|
|
(for-each
|
|
(lambda (twig)
|
|
(send (cadr twig) update t d))
|
|
twigs))
|
|
|
|
(super-new)))
|
|
|
|
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
|
|
(define (build-env-box top bottom left right front back lower)
|
|
(let ((p (build-locator)))
|
|
(with-state
|
|
(parent p)
|
|
(hint-unlit)
|
|
|
|
(list
|
|
(let ((t (with-state
|
|
(texture (load-texture top))
|
|
(translate (vector 0 0.5 0))
|
|
(rotate (vector 90 0 0))
|
|
(build-plane))))
|
|
(when lower (with-primitive t
|
|
(pdata-map!
|
|
(lambda (t)
|
|
(vmul t 10))
|
|
"t"))
|
|
) t)
|
|
|
|
(with-state
|
|
(texture (load-texture left))
|
|
(translate (vector 0 0 -0.5))
|
|
(rotate (vector 0 0 0))
|
|
(build-plane))
|
|
|
|
(with-state
|
|
(texture (load-texture back))
|
|
(translate (vector 0.5 0 0))
|
|
(rotate (vector 0 90 0))
|
|
(build-plane))
|
|
|
|
(with-state
|
|
(texture (load-texture right))
|
|
(translate (vector 0 0 0.5))
|
|
(rotate (vector 0 0 0))
|
|
(build-plane))
|
|
|
|
(with-state
|
|
(texture (load-texture front))
|
|
(translate (vector -0.5 0 0))
|
|
(rotate (vector 0 90 0))
|
|
(build-plane))
|
|
|
|
(if lower
|
|
(with-state
|
|
(texture (load-texture bottom))
|
|
(translate (vector 0 -0.5 0))
|
|
(rotate (vector 90 0 0))
|
|
(build-plane)) 0)))))
|
|
|
|
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
|
|
(define grow-hud%
|
|
(class object%
|
|
|
|
(field
|
|
(cam #f)
|
|
(hud (build-locator))
|
|
(grow-mode-hud (build-locator)
|
|
#;(let ((p (with-state
|
|
(parent hud)
|
|
(translate (vector 0 0 3))
|
|
(scale (vector 1.3 1 1))
|
|
(hint-depth-sort)
|
|
(hint-nozwrite)
|
|
(texture (load-texture "textures/grow-mode-hud.png"))
|
|
(hint-unlit)
|
|
(build-plane))))
|
|
(with-primitive p (hide 1)) p))
|
|
(grow-mode-hud-state #f)
|
|
(grow-mode-hud-t 2)
|
|
(markers (make-marker-list 10))
|
|
(next-marker 0)
|
|
(text-list '())
|
|
(next-text-t -1)
|
|
(new-text #f))
|
|
|
|
(define/public (make-marker-list n)
|
|
(build-list n
|
|
(lambda (_)
|
|
(let ((p (with-state
|
|
(parent hud)
|
|
;(hint-unlit)
|
|
(colour 0.5)
|
|
(build-sphere 8 8))))
|
|
(with-primitive p (hide 1)) p))))
|
|
|
|
(define/public (set-cam s)
|
|
(set! cam s)
|
|
(with-primitive hud
|
|
(parent cam)))
|
|
|
|
(define/public (set-mode-on num-markers)
|
|
(when (> num-markers (length markers))
|
|
(set! markers (append markers (make-marker-list
|
|
(- num-markers (length markers))))))
|
|
|
|
(set! next-marker 0)
|
|
|
|
(for ((i (in-range 0 num-markers)))
|
|
(with-primitive (list-ref markers i)
|
|
(identity)
|
|
(scale 0.1)
|
|
(colour (marker-colour))
|
|
(hide 0)
|
|
(let ((a (* (/ i num-markers) 360 0.0174532925)))
|
|
(translate (vmul (vector (sin a) (cos a) 0) 15)))))
|
|
|
|
(with-primitive grow-mode-hud (hide 0) (opacity 0))
|
|
(set! grow-mode-hud-state #t)
|
|
(set! grow-mode-hud-t 0))
|
|
|
|
(define/public (set-mode-off)
|
|
(with-primitive grow-mode-hud (hide 0) (opacity 0))
|
|
(set! grow-mode-hud-state #f)
|
|
(set! grow-mode-hud-t 0))
|
|
|
|
(define/public (display text time)
|
|
(set! new-text #t)
|
|
(set! text-list (append text-list (list (list time (let ((t (with-state
|
|
(build-type "meshes/pensharp.ttf" text))))
|
|
(let* ((p (type->poly t))
|
|
(shad (build-copy p)))
|
|
(destroy t)
|
|
(with-primitive p
|
|
(hide 1)
|
|
(parent hud)
|
|
(hint-unlit)
|
|
(colour 1)
|
|
(scale 0.04)
|
|
(translate (vector 0 10 5))
|
|
; subtract the centre point to centre the text
|
|
(let ((c (vdiv (pdata-fold vadd (vector 0 0 0) "p") (pdata-size))))
|
|
(translate (vmul c -1))))
|
|
(with-primitive shad
|
|
(parent p)
|
|
(translate (vector 0 0 -0.01))
|
|
(hint-wire)
|
|
(wire-colour (vector 0 0 0))
|
|
(line-width 5))
|
|
p)))))))
|
|
|
|
(define/public (update-text t d)
|
|
|
|
(when (and new-text (eq? next-text-t -1))
|
|
(set! next-text-t (+ t (car (car text-list)))))
|
|
|
|
(set! new-text #f)
|
|
|
|
(when (not (null? text-list))
|
|
(let ((i (car text-list)))
|
|
(with-primitive (cadr i) (hide 0))
|
|
(when (> t next-text-t)
|
|
(destroy (cadr i))
|
|
(set! text-list (cdr text-list))
|
|
(if (null? text-list)
|
|
(set! next-text-t -1)
|
|
(set! next-text-t (+ t (car (car text-list)))))))))
|
|
|
|
(define/public (scrub-marker)
|
|
(with-primitive (list-ref markers next-marker)
|
|
;(hide 1)
|
|
(scale 0.99))
|
|
(set! next-marker (+ next-marker 1)))
|
|
|
|
(define/pubment (update-markers t d)
|
|
(for-each
|
|
(lambda (marker)
|
|
(with-primitive marker
|
|
(let ((sc (vmag (vtransform-rot (vector 0 1 0) (get-transform)))))
|
|
(when (and (< sc 0.1) (> sc 0))
|
|
(scale (- 1.0 (* d 1)))))))
|
|
markers))
|
|
|
|
(define/public (update t d)
|
|
(update-text t d)
|
|
(update-markers t d)
|
|
(when (< grow-mode-hud-t 1)
|
|
(with-primitive grow-mode-hud
|
|
(opacity (if grow-mode-hud-state
|
|
(* grow-mode-hud-t 0.5)
|
|
(* (- 1 (* grow-mode-hud-t )) 0.5)))))
|
|
|
|
(when (and (> grow-mode-hud-t 1) (not grow-mode-hud-state))
|
|
(with-primitive grow-mode-hud (hide 1)))
|
|
|
|
(set! grow-mode-hud-t (+ grow-mode-hud-t d 0.02)))
|
|
|
|
(super-new)))
|
|
|
|
|
|
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
|
|
(define game-view%
|
|
(class object%
|
|
|
|
(field
|
|
(plants '()) ; map of ids -> plants
|
|
(pickups '()) ; map of ids -> pickups
|
|
(insects '()) ; map of ids -> insects
|
|
(camera-dist 1)
|
|
(env-root (with-state (scale 1000) (build-locator)))
|
|
(root-camera-t 0)
|
|
(num-msgs 0)
|
|
(grow-hud (make-object grow-hud%))
|
|
(floor #f)
|
|
|
|
#;(upper-env (with-state
|
|
(parent env-root)
|
|
(hint-depth-sort)
|
|
(colour 2)
|
|
(translate (vector 0 0.28 0))
|
|
(build-env-box "textures/top.png" "textures/bottom-trans.png"
|
|
"textures/left.png" "textures/right.png"
|
|
"textures/front.png" "textures/back.png")))
|
|
#;(lower-env (with-state
|
|
(parent env-root)
|
|
(hint-depth-sort)
|
|
(translate (vector 0 -0.22001 0))
|
|
(build-env-box "textures/bottom-trans.png" "textures/bottom.png"
|
|
"textures/sleft.png" "textures/sright.png"
|
|
"textures/sfront.png" "textures/sback.png")))
|
|
#;(upper-env (with-state
|
|
(parent env-root)
|
|
;(hint-depth-sort)
|
|
(hint-unlit)
|
|
(translate (vector 0 0.28 0))
|
|
(build-env-box "textures/sky-top.png" "textures/floor.png"
|
|
"textures/sky-side.png" "textures/sky-side.png"
|
|
"textures/sky-side.png" "textures/sky-side.png" #f)))
|
|
#;(lower-env (with-state
|
|
(parent env-root)
|
|
;(hint-depth-sort)
|
|
(hint-unlit)
|
|
(colour (earth-colour))
|
|
(translate (vector 0 -0.22001 0))
|
|
(build-env-box "textures/floor.png" "textures/earth-bottom.png"
|
|
"textures/earth-side.png" "textures/earth-side.png"
|
|
"textures/earth-side.png" "textures/earth-side.png" #t)))
|
|
|
|
(stones '())
|
|
(ground-change-t 0)
|
|
(going-up #f))
|
|
|
|
(define/public (setup world-list)
|
|
(let ((l (make-light 'point 'free)))
|
|
(light-diffuse 0 (vector 0 0 0))
|
|
(light-diffuse l (vector 1 1 1))
|
|
(light-position l (vector 0 500 0)))
|
|
(set! stones
|
|
(map
|
|
(lambda (stone)
|
|
(let ((p (with-state
|
|
(hint-frustum-cull)
|
|
(colour 1)
|
|
(ambient 0.5)
|
|
(translate (list-ref stone 2))
|
|
(scale (list-ref stone 3))
|
|
(rotate (list-ref stone 4))
|
|
(cond
|
|
((eq? (list-ref stone 0) 'stone)
|
|
(colour (stones-colour))
|
|
(ambient (vmul (stones-colour) 0.5))
|
|
(shader "shaders/tree.vert.glsl" "shaders/rocks.frag.glsl")
|
|
(texture (load-texture "textures/root-norm.png")))
|
|
((eq? (list-ref stone 0) 'tree)
|
|
(colour (vector 0.45 0.4 0.3))
|
|
(ambient (vmul (vector 0.45 0.4 0.3) 0.5))
|
|
(shader "shaders/tree.vert.glsl" "shaders/rocks.frag.glsl")
|
|
(texture (load-texture "textures/root-norm.png")))
|
|
((eq? (list-ref stone 0) 'bg)
|
|
(hint-unlit)
|
|
(translate (vector 0 12 0))
|
|
(colour 1)
|
|
(texture (load-texture "textures/bg3.png"))))
|
|
|
|
(load-primitive (list-ref stone 1)))))
|
|
(with-primitive p
|
|
#;(when (eq? (list-ref stone 0) 'stone)
|
|
(pdata-map!
|
|
(lambda (t)
|
|
(vmul t 4))
|
|
"t"))
|
|
(apply-transform)
|
|
(recalc-bb)) ; apply the transform to speed up the ray tracing, don't have to tranform the ray into object space
|
|
p))
|
|
(list-ref world-list 2)))
|
|
#;(set! floor (let ((p (with-state
|
|
(hint-none)
|
|
(hint-unlit)
|
|
(hint-wire)
|
|
(colour 0.5)
|
|
;(opacity 0.2)
|
|
(texture (load-texture "textures/top.png"))
|
|
(hint-vertcols)
|
|
(translate (vector 0 0 0))
|
|
(rotate (vector 90 0 0))
|
|
(scale 500)
|
|
(line-width 2)
|
|
(backfacecull 0)
|
|
(build-seg-plane 80 80))))
|
|
(with-primitive p
|
|
(poly-convert-to-indexed)
|
|
(pdata-map!
|
|
(lambda (t)
|
|
(vmul t 10))
|
|
"t")
|
|
(pdata-map!
|
|
(lambda (c)
|
|
(vmul (vector 1 0.8 0.7) (rndf)))
|
|
"c")
|
|
(pdata-map!
|
|
(lambda (p)
|
|
(vadd p (vmul (grndvec) 0.001)))
|
|
"p")) p))
|
|
(with-state ; cap the top of the world
|
|
(translate (vector 0 300 0))
|
|
(rotate (vector 90 0 0))
|
|
(scale 5000)
|
|
(hint-unlit)
|
|
(colour (sky-colour))
|
|
(build-plane))
|
|
(below-ground))
|
|
|
|
(define/public (set-cam s)
|
|
(send grow-hud set-cam s))
|
|
|
|
(define/public (above-ground)
|
|
#;(with-primitive floor
|
|
(colour (vector 0.4 0.6 0.4))
|
|
(texture (load-texture "textures/top.png")))
|
|
(for-each
|
|
(lambda (plant)
|
|
(send (cadr plant) above-ground))
|
|
plants)
|
|
#;(for-each
|
|
(lambda (pickup)
|
|
(with-primitive (send (cadr pickup) get-root) (hide 1)))
|
|
pickups)
|
|
(set! going-up #t)
|
|
(set! ground-change-t ground-change-duration))
|
|
|
|
(define/public (below-ground)
|
|
#;(with-primitive floor
|
|
(texture (load-texture "textures/top.png"))
|
|
(colour (vector 0.4 0.6 0.4)))
|
|
(for-each
|
|
(lambda (plant)
|
|
(send (cadr plant) below-ground))
|
|
plants)
|
|
#;(for-each
|
|
(lambda (pickup)
|
|
(with-primitive (send (cadr pickup) get-root) (hide 0)))
|
|
pickups)
|
|
(set! going-up #f)
|
|
(set! ground-change-t ground-change-duration))
|
|
|
|
(define/public (update-ground-change t d)
|
|
(when (> ground-change-t 0)
|
|
(set! ground-change-t (- ground-change-t d))
|
|
(let* ((t (max 0 (/ ground-change-t ground-change-duration)))
|
|
(anim-t (if going-up t (- 1 t))))
|
|
|
|
(set-fov 53 0.1 (lerp 1000 1000 anim-t))
|
|
(clear-colour fog-col)
|
|
;(clear-colour (vmix fog-col above-fog-col anim-t))
|
|
;(fog (vmix fog-col above-fog-col anim-t) (lerp fog-strength above-fog-strength anim-t) 1 100)
|
|
)
|
|
)
|
|
)
|
|
|
|
(define/public (get-stones)
|
|
stones)
|
|
|
|
(define/public (add-plant plant)
|
|
;(destroy-plant (send plant get-id)) ; just in case
|
|
(set! plants (cons (list (send plant get-id) plant) plants)))
|
|
|
|
(define/public (get-plant plant-id)
|
|
(let ((p (assoc plant-id plants)))
|
|
(if (not p) #f (cadr p))))
|
|
|
|
(define/public (destroy-plant plant-id)
|
|
(let ((p (get-plant plant-id)))
|
|
(when p (send p destroy-plant)
|
|
(set! plants (assoc-remove plant-id plants)))))
|
|
|
|
(define/public (destroy-branch-twig plant-id twig-id)
|
|
(send (get-plant plant-id) destroy-branch-twig twig-id))
|
|
|
|
(define/public (add-twig plant-id parent-twig-id point-index twig)
|
|
(when (get-plant plant-id)
|
|
(send (get-plant plant-id) add-twig parent-twig-id point-index twig)))
|
|
|
|
(define/public (grow-seed plant-id amount)
|
|
(when (get-plant plant-id)
|
|
(send (get-plant plant-id) grow-seed amount)))
|
|
|
|
(define/public (get-pickup pickup-id)
|
|
(let ((p (assq pickup-id pickups)))
|
|
(if p (cadr p) #f)))
|
|
|
|
(define/public (add-pickup pickup-id type pos)
|
|
(set! pickups (cons (list pickup-id (make-object pickup-view% pickup-id type pos)) pickups)))
|
|
|
|
(define/public (add-insect insect-id pos type)
|
|
(cond
|
|
((eq? type 'worm)
|
|
(set! insects (cons (list insect-id
|
|
(make-object worm-insect-view% insect-id pos type)) insects)))
|
|
((eq? type 'spider)
|
|
(set! insects (cons (list insect-id
|
|
(make-object spider-insect-view% insect-id pos type)) insects)))
|
|
((eq? type 'butterfly)
|
|
(set! insects (cons (list insect-id
|
|
(make-object butterfly-insect-view% insect-id pos type)) insects)))))
|
|
|
|
(define/public (get-insect insect-id)
|
|
(cadr (assq insect-id insects)))
|
|
|
|
(define/public (pick-up-pickup pickup-id point)
|
|
(let ((pu (get-pickup pickup-id)))
|
|
(when pu
|
|
(send (get-pickup pickup-id) pick-up point))))
|
|
|
|
(define/public (highlight-pickup plant-id pickup-id)
|
|
(let ((pu (get-pickup pickup-id)))
|
|
(when pu
|
|
(let* ((p (get-pickup pickup-id))
|
|
(type (send p get-type)))
|
|
(send p highlight)
|
|
(when (send (get-plant plant-id) is-player?)
|
|
(display
|
|
(cond
|
|
((eq? type 'nutrient) "found a nutrient")
|
|
((eq? type 'leaf) "found a nutrient from the leaf plant")
|
|
((eq? type 'horn) "found a nutrient from the horn plant")
|
|
((eq? type 'inflatoe) "found an inflatoe growing ability")
|
|
((eq? type 'fork) "found a nutrient from the canopy plant")
|
|
((eq? type 'flower) "found a nutrient from the flower plant")) 4))))))
|
|
|
|
(define/public (add-ornament plant-id twig-id point-index property)
|
|
(when (get-plant plant-id)
|
|
(send (get-plant plant-id) add-ornament twig-id point-index property)))
|
|
|
|
(define/public (shrink-twig plant-id twig-id)
|
|
(when (get-plant plant-id)
|
|
(send (get-plant plant-id) shrink-twig twig-id)))
|
|
|
|
(define/public (set-excitations! a b)
|
|
(for-each
|
|
(lambda (plant)
|
|
(send (cadr plant) set-excitations! a b))
|
|
plants))
|
|
|
|
(define/public (set-grow-mode-on num)
|
|
(send grow-hud set-mode-on num))
|
|
|
|
(define/public (set-grow-mode-off)
|
|
(send grow-hud set-mode-off))
|
|
|
|
(define/public (scrub-marker)
|
|
(send grow-hud scrub-marker))
|
|
|
|
(define/public (display text time)
|
|
(send grow-hud display text time))
|
|
|
|
(define/public (update t d messages)
|
|
|
|
(update-ground-change t d)
|
|
(send grow-hud update t d)
|
|
|
|
(for-each
|
|
(lambda (plant)
|
|
(send (cadr plant) update t d))
|
|
plants)
|
|
|
|
(for-each
|
|
(lambda (pickup)
|
|
(send (cadr pickup) update t d))
|
|
pickups)
|
|
|
|
(for-each
|
|
(lambda (insect)
|
|
(send (cadr insect) update t d))
|
|
insects)
|
|
|
|
(when debug-messages
|
|
(for-each
|
|
(lambda (msg)
|
|
(send msg print))
|
|
messages))
|
|
|
|
;(when (> (length messages) 0) (printf "~a~n" (length messages)))
|
|
|
|
(set! pickups (filter
|
|
(lambda (pickup)
|
|
(not (send (cadr pickup) delme?)))
|
|
pickups))
|
|
|
|
(for-each
|
|
(lambda (msg)
|
|
(cond
|
|
((eq? (send msg get-name) 'player-plant)
|
|
(printf "adding player plant to view ~a~n" (send msg get-data 'plant-id))
|
|
(add-plant (make-object plant-view%
|
|
(send msg get-data 'plant-id)
|
|
(send msg get-data 'pos)
|
|
(send msg get-data 'size)
|
|
(send msg get-data 'col)
|
|
(send msg get-data 'tex)
|
|
#t
|
|
(list (send msg get-data 'curve)
|
|
(send msg get-data 'corner)))))
|
|
|
|
((eq? (send msg get-name) 'new-plant)
|
|
(printf "adding new plant to view ~a~n" (send msg get-data 'plant-id))
|
|
(add-plant (make-object plant-view%
|
|
(send msg get-data 'plant-id)
|
|
(send msg get-data 'pos)
|
|
(send msg get-data 'size)
|
|
(send msg get-data 'col)
|
|
(send msg get-data 'tex)
|
|
#f
|
|
(list (send msg get-data 'curve)
|
|
(send msg get-data 'corner)))))
|
|
|
|
|
|
((eq? (send msg get-name) 'grow-seed)
|
|
(grow-seed (send msg get-data 'plant-id)
|
|
(send msg get-data 'amount)))
|
|
|
|
((eq? (send msg get-name) 'destroy-branch-twig)
|
|
(destroy-branch-twig (send msg get-data 'plant-id) (send msg get-data 'twig-id)))
|
|
|
|
((eq? (send msg get-name) 'new-twig)
|
|
(add-twig (send msg get-data 'plant-id)
|
|
(send msg get-data 'parent-twig-id)
|
|
(send msg get-data 'point-index)
|
|
(cond
|
|
((eq? (send msg get-data 'render-type) 'ribbon)
|
|
(make-object ribbon-twig-view%
|
|
(send msg get-data 'twig-id)
|
|
(vector 0 0 0) ; will be filled in by add-twig
|
|
(send msg get-data 'type)
|
|
(send msg get-data 'dir)
|
|
(send msg get-data 'width)
|
|
(send msg get-data 'num-points)))
|
|
|
|
((eq? (send msg get-data 'render-type) 'extruded)
|
|
(make-object extruded-twig-view%
|
|
(send msg get-data 'twig-id)
|
|
(vector 0 0 0) ; will be filled in by add-twig
|
|
(send msg get-data 'type)
|
|
(send msg get-data 'dir)
|
|
(send msg get-data 'width)
|
|
(send msg get-data 'num-points))))))
|
|
|
|
((eq? (send msg get-name) 'add-twig-point)
|
|
(when (get-plant (send msg get-data 'plant-id))
|
|
(send (get-plant (send msg get-data 'plant-id)) add-twig-point
|
|
(send msg get-data 'twig-id)
|
|
(send msg get-data 'point)
|
|
(send msg get-data 'width))))
|
|
|
|
((eq? (send msg get-name) 'start-growing)
|
|
(when (get-plant (send msg get-data 'plant-id))
|
|
(send (get-plant (send msg get-data 'plant-id)) start-twig-growing
|
|
(send msg get-data 'twig-id))))
|
|
|
|
((eq? (send msg get-name) 'new-pickup)
|
|
(add-pickup
|
|
(send msg get-data 'pickup-id)
|
|
(send msg get-data 'type)
|
|
(send msg get-data 'pos)))
|
|
|
|
((eq? (send msg get-name) 'pick-up-pickup)
|
|
(pick-up-pickup
|
|
(send msg get-data 'pickup-id)
|
|
(send msg get-data 'point)))
|
|
|
|
((eq? (send msg get-name) 'pick-up-highlight)
|
|
(highlight-pickup
|
|
(send msg get-data 'plant-id)
|
|
(send msg get-data 'pickup-id)))
|
|
|
|
((eq? (send msg get-name) 'shrink-twig)
|
|
(shrink-twig
|
|
(send msg get-data 'plant-id)
|
|
(send msg get-data 'twig-id)))
|
|
|
|
((eq? (send msg get-name) 'new-ornament)
|
|
(add-ornament
|
|
(send msg get-data 'plant-id)
|
|
(send msg get-data 'twig-id)
|
|
(send msg get-data 'point-index)
|
|
(send msg get-data 'property)))
|
|
|
|
((eq? (send msg get-name) 'vrob)
|
|
(set! num-msgs (+ num-msgs 1))
|
|
(printf "num light-level msgs: ~a~n" num-msgs)
|
|
(set-excitations!
|
|
(send msg get-data 'light-level)
|
|
(send msg get-data 'soil-moisture))
|
|
#;(for-each
|
|
(lambda (p)
|
|
(with-primitive p
|
|
(colour (send msg get-data 'amount))))
|
|
upper-env))
|
|
|
|
((eq? (send msg get-name) 'new-insect)
|
|
(add-insect
|
|
(send msg get-data 'insect-id)
|
|
(send msg get-data 'pos)
|
|
(send msg get-data 'type)))
|
|
|
|
((eq? (send msg get-name) 'insect-move)
|
|
(send (get-insect (send msg get-data 'insect-id)) move
|
|
(send msg get-data 'pos)
|
|
(send msg get-data 'duration)))
|
|
|
|
))
|
|
messages))
|
|
|
|
|
|
|
|
|
|
(super-new)))
|