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

added fpp

Browse source
This commit is contained in:
Dave Griffiths 2009-06-19 16:53:02 +01:00
parent 143a4c0796
commit 1489bd4b10
3 changed files with 222 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

10
fpp/cam-dir.scm~ Normal file
View file

@ -0,0 +1,10 @@
(clear)
(show-axis 1)
(clear-colour 0.5)
(hint-wire)
(define p (build-ribbon 2))
(every-frame
(with-primitive p
(pdata-set! "p" 1
(vtransform-rot (vector 0 0 1) (minverse (get-camera-transform))))))

106
fpp/fpp.scm Normal file
View file

@ -0,0 +1,106 @@
(require scheme/class)
(define (build-ring n sr er)
(let ((p (build-polygons (+ (* n 2) 2) 'triangle-strip)))
(with-primitive p
(pdata-index-map!
(lambda (i p)
(let ((a (* (/ (quotient i 2) n) (* 2 3.141)))
(s (if (odd? i) sr er)))
(vector (* (cos a) s) (* (sin a) s) (if (odd? i) 0 1))))
"p")
(recalc-normals 1))
p))
(define twig%
(class object%
(init-field
(size 10)
(radius 1)
(speed 0.2))
(field
(root (build-locator))
(child-twigs '())
(age 0)
(tx (mident))
(next-ring-time 0))
(define/public (build pos dir)
(with-primitive root
(translate pos)
(if dir (concat (maim (vector 0 0 1) dir))
(rotate (vmul (crndvec) 20)))))
(define/public (update)
(when (and (< age size) (< next-ring-time (time)))
(set! next-ring-time (+ (time) speed))
(with-state
(parent root)
;(hint-none)
; (hint-wire)
(backfacecull 0)
(let* ((s (- size age))
(sr (* radius (/ s size)))
(er (* radius (/ (+ s 1) size))))
(translate (vector 0 0 age))
(when (zero? (random 20))
(with-state
(identity)
(set! child-twigs (cons
(make-object twig% (/ size 2) sr speed) child-twigs))
(send (car child-twigs) build (vector 0 0 age) #f)))
(build-ring 5 sr er)))
(set! age (+ age 1)))
(for-each
(lambda (child)
(send child update))
child-twigs))
(super-new)))
(define seed%
(class object%
(field
(twigs '())
(debounce #t)
(debounce-time 0))
(define/public (add-twig dir)
(let ((t (make-object twig% 100 1 0.01)))
(set! twigs (cons (with-state
(colour (vector 0.3 0.8 0.4))
(send t build (vector 0 0 0) dir) t) twigs))))
(define/public (update)
(when (and debounce (key-pressed " "))
(add-twig (vtransform-rot (vector 0 0 1) (minverse (get-camera-transform))))
(set! debounce #f)
(set! debounce-time (+ (time) 1)))
(when (> (time) debounce-time)
(set! debounce #t))
(for-each
(lambda (twig)
(send twig update))
twigs))
(super-new)))
(clear)
(show-axis 1)
(clear-colour (vector 0.2 0.5 0.3))
(define s (make-object seed%))
(every-frame (send s update))

106
fpp/fpp.scm~ Normal file
View file

@ -0,0 +1,106 @@
(require scheme/class)
(define (build-ring n sr er)
(let ((p (build-polygons (+ (* n 2) 2) 'triangle-strip)))
(with-primitive p
(pdata-index-map!
(lambda (i p)
(let ((a (* (/ (quotient i 2) n) (* 2 3.141)))
(s (if (odd? i) sr er)))
(vector (* (cos a) s) (* (sin a) s) (if (odd? i) 0 1))))
"p")
(recalc-normals 1))
p))
(define twig%
(class object%
(init-field
(size 10)
(radius 1)
(speed 0.2))
(field
(root (build-locator))
(child-twigs '())
(age 0)
(tx (mident))
(next-ring-time 0))
(define/public (build pos dir)
(with-primitive root
(translate pos)
(if dir (concat (maim (vector 0 0 1) dir))
(rotate (vmul (crndvec) 20)))))
(define/public (update)
(when (and (< age size) (< next-ring-time (time)))
(set! next-ring-time (+ (time) speed))
(with-state
(parent root)
;(hint-none)
;(hint-wire)
(backfacecull 0)
(let* ((s (- size age))
(sr (* radius (/ s size)))
(er (* radius (/ (+ s 1) size))))
(translate (vector 0 0 age))
(when (zero? (random 20))
(with-state
(identity)
(set! child-twigs (cons
(make-object twig% (/ size 2) sr speed) child-twigs))
(send (car child-twigs) build (vector 0 0 age) #f)))
(build-ring 5 sr er)))
(set! age (+ age 1)))
(for-each
(lambda (child)
(send child update))
child-twigs))
(super-new)))
(define seed%
(class object%
(field
(twigs '())
(debounce #t)
(debounce-time 0))
(define/public (add-twig dir)
(let ((t (make-object twig% 100 1 0.01)))
(set! twigs (cons (with-state
(colour (vector 0.3 0.8 0.4))
(send t build (vector 0 0 0) dir) t) twigs))))
(define/public (update)
(when (and debounce (key-pressed " "))
(add-twig (vtransform-rot (vector 0 0 1) (minverse (get-camera-transform))))
(set! debounce #f)
(set! debounce-time (+ (time) 1)))
(when (> (time) debounce-time)
(set! debounce #t))
(for-each
(lambda (twig)
(send twig update))
twigs))
(super-new)))
(clear)
(show-axis 1)
(clear-colour (vector 0.2 0.5 0.3))
(define s (make-object seed%))
(every-frame (send s update))