1054 lines
36 KiB
Scheme
1054 lines
36 KiB
Scheme
#lang scheme/base
|
|
(require scheme/class fluxus-016/fluxus "message.ss" "list-utils.ss")
|
|
(provide (all-defined-out))
|
|
|
|
; the fluxus code to make things look the way they do
|
|
|
|
(define debug-messages #t) ; prints out all the messages sent to the renderer
|
|
(define audio-on #t)
|
|
|
|
(define (ornament-colour) (vector 0.5 1 0.4))
|
|
(define (pickup-colour) (vector 1 1 1))
|
|
(define (earth-colour) (vector 0.2 0.1 0))
|
|
(define (stones-colour) (vmul (earth-colour) (+ 0.5 (* (rndf) 0.5))))
|
|
|
|
(define wire-mode #f)
|
|
(define fog-col (earth-colour))
|
|
(define fog-strength 0.001)
|
|
(define default-grow-speed 0.5)
|
|
(define grow-overshoot 10)
|
|
|
|
(when audio-on (oa-start)) ;; start openAL audio
|
|
|
|
(define (pre-ripple)
|
|
(when (not (pdata-exists? "rip-pref"))
|
|
(pdata-copy "p" "rip-pref")))
|
|
|
|
|
|
(define (clamp v l u)
|
|
(if (< v l) l
|
|
(if (> v u) u v)))
|
|
|
|
(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 (play-sound sound pos freq vol)
|
|
(when audio-on (let ((noise (oa-load-sample (fullpath sound))))
|
|
(oa-play noise pos freq vol))))
|
|
|
|
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
|
|
(define ornament-view%
|
|
(class object%
|
|
(init-field
|
|
(pos (vector 0 0 0))
|
|
(sc 1)
|
|
(dir (vector 0 0 1))
|
|
(property 'none)
|
|
(col (vector 1 1 1))
|
|
(time 0)
|
|
(ev-time 0)
|
|
(ev-dur 8)
|
|
(ev-col (vector 0 0 1))
|
|
(light 0))
|
|
|
|
(field
|
|
(const-scale (if (eq? property 'leaf) 2 4))
|
|
(rot (vector 0 0 0))
|
|
(excitation-changed #f)
|
|
(root (with-state
|
|
(translate pos)
|
|
;(hint-frustum-cull)
|
|
(concat (maim dir (vector 0 1 0)))
|
|
(scale (* const-scale sc))
|
|
;(hint-origin)
|
|
;(shader "shaders/textoon.vert.glsl" "shaders/textoon.frag.glsl")
|
|
(cond
|
|
((eq? property 'wiggle)
|
|
; (opacity 1)
|
|
(hint-depth-sort)
|
|
(colour (vector 0.5 0.0 0.0))
|
|
(load-primitive "meshes/wiggle.obj"))
|
|
((eq? property 'leaf)
|
|
(colour (vector 0.8 1 0.6))
|
|
(texture (load-texture "textures/leaf.png"))
|
|
(set! rot (vector 0 0 0))
|
|
(load-primitive "meshes/leaf.obj"))
|
|
((eq? property 'horn)
|
|
(backfacecull 0)
|
|
(shader "shaders/toon.vert.glsl" "shaders/toon.frag.glsl")
|
|
(colour col)
|
|
(set! rot (vector (* (rndf) 360) 0 0))
|
|
(load-primitive "meshes/horn.obj"))
|
|
((eq? property 'inflatoe)
|
|
(backfacecull 0)
|
|
(shader "shaders/toon.vert.glsl" "shaders/textoon.frag.glsl")
|
|
(texture (load-texture "textures/wiggle.png"))
|
|
(colour col)
|
|
(set! rot (vector (* (rndf) 360) 0 0))
|
|
(let ((p (load-primitive "meshes/inflatoe-full.obj")))
|
|
(let ((dp (load-primitive "meshes/inflatoe-empty.obj")))
|
|
(with-primitive p
|
|
(pdata-copy "p" "p1")
|
|
(pdata-add "p2" "v")
|
|
(pdata-index-map!
|
|
(lambda (i p2)
|
|
(with-primitive dp
|
|
(pdata-ref "p" i)))
|
|
"p2"))
|
|
(destroy dp))
|
|
p))
|
|
(else (error "unrecognised pickup property")))))
|
|
(particles (if (eq? property 'horn)
|
|
(let ((p (with-state
|
|
(parent root)
|
|
(translate (vector 0 0 2))
|
|
(hint-depth-sort)
|
|
(hint-unlit)
|
|
(blend-mode 'src-alpha 'one)
|
|
(texture (load-texture "textures/particle.png"))
|
|
(build-particles 30))))
|
|
(with-primitive p
|
|
(pdata-add "vel" "v")
|
|
(pdata-map!
|
|
(lambda (vel)
|
|
(vmul (srndvec) 0.01))
|
|
"vel")
|
|
(pdata-map!
|
|
(lambda (s)
|
|
(vmul (vector 1 1 1) (* 0.25 (rndf))))
|
|
"s")
|
|
(pdata-map!
|
|
(lambda (c)
|
|
(vadd ev-col (vmul (rndvec) (* 0.2 (rndf)))))
|
|
"c"))
|
|
p)
|
|
0)))
|
|
|
|
(define/public (set-excitations! a b)
|
|
(set! excitation-changed #t)
|
|
(set! light a)
|
|
(set! ev-dur (if (zero? a) 9999 (/ 1 a)))
|
|
(set! ev-col (vmix (vector 0 0 1) (vector 1 0 0) b))
|
|
(set! ev-time (* ev-dur 4 (rndf))))
|
|
|
|
(define/public (update t d)
|
|
(when (< time 1)
|
|
(with-primitive root
|
|
(identity)
|
|
(translate pos)
|
|
(concat (maim dir (vector 0 1 0)))
|
|
(rotate rot)
|
|
(scale (* const-scale sc 0.2 time)))
|
|
(set! time (+ time (* 0.05 d))))
|
|
|
|
(when (and (eq? property 'inflatoe) excitation-changed)
|
|
(with-primitive root
|
|
(pdata-map!
|
|
(lambda (p p1 p2)
|
|
(vmix p1 p2 (clamp light 0 1)))
|
|
"p" "p1" "p2")))
|
|
|
|
(when (eq? property 'horn)
|
|
(with-primitive particles
|
|
(pdata-op "+" "p" "vel")
|
|
(pdata-op "*" "c" 0.995))
|
|
|
|
(when (< ev-time 0)
|
|
(play-sound "snd/wateringcan.wav" pos (+ 0.1 (rndf)) 0.3)
|
|
|
|
#;(with-primitive root
|
|
(identity)
|
|
(translate pos)
|
|
(concat (maim dir (vector 0 1 0)))
|
|
(rotate rot)
|
|
(scale (* const-scale sc 0.2 ev-time)))
|
|
|
|
; todo inherit and call event happen or somesuch
|
|
(with-primitive particles
|
|
(pdata-index-map!
|
|
(lambda (i p)
|
|
(cond ((zero? (random 2)) p)
|
|
(else
|
|
(pdata-set! "c" i (vector (+ 0.5 (* 0.5 (rndf))) (+ 0.5 (* 0.5 (rndf))) 1))
|
|
(vector 0 0 0))))
|
|
"p"))
|
|
(set! ev-time ev-dur))
|
|
(set! ev-time (- ev-time d)))
|
|
|
|
(set! excitation-changed #f))
|
|
|
|
(super-new)))
|
|
|
|
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
|
|
(define pickup-view%
|
|
(class object%
|
|
(init-field
|
|
(id -1)
|
|
(type 'none)
|
|
(pos (vector 0 0 0)))
|
|
|
|
(field
|
|
(rot (vmul (rndvec) 360))
|
|
(root (with-state
|
|
(translate pos)
|
|
(rotate rot)
|
|
(colour (pickup-colour))
|
|
(scale 0.3)
|
|
(hint-frustum-cull)
|
|
;(shader "shaders/textoon.vert.glsl" "shaders/textoon.frag.glsl")
|
|
(texture
|
|
(cond
|
|
((eq? type 'wiggle) (load-texture "textures/wiggle.png"))
|
|
((eq? type 'leaf) (load-texture "textures/leaf.png"))
|
|
((eq? type 'curly) (load-texture "textures/curl.png"))
|
|
(else 0)))
|
|
(cond
|
|
((eq? type 'wiggle) (load-primitive "meshes/pickup.obj"))
|
|
((eq? type 'leaf) (load-primitive "meshes/leaf.obj"))
|
|
((eq? type 'curly) (load-primitive "meshes/pickup.obj"))
|
|
((eq? type 'horn) (backfacecull 0) (scale 5) (load-primitive "meshes/horn.obj"))
|
|
((eq? type 'inflatoe) (backfacecull 0) (scale 5) (load-primitive "meshes/inflatoe.obj")))))
|
|
(from pos)
|
|
(destination (vector 0 0 0))
|
|
(speed 0.05)
|
|
(t -1))
|
|
|
|
(define/public (pick-up)
|
|
(destroy 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 10) 0 0)))
|
|
#;(when (and (>= t 0) (< t 1))
|
|
(set! pos (vadd pos (vmul (vsub destination from) speed)))
|
|
(with-primitive root
|
|
(identity)
|
|
(translate pos)
|
|
(rotate rot))
|
|
(set! t (+ t speed))))
|
|
|
|
(super-new)))
|
|
|
|
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
|
|
(define nutrient-view%
|
|
(class object%
|
|
(init-field
|
|
(id -1)
|
|
(pos (vector 0 0 0))
|
|
(size 0))
|
|
|
|
(field
|
|
(root (with-state
|
|
(translate pos)
|
|
(scale size)
|
|
(build-sphere 10 10))))
|
|
|
|
(define/public (deplete amount)
|
|
(when (> size 0)
|
|
(set! size (- size amount))
|
|
(with-primitive root
|
|
(identity)
|
|
(translate pos)
|
|
(scale size))))
|
|
|
|
(define/public (update t d)
|
|
0)
|
|
|
|
(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 '())
|
|
(grow-t -1)
|
|
(marker-destroy-t 0)
|
|
(grow-speed default-grow-speed)
|
|
(shrink-t 0)
|
|
(delme #f))
|
|
|
|
(define/public (get-id)
|
|
id)
|
|
|
|
(define/public (delme?)
|
|
delme)
|
|
|
|
(define/public (get-dir)
|
|
dir)
|
|
|
|
(define/public (set-col! s)
|
|
(set! col s))
|
|
|
|
(define/public (set-tex! s)
|
|
(set! tex s))
|
|
|
|
(define/public (build)
|
|
0)
|
|
|
|
(define/public (get-num-points)
|
|
index)
|
|
|
|
(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 (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)
|
|
(set! grow-t 0)
|
|
(set! markers (cons (build-locator) markers)))
|
|
|
|
(define/public (start-shrinking)
|
|
(set! shrink-t (if (growing?) grow-t grow-overshoot)))
|
|
|
|
(define/pubment (add-point point width)
|
|
(play-sound "snd/event01.wav" point (+ 0.1 (rndf)) 0.3)
|
|
(set! markers (append markers (list (with-state
|
|
(parent (get-root))
|
|
(translate point)
|
|
(scale 0.1)
|
|
(shader "shaders/toon.vert.glsl" "shaders/toon.frag.glsl")
|
|
(colour col)
|
|
(build-sphere 8 8)))))
|
|
|
|
(inner (void) add-point point width))
|
|
|
|
(define/public (add-ornament point-index property)
|
|
(when (< point-index grow-t)
|
|
(play-sound "snd/nix.00203.wav" (get-point point-index) (+ 0.1 (rndf)) 0.3)
|
|
(with-state
|
|
(parent (get-root))
|
|
; todo - different ornament-view objects per property needed?
|
|
; todo - delete existing ornaments here
|
|
(set! ornaments (cons (list point-index
|
|
(make-object ornament-view%
|
|
(get-point point-index)
|
|
(get-width point-index)
|
|
(vnormalise (vsub (get-point point-index)
|
|
(get-point (- point-index 1))))
|
|
property col))
|
|
ornaments)))))
|
|
|
|
(define/pubment (set-excitations! a b)
|
|
(for-each
|
|
(lambda (ornament)
|
|
(send (cadr ornament) set-excitations! a b))
|
|
ornaments))
|
|
|
|
(define/pubment (update t d)
|
|
(for-each
|
|
(lambda (ornament)
|
|
(send (cadr ornament) update t d))
|
|
ornaments)
|
|
|
|
(when (> shrink-t 0)
|
|
(set! shrink-t (- shrink-t (* d grow-speed))))
|
|
|
|
(when (< shrink-t 0)
|
|
(set! delme #t))
|
|
|
|
(inner (void) update t d)
|
|
|
|
(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)))
|
|
; soundtodo: marker gobble
|
|
(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)
|
|
|
|
(field
|
|
(root 0))
|
|
|
|
(define/override (build)
|
|
(set! root (let ((p (with-state
|
|
(translate pos)
|
|
(colour col)
|
|
(texture (load-texture tex))
|
|
(build-ribbon num-points))))
|
|
(with-primitive p
|
|
(pdata-map!
|
|
(lambda (w)
|
|
0)
|
|
"w")
|
|
(pdata-set! "w" 0 radius))
|
|
p)))
|
|
|
|
|
|
(define/override (get-root)
|
|
root)
|
|
|
|
(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/augment (add-point point width)
|
|
(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")
|
|
(pdata-index-map! ; do a similar thing with the width
|
|
(lambda (i w)
|
|
(if (< i (+ index 1))
|
|
w
|
|
width))
|
|
"w"))
|
|
(set! index (+ index 1)))
|
|
|
|
(define/augment (update t d)
|
|
0)
|
|
|
|
(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)
|
|
|
|
(field
|
|
(profile '())
|
|
(path '())
|
|
(root 0)
|
|
(widths '()))
|
|
|
|
(define/override (build)
|
|
(set! profile (build-circle-profile 12 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 0)
|
|
(when wire-mode
|
|
(hint-none)
|
|
(hint-wire))
|
|
(shader "shaders/toon.vert.glsl" "shaders/toon.frag.glsl")
|
|
(texture (load-texture tex))
|
|
(opacity 0.6)
|
|
(colour col)
|
|
#;(colour (vector 1 1 1))
|
|
#;(texture (load-texture "textures/root.png"))
|
|
(build-partial-extrusion profile path 3))))
|
|
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 (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)
|
|
(set! path (list-set path index point))
|
|
(set! widths (list-set widths index width))
|
|
(set! index (+ index 1)))
|
|
|
|
(define/augment (update t d)
|
|
(when (and (not (eq? grow-t -1)) (not (eq? grow-t 999)))
|
|
(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 (not (growing?))
|
|
(with-primitive root
|
|
(pre-ripple)
|
|
(ripple t 1 0.001))))
|
|
|
|
(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 ""))
|
|
|
|
(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 (with-state
|
|
(parent root)
|
|
(shader "shaders/toon.vert.glsl" "shaders/toon.frag.glsl")
|
|
(texture (load-texture tex))
|
|
(backfacecull 0)
|
|
(opacity 0.6)
|
|
(colour col)
|
|
(hint-depth-sort)
|
|
(scale (* 0.12 size))
|
|
(when wire-mode
|
|
(hint-none)
|
|
(hint-wire))
|
|
;(hint-unlit)
|
|
(load-primitive "meshes/seed.obj")))
|
|
(nutrients (let ((p (with-state
|
|
(hint-depth-sort)
|
|
(hint-unlit)
|
|
(parent root)
|
|
(blend-mode 'src-alpha 'one)
|
|
(texture (load-texture "textures/star.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 0 (rndf) (rndf)))
|
|
"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)))
|
|
|
|
(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)
|
|
|
|
(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)))
|
|
|
|
(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)
|
|
(when (get-twig twig-id)
|
|
(send (get-twig twig-id) add-ornament point-index property)))
|
|
|
|
(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)
|
|
(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 (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)))
|
|
(if twig
|
|
(cond
|
|
((< point 1) (pdata-set! "twig" i -1) (vector 0 0 0))
|
|
((< (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)))))
|
|
(vector 0 0 0))))
|
|
"p" "twig" "point" "offset" "speed"))))
|
|
|
|
(define/public (update t d)
|
|
(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 game-view%
|
|
(class object%
|
|
|
|
(field
|
|
(plants '()) ; map of ids -> plants
|
|
(pickups '()) ; map of ids -> pickups
|
|
(nutrients '()) ; map of ids -> nutrients
|
|
(camera-dist 1)
|
|
(env-root (with-state (scale 1000) (build-locator)))
|
|
(root-camera-t 0)
|
|
(num-msgs 0)
|
|
#;(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 '()))
|
|
|
|
(define/public (setup world-list)
|
|
(let ((l (make-light 'point 'free)))
|
|
(light-diffuse 0 (vector 0.5 0.5 0.5))
|
|
(light-diffuse l (vector 1 1 1))
|
|
(light-position l (vector 10 50 -4)))
|
|
|
|
(clear-colour fog-col)
|
|
(clip 1 2000)
|
|
(fog fog-col fog-strength 1 100)
|
|
|
|
(set! stones
|
|
(map
|
|
(lambda (stone)
|
|
(let ((p (with-state
|
|
(hint-frustum-cull)
|
|
(shader "shaders/toon.vert.glsl" "shaders/toon.frag.glsl")
|
|
(colour (stones-colour))
|
|
(translate (list-ref stone 2))
|
|
(scale (list-ref stone 3))
|
|
(rotate (list-ref stone 4))
|
|
(texture (load-texture "textures/quartz.png"))
|
|
(load-primitive (list-ref stone 1)))))
|
|
(with-primitive p (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 3))))
|
|
|
|
(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)
|
|
(cadr (assq pickup-id pickups)))
|
|
|
|
(define/public (get-nutrient nutrient-id)
|
|
(cadr (assq nutrient-id nutrients)))
|
|
|
|
(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-nutrient nutrient-id pos size)
|
|
(set! nutrients (cons (list nutrient-id (make-object nutrient-view% nutrient-id pos size)) nutrients)))
|
|
|
|
(define/public (pick-up-pickup pickup-id)
|
|
(send (get-pickup pickup-id) pick-up)
|
|
(set! pickups (assoc-remove pickup-id pickups)))
|
|
|
|
(define/public (deplete-nutrient nutrient-id amount plant-id twig-id twig-point)
|
|
(send (get-nutrient nutrient-id) deplete amount)
|
|
(when (get-plant plant-id)
|
|
(send (get-plant plant-id) nutrient-absorb twig-id twig-point)))
|
|
|
|
(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 (update t d messages)
|
|
|
|
(for-each
|
|
(lambda (plant)
|
|
(send (cadr plant) update t d))
|
|
plants)
|
|
|
|
(for-each
|
|
(lambda (pickup)
|
|
(send (cadr pickup) update t d))
|
|
pickups)
|
|
|
|
(when debug-messages
|
|
(for-each
|
|
(lambda (msg)
|
|
(send msg print))
|
|
messages))
|
|
(for-each
|
|
(lambda (msg)
|
|
(cond
|
|
((eq? (send msg get-name) 'player-plant) ; not really any difference now
|
|
(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))))
|
|
|
|
((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))))
|
|
|
|
((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) 'new-nutrient)
|
|
(add-nutrient
|
|
(send msg get-data 'nutrient-id)
|
|
(send msg get-data 'pos)
|
|
(send msg get-data 'size)))
|
|
|
|
((eq? (send msg get-name) 'pick-up-pickup)
|
|
(pick-up-pickup
|
|
(send msg get-data 'pickup-id)))
|
|
|
|
((eq? (send msg get-name) 'deplete-nutrient)
|
|
(deplete-nutrient
|
|
(send msg get-data 'nutrient-id)
|
|
(send msg get-data 'amount)
|
|
(send msg get-data 'plant-id)
|
|
(send msg get-data 'twig-id)
|
|
(send msg get-data 'twig-point)))
|
|
|
|
((eq? (send msg get-name) 'shrink-twig)
|
|
(printf "hello~n")
|
|
(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))
|
|
|
|
))
|
|
messages))
|
|
|
|
|
|
|
|
|
|
(super-new)))
|