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

twiglets fixed, moved stuff around...

Browse source
This commit is contained in:
Dave Griffiths 2009-09-28 09:57:29 +01:00
parent dca225bc0a
commit 07438ae5c1
31 changed files with 1193 additions and 54 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

30
plant-eyes/README
View file

@ -1,2 +1,28 @@
i've split off the logic code while I work on it - it will eventually replace
plant-eyes.scm
notes:
* keeping with a view/logic separation, although this is quite different to
the hexagon game. the main advantages:
- just a divide and conquer strategy for staying sane
- able to debug the logic without the view, or vice versa
- the logic can be ticked at a lower frequency - or even different
parts at different rates, whereas the view needs ticking every frame
* need to try to keep all the intensive 'every thing vs every thing' checking
in the logic side, where it can be done over many frames (i'm thinking the
lags involved with things like nutrients getting absorbed may not matter
too much in this game)
* using a message passing system to formalise the passing of information on
the logic side. this makes it possible to have objects sending messages
at any point, and have them automatically collected up and dispatched to
the view
* these messages are also converted to xmpp messages and sent out over the
network
* line segments are computed in the logic side, and can be represented any
way by the view - maybe the players plant will be geometry and everyone
elses will be ribbons (stoopid LOD)
* in the same way, the line segments can be created in any way by the logic
side - eg. lsystem, or different methods per plant (or per twig even)

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

@ -1,39 +1,15 @@
;; p l a n t e y e s [ copyright (c) 2009 foam vzw : gpl v3 ]
;#lang scheme/base
;(require fluxus-016/drflux)
(require scheme/class "game-modes.ss" "logic.ss" "view.ss" "controller.ss" "client.ss" "jabberer.ss" "list-utils.ss")
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; p l a n t e y e s
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; notes:
;
; * keeping with a view/logic separation, although this is quite different to
; the hexagon game. the main advantages:
; - just a divide and conquer strategy for staying sane
; - able to debug the logic without the view, or vice versa
; - the logic can be ticked at a lower frequency - or even different
; parts at different rates, whereas the view needs ticking every frame
;
; * need to try to keep all the intensive 'every thing vs every thing' checking
; in the logic side, where it can be done over many frames (i'm thinking the
; lags involved with things like nutrients getting absorbed may not matter
; too much in this game)
;
; * using a message passing system to formalise the passing of information on
; the logic side. this makes it possible to have objects sending messages
; at any point, and have them automatically collected up and dispatched to
; the view
;
; * these messages are also converted to xmpp messages and sent out over the
; network
;
; * line segments are computed in the logic side, and can be represented any
; way by the view - maybe the players plant will be geometry and everyone
; elses will be ribbons (stoopid LOD)
;
; * in the same way, the line segments can be created in any way by the logic
; side - eg. lsystem, or different methods per plant (or per twig even)
(require scheme/class
"scripts/game-modes.ss"
"scripts/logic.ss"
"scripts/view.ss"
"scripts/controller.ss"
"scripts/client.ss"
"scripts/jabberer.ss"
"scripts/list-utils.ss")
(define world-list (let* ((f (open-input-file "world.txt"))
(o (list (read f)(read f)(read f)(read f))))

8
plant-eyes/client.ss → plant-eyes/scripts/client.ss
View file

@ -1,5 +1,11 @@
;; p l a n t e y e s [ copyright (c) 2009 foam vzw : gpl v3 ]
#lang scheme
(require scheme/class "jabberer.ss" "message.ss" "list-utils.ss")
(require scheme/class
"jabberer.ss"
"message.ss"
"list-utils.ss")
(provide (all-defined-out))
; the client listens to all the messages from the logic side

8
plant-eyes/controller.ss → plant-eyes/scripts/controller.ss
View file

@ -1,5 +1,11 @@
;; 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 "logic.ss" "view.ss")
(require scheme/class
fluxus-016/fluxus
"logic.ss"
"view.ss")
(provide (all-defined-out))
; reads input events and tells the logic side what to do

12
plant-eyes/game-modes.ss → plant-eyes/scripts/game-modes.ss
View file

@ -1,5 +1,15 @@
;; p l a n t e y e s [ copyright (c) 2009 foam vzw : gpl v3 ]
#lang scheme
(require scheme/class fluxus-016/fluxus "logic.ss" "view.ss" "controller.ss" "client.ss" "jabberer.ss" "list-utils.ss")
(require scheme/class
fluxus-016/fluxus
"logic.ss"
"view.ss"
"controller.ss"
"client.ss"
"jabberer.ss"
"list-utils.ss")
(provide (all-defined-out))
(define-struct player-info (jid pass tex pos col))

2
plant-eyes/jabberer.ss → plant-eyes/scripts/jabberer.ss
View file

@ -1,3 +1,5 @@
;; p l a n t e y e s [ copyright (c) 2009 foam vzw : gpl v3 ]
#lang scheme/base
(require scheme/class); openssl (prefix-in xmpp: "xmpp.ss"))
(provide (all-defined-out))

2
plant-eyes/list-utils.ss → plant-eyes/scripts/list-utils.ss
View file

@ -1,3 +1,5 @@
;; p l a n t e y e s [ copyright (c) 2009 foam vzw : gpl v3 ]
#lang scheme/base
(provide (all-defined-out))

8
plant-eyes/logic.ss → plant-eyes/scripts/logic.ss
View file

@ -1,5 +1,11 @@
;; p l a n t e y e s [ copyright (c) 2009 foam vzw : gpl v3 ]
#lang scheme
(require scheme/class fluxus-016/fluxus "message.ss" "list-utils.ss")
(require scheme/class
fluxus-016/fluxus
"message.ss"
"list-utils.ss")
(provide (all-defined-out))
(define branch-probability 6) ; as in one in branch-probability chance

6
plant-eyes/message.ss → plant-eyes/scripts/message.ss
View file

@ -1,5 +1,9 @@
;; p l a n t e y e s [ copyright (c) 2009 foam vzw : gpl v3 ]
#lang scheme/base
(require scheme/class "list-utils.ss")
(require scheme/class
"list-utils.ss")
(provide (all-defined-out))
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

7
plant-eyes/ornament-views.ss → plant-eyes/scripts/ornament-views.ss
View file

@ -1,5 +1,10 @@
;; 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 "sound.ss")
(require scheme/class
fluxus-016/fluxus
"sound.ss")
(provide (all-defined-out))
(define (clamp v l u)

2
plant-eyes/sound.ss → plant-eyes/scripts/sound.ss
View file

@ -1,3 +1,5 @@
;; 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)
(provide (all-defined-out))

25
plant-eyes/view.ss → plant-eyes/scripts/view.ss
View file

@ -1,5 +1,14 @@
;; 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")
(require scheme/class
fluxus-016/fluxus
fluxus-016/shapes
"sound.ss"
"message.ss"
"list-utils.ss"
"ornament-views.ss")
(provide (all-defined-out))
; the fluxus code to make things look the way they do
@ -485,7 +494,7 @@
(widths '())
(points '())
(global-growth 0)
(global-growth-time 20))
(global-growth-time 100))
(define/override (build)
(set! root (let ((p (with-state
@ -603,14 +612,11 @@
(lambda (twig)
(send twig update t d)
(when (and
(< (length twigs) 50)
(< (length twigs) 20)
(> (send twig get-num-points) 2)
(zero? (random 20)))
(zero? (random 400)))
(let ((pi (inexact->exact (floor (send twig get-grow-t)))))
(when (< pi (send twig get-num-points))
(with-state
(translate (vadd (send twig get-pos) (send twig get-point pi)))
(build-sphere 5 5))
(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))
@ -764,8 +770,7 @@
(when (and (not (eq? grow-t -1)) (not (eq? grow-t 999)))
; randomly add twiglets as we are growing
(when (and (zero? (random 400)) (< grow-t num-points))
(printf "~a~n" (length twiglets))
(when (and (zero? (random 100)) (< grow-t num-points))
(let ((t (make-object twiglets% (get-root)))
(pi (inexact->exact (floor grow-t))))
(send t build (get-point pi) dir (/ (get-width pi) 2) 20)

0
plant-eyes/xmpp.ss → plant-eyes/scripts/xmpp.ss
View file

41
plant-eyes/test-scripts/butterflies.scm Normal file
View file

@ -0,0 +1,41 @@
(clear)
(clear-colour 0.5)
(define (build)
(let ((p (build-locator)))
(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 (anim)
(let ((a (* 90 (rndf))))
(with-primitive (car (get-children))
(rotate (vector 0 0 a)))
(with-primitive (cadr (get-children))
(rotate (vector 0 0 (- a))))))
(define l (build-list 10
(lambda (_)
(with-state
(translate (srndvec))
(rotate (vmul (rndvec) 360))
(scale 0.5)
(build)))))
(every-frame
(for-each
(lambda (p)
(with-primitive p
(anim)))
l))

17
plant-eyes/test-scripts/camera-dir.scm Normal file
View file

@ -0,0 +1,17 @@
(clear)
(show-axis 1)
(clear-colour 0.5)
(hint-wire)
(define p (build-ribbon 2))
(define p2 (with-state (scale (vector 0.1 0.1 1)) (build-cube)))
(every-frame
(let ((dir (vtransform-rot (vector 0 0 1) (minverse (get-camera-transform)))))
(with-primitive p
(pdata-set! "p" 1
dir))
(with-primitive p2
(identity)
(concat (maim dir (vector 0 1 0)))
(scale (vector 1 0.1 0.1)))))

21
plant-eyes/test-scripts/classtest.scm Normal file
View file

@ -0,0 +1,21 @@
#lang scheme
(define testy%
(class object%
(init-field (a 0))
(define/public (m) (display a)(newline))
(super-new)))
(define testy2%
(class testy%
(inherit-field a)
(field (b a))
(define/public (mm) (display a)(display b) (newline))
(super-new)))
(define t (make-object testy2% 100))
(send t m)
(send t mm)

39
plant-eyes/test-scripts/dust.scm Normal file
View file

@ -0,0 +1,39 @@
(require scheme/class)
(define dust%
(class object%
(field
(rate 10)
(next-p 0)
(root (let ((p (with-state
(build-particles 500))))
(with-primitive p
(pdata-map!
(lambda (c)
(vector 1 1 1))
"c")) p))
(emitter (build-locator)))
(define/public (update t d)
(let ((emitter-pos (with-primitive emitter
(identity)
(concat (minverse (get-camera-transform)))
(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)))
(set! next-p (+ next-p 1))))))
(super-new)))
(clear)
(define t (make-object dust%))
(define (animate)
(send t update (time) (delta)))
(every-frame (animate))

140
plant-eyes/test-scripts/earth.scm Normal file
View file

@ -0,0 +1,140 @@
(define-struct stones (mesh-list (pos-list #:mutable) size-list rot-list
(root #:mutable) (obj-list #:mutable)))
(define (stones->list s)
(map list
(stones-mesh-list s)
(stones-pos-list s)
(stones-size-list s)
(stones-rot-list s)))
(define (write-out fn s)
(let ((f (open-output-file fn)))
(write (stones->list s) f)
(close-output-port f)))
(define (choose l)
(list-ref l (random (length l))))
(define models (list
; "meshes/fork.obj"
"meshes/stone1.obj"
"meshes/stone2.obj"
"meshes/stone3.obj"))
(define (stones-init num area size)
(make-stones
(append (build-list num
(lambda (_)
(choose models)))
(build-list 5
(lambda (_)
"meshes/seed.obj")))
(append
(build-list num
(lambda (_)
(vmul (srndvec) (* size area))))
(build-list 5
(lambda (_)
(vmul (srndvec) (* size area 0.5)))))
(append
(build-list num
(lambda (_)
(* size (- 1 (expt (rndf) 2)))))
(build-list 5
(lambda (_)
1)))
(append
(build-list num
(lambda (_)
(vmul (rndvec) 360)))
(build-list 5
(lambda (_)
(vmul (rndvec) 360))))
0
'()))
(define (stones-build stones)
(let* ((root (build-locator))
(objs (with-state
(parent root)
(map
(lambda (mesh pos size)
(let ((p (with-state
(if (string=? mesh "meshes/seed.obj")
(colour (vector 0 1 0))
(colour (vector 1 0.5 0)))
(load-primitive mesh))))
0
p))
(stones-mesh-list stones)
(stones-pos-list stones)
(stones-size-list stones)))))
(set-stones-obj-list! stones objs)
(set-stones-root! stones root)
stones))
(define (stones-relax stones amount)
(let ((done #t))
(set-stones-pos-list! stones
(map
(lambda (pos size)
(foldl
(lambda (opos osize r)
(cond ((< (vdist pos opos) (* 5 (+ size osize)))
(set! done #f)
(vadd r (vmul (vnormalise (vsub pos opos)) amount)))
(else r)))
(if (> (vy pos) 0) (vadd pos (vector 0 (* amount -30) 0)) pos)
(stones-pos-list stones)
(stones-size-list stones)))
(stones-pos-list stones)
(stones-size-list stones)))
done))
(define (stones-update stones)
(let ((root (build-locator)))
(with-state
(parent root)
(for-each
(lambda (obj pos size rot)
(with-primitive obj
(identity)
(translate pos)
(rotate rot)
(scale size)))
(stones-obj-list stones)
(stones-pos-list stones)
(stones-size-list stones)
(stones-rot-list stones)))
(set-stones-root! stones root)))
(clear)
(clear-colour 0)
(define s (stones-build (stones-init 200 1 10)))
(define l (make-light 'spot 'free))
(light-diffuse 0 (vector 0 0 0))
(light-specular 0 (vector 0 0 0))
(light-diffuse l (vector 1 1 1))
(light-position l (vector 0 1000 0))
(light-specular l (vector 0.1 0.1 0.1))
(define done #f)
(define (animate)
(when (key-pressed "s") (write-out "stones.txt" s))
(when (not done)
(set! done (stones-relax s 0.1))
(stones-update s))
(when done (printf "done~n")))
(every-frame (animate))

23
plant-eyes/test-scripts/earth2.scm Normal file
View file

@ -0,0 +1,23 @@
(define models (list
; "meshes/fork.obj"
"meshes/stone1.obj"
"meshes/stone2.obj"
"meshes/stone3.obj"))
(define (choose l)
(list-ref l (random (length l))))
(clear)
(for ((i (in-range 0 10)))
(with-state
(texture (load-texture "textures/quartz.png"))
(translate (vmul (srndvec) 10))
(rotate (vmul (rndvec) 360))
(scale 0.5)
(load-primitive (choose models))))

0
plant-eyes/extrude.scm → plant-eyes/test-scripts/extrude.scm
View file

96
plant-eyes/test-scripts/fin-test.scm Normal file
View file

@ -0,0 +1,96 @@
; an example of the fluxus extrusion tool
(require scheme/class)
(define min-fin-len 3)
(define fin-length-var 6)
(define fin-grow-prob 2)
(define max-fins-per-twig 5)
(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 (+ 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)))
(clear)
(clear-colour 0.5)
(define profile (build-circle-profile 12 0.5))
(define width (build-list 20
(lambda (n) (* n 0.01 (+ 1.5 (cos (* 0.5 n)))))))
(define path (build-list 20
(lambda (n) (vadd (vector 1 0 0) (vmul (vector (sin (* 0.2 n)) 0 (cos (* 0.2 n))) (* 0.05 n))))))
(define p (with-state
(wire-colour 0)
(colour (vector 1 1 1))
(specular (vector 1 1 1))
(shinyness 20)
(hint-wire)
; (hint-normal)
(build-extrusion profile path width 10 (vector 0 1 0))))
(define fins (build-list 10
(lambda (_)
(let ((f (make-object fin% 0.5 p (vector 1 1 1) (length path) (length profile))))
(send f build)
f))))
(every-frame (for-each
(lambda (f)
(send f update (time) (delta)))
fins))
#;(define (animate)
(with-primitive p
(partial-extrude
(* (* 0.5 (+ 1 (sin (* 1 (time))))) (+ (length path) 5))
profile path width (vector 0 1 0) 0.05)))
#;(every-frame (animate))

96
plant-eyes/test-scripts/insect-test.scm Normal file
View file

@ -0,0 +1,96 @@
(require scheme/class)
(define insect-view%
(class object%
(init-field
(id 0)
(from (vector 0 0 0))
(type 'none))
(field
(to (vector 0 0 0))
(from-dir (vector 1 0 0))
(to-dir (vector 1 0 0))
(time 0)
(tick 1))
(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 (update t d)
(set! time (+ 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)
(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
(when (> anim-t anim-d)
(set! anim-t 0)
(set! blendshape (modulo (+ blendshape 1) 3))
(set-blendshape blendshape))
(identity)
(let ((h (hermite-tangent from to (vmul from-dir 2) (vmul to-dir 2) (/ time tick))
#;(vlerp-tangent from to (/ time tick))))
(translate (car h))
(concat (maim (vector 0 0 1) (vnormalise (cadr h))))
(scale 1)))
(set! time (+ time d))
(set! anim-t (+ anim-t d)))
(super-new)))
(clear)
(clear-colour 0.5)
(define s (make-object spider-insect-view% 0 (vector 0 0 0) 'spider))
(define t 0)
(every-frame
(begin
(when (> (time) t)
(set! t (+ (time) 1))
(send s move (vmul (srndvec) 10) 1))
(send s update (time) (delta))))

0
plant-eyes/plant-eyes-proto.scm → plant-eyes/test-scripts/plant-eyes-proto.scm
View file

0
plant-eyes/ribbontest.scm → plant-eyes/test-scripts/ribbontest.scm
View file

37
plant-eyes/test-scripts/ripple.scm Normal file
View file

@ -0,0 +1,37 @@
(define (ripple t speed wave-length)
(define (pre-ripple p)
(for-each
(lambda (p)
(with-primitive p
(when (not (pdata-exists? "rip-pref"))
(pdata-copy "p" "rip-pref"))
(pre-ripple p)))
(get-children)))
(define (do-ripple p t)
(for-each
(lambda (p)
(with-primitive p
(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")
(do-ripple p t)))
(get-children)))
(pre-ripple 1)
(do-ripple 1 t))
(clear)
(build-cube)
(translate (rndvec))
(build-torus 0.1 2 30 30)
(every-frame (ripple (time) 5 0.001))

47
plant-eyes/test-scripts/serialise-test.scm Normal file
View file

@ -0,0 +1,47 @@
#lang scheme
(define (value->string a)
(cond
((number? a) (string-append "n:" (number->string a)))
((string? a) (string-append "s:" a))
((vector? a) (string-append "v:" (number->string (vector-ref a 0)) ","
(number->string (vector-ref a 1)) ","
(number->string (vector-ref a 2))))
((symbol? a) (string-append "y:" (symbol->string a)))
(else (error "unsupported arg type for " a))))
(define (nvpairs->string l s)
(cond
((null? l) s)
(else
(nvpairs->string (cdr l) (string-append s (symbol->string (caar l)) "="
(value->string (cadr (car l))) " ")))))
(define (string->value a)
(cond
((string=? (car a) "n") (string->number (cadr a)))
((string=? (car a) "s") (cadr a))
((string=? (car a) "v")
(let ((v (string-split (cadr a) #\,)))
(vector (string->number (list-ref v 0))
(string->number (list-ref v 1))
(string->number (list-ref v 2)))))
((string=? (car a) "y") (string->symbol (cadr a)))
(else (error "unsupported value type for " a))))
(define (string->nvpairs s l)
(map
(lambda (pair)
(let ((nv (string-split pair #\=)))
(list (string->symbol (car nv))
(string->value (string-split (cadr nv) #\:)))))
(string-split s #\ )))
(define ser (nvpairs->string (list
(list 'one 2)
(list 'two "three")
(list 'three (vector 1 2 3))
(list 'four 'hello)) ""))
(string->nvpairs ser '())

20
plant-eyes/test-scripts/shader-test.scm Normal file
View file

@ -0,0 +1,20 @@
(clear)
(clear-shader-cache)
(clear-texture-cache)
(let ((l (make-light 'point 'free)))
(light-diffuse 0 (vector 0 0 0))
(light-diffuse l (vector 1 1 1))
(light-position l (vector 10 50 -4)))
(with-primitive (with-state
(colour (vector 0.5 1 0.4))
(shader "shaders/twig.vert.glsl" "shaders/twig.frag.glsl")
(multitexture 0 (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"))
(build-torus 1 2 20 20))
(shader-set! (list "Maps" (list 0 1 2) "NormalMap" 3)))

25
plant-eyes/test-scripts/spark.scm Normal file
View file

@ -0,0 +1,25 @@
(clear)
(texture (load-texture "textures/spark.png"))
(hint-unlit)
(define (build-pickup x y)
(let ((p (build-ribbon 30)))
(with-primitive p
(pdata-index-map!
(lambda (i p)
(vector (cos (/ i x)) (sin (/ i y)) (/ i (pdata-size))))
"p")
(pdata-index-map!
(lambda (i p)
(* 0.3 (sin (* 3.141 (/ i (pdata-size))))))
"w")
(pdata-map!
(lambda (c)
(vector 1 1 1))
"c"))
p))
(build-pickup 5 3)

37
plant-eyes/test-scripts/spider.scm Normal file
View file

@ -0,0 +1,37 @@
(clear)
(clear-geometry-cache)
(hint-unlit)
(colour 0)
(define p (load-primitive "meshes/spider-1.obj"))
(clear-colour 0.5)
(define (add-blendshape key model)
(let ((b (load-primitive model))
(pname (string-append "p" (number->string key)))
(nname (string-append "n" (number->string key))))
(pdata-add pname "v")
(pdata-add nname "v")
(pdata-index-map!
(lambda (i p)
(with-primitive b (pdata-ref "p" i)))
pname)
(pdata-index-map!
(lambda (i n)
(with-primitive b (pdata-ref "p" i)))
nname)
(destroy b)))
(define (set-blendshape key)
(pdata-copy (string-append "p" (number->string key)) "p")
(pdata-copy (string-append "n" (number->string key)) "n")
(recalc-normals 0))
(with-primitive p
(pdata-copy "p" "p0")
(pdata-copy "n" "n0")
(add-blendshape 1 "meshes/spider-2.obj")
(add-blendshape 2 "meshes/spider-3.obj"))
(every-frame
(with-primitive p
(set-blendshape (modulo (inexact->exact (round (* (time) 5))) 3))))

300
plant-eyes/test-scripts/twiglets.scm Normal file
View file

@ -0,0 +1,300 @@
(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")

150
plant-eyes/test-scripts/worm-test.scm Normal file
View file

@ -0,0 +1,150 @@
(require scheme/class)
(define (worm-colour) (vector 1 1 1))
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; slow implementation of hermite curves for animation
(define (hermite s p1 p2 t1 t2)
; the bernstein polynomials
(define (h1 s)
(+ (- (* 2 (expt s 3))
(* 3 (expt s 2))) 1))
(define (h2 s)
(+ (* -2 (expt s 3))
(* 3 (expt s 2))))
(define (h3 s)
(+ (- (expt s 3) (* 2 (expt s 2))) s))
(define (h4 s)
(- (expt s 3) (expt s 2)))
(vadd
(vadd
(vmul p1 (h1 s))
(vmul p2 (h2 s)))
(vadd
(vmul t1 (h3 s))
(vmul t2 (h4 s)))))
; slow, stupid version for getting the tangent - not in the mood for
; maths today to see how you derive it directly, must be pretty simple
(define (hermite-tangent t p1 p2 t1 t2)
(let ((p (hermite t p1 p2 t1 t2)))
(list p (vsub (hermite (- t 0.01) p1 p2 t1 t2) p))))
(define insect-view%
(class object%
(init-field
(id 0)
(from (vector 0 0 0))
(type 'none))
(field
(to (vector 0 0 0))
(from-dir (vector 1 0 0))
(to-dir (vector 1 0 0))
(time 0)
(tick 0))
(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 (update t d)
#;(when (< time tick)
(with-primitive root
(identity)
(let ((h (hermite-tangent (/ time tick) from to (vmul from-dir 2) (vmul to-dir 2))
#;(lerp-tangent (/ time tick) from to)))
(translate (car h))
(concat (maim (vector 0 0 1) (vnormalise (cadr h))))
(scale 0.2))))
(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 (vector 0 0 0))
(from-dir2 (vector 0 0 0))
(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 (+ 2 (* 2 (rndf)))))
(pdata-index-map!
(lambda (i w)
width)
"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/public (get-pos)
to)
(define/public (get-dir)
to-dir)
(define/override (update t d)
(let ((nt (/ time tick))) ; normalise time
(with-primitive root
(pdata-index-map!
(lambda (i p)
(let ((st (- nt (* i 0.05))))
(if (< st 0)
(hermite (+ st 1) from2 from (vmul from-dir2 2) (vmul from-dir 2))
(hermite st from to (vmul from-dir 2) (vmul to-dir 2)))))
"p")))
(set! time (+ time d)))
(super-new)))
(clear)
(clear-colour 0.5)
(define w (make-object worm-insect-view% 0 (srndvec)))
(send w move (srndvec) 1)
(define next 0)
(every-frame
(begin
(when (> (time) next)
(printf "~a~n" (send w get-dir))
(send w move (vmul (srndvec) 10) 5)
(set! next (+ (time) 5)))
(send w update (time) (delta))))