300 lines
11 KiB
Scheme
300 lines
11 KiB
Scheme
(require scheme/class)
|
|
(require "sound.ss")
|
|
(define default-grow-speed 4)
|
|
(define grow-overshoot 10)
|
|
|
|
(define (fract n)
|
|
(- n (floor n)))
|
|
|
|
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
|
|
(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) 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 (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 (+ num-points grow-overshoot))))
|
|
|
|
(define/pubment (add-point point width make-marker)
|
|
(play-sound "snd/event01.wav" point (+ 0.1 (rndf)) 0.3)
|
|
(when make-marker
|
|
(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 make-marker))
|
|
|
|
(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))
|
|
(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)))
|
|
; check above ground
|
|
(let ((pos (with-primitive (get-root) (vtransform (vector 0 0 0) (get-global-transform)))))
|
|
(if (not (and (send ornament above-ground-only?)
|
|
(< (vy (vadd pos (get-point point-index))) 1)))
|
|
; todo - delete existing ornaments here
|
|
(set! ornaments (cons (list point-index ornament) ornaments))
|
|
(send ornament destroy-ornament)))))))
|
|
|
|
(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 grow-t)
|
|
|
|
(field
|
|
(root 0)
|
|
(widths '())
|
|
(points '())
|
|
(global-growth 0)
|
|
(global-growth-time 10))
|
|
|
|
(define/override (build)
|
|
(set! root (let ((p (with-state
|
|
(translate pos)
|
|
(colour col)
|
|
(hint-unlit)
|
|
(texture (load-texture "textures/ribbon-twig.png"))
|
|
(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/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 (update t d)
|
|
(when (and (> grow-t 0) (< grow-t (+ (length points) 10)))
|
|
(with-primitive root
|
|
(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")))
|
|
|
|
(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))
|
|
|
|
(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)))
|
|
(with-state
|
|
(parent par)
|
|
(send t build))
|
|
(let ((m (mrotate (vmul (srndvec) 45)))
|
|
(ppos (vector 0 0 0)))
|
|
(for ((i (in-range 0 length)))
|
|
(let ((dir (vtransform (send t get-dir) m))
|
|
(width (if (eq? i (- length 1)) 0 (/ width (+ i 1)))))
|
|
(send t set-dir! dir)
|
|
(send t add-point ppos width #f)
|
|
(set! ppos (vadd ppos (vmul dir (* 5 width)))))))
|
|
(send t start-growing)
|
|
t))
|
|
|
|
|
|
|
|
(define/public (update t d)
|
|
(for-each
|
|
(lambda (twig)
|
|
(send twig update t d)
|
|
(when (and
|
|
(< (length twigs) 50)
|
|
(> (send twig get-num-points) 2)
|
|
(zero? (random 20)))
|
|
(let ((pi (inexact->exact (floor (send twig get-grow-t)))))
|
|
(when (< 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))
|
|
|
|
(super-new)))
|
|
|
|
|
|
(clear)
|
|
(clear-colour 0.5)
|
|
(define l (with-state
|
|
(build-locator)))
|
|
|
|
|
|
(define r '())
|
|
|
|
(let ((t (make-object twiglets% l)))
|
|
(send t build (vector 0 0 0) (vector 0 1 0) 2 20)
|
|
(set! r (cons t r)))
|
|
|
|
(every-frame
|
|
(begin
|
|
(when (key-pressed " ")
|
|
(let ((t (make-object twiglets% l)))
|
|
(send t build (vector 0 0 0) (vector 0 1 0) 2 20)
|
|
(set! r (cons t r))))
|
|
(for-each
|
|
(lambda (t)
|
|
(send t update (time) 0.02))
|
|
r)))
|
|
|
|
;(start-framedump "ribbon-test-" "jpg")
|
|
|