diff --git a/plant-eyes/README b/plant-eyes/README index 792629e..7483ee2 100644 --- a/plant-eyes/README +++ b/plant-eyes/README @@ -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) diff --git a/plant-eyes/plant-eyes.scm b/plant-eyes/plant-eyes.scm index 2ba6bb4..5ffd1db 100644 --- a/plant-eyes/plant-eyes.scm +++ b/plant-eyes/plant-eyes.scm @@ -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)))) diff --git a/plant-eyes/client.ss b/plant-eyes/scripts/client.ss similarity index 95% rename from plant-eyes/client.ss rename to plant-eyes/scripts/client.ss index 2fe6e7b..9469740 100644 --- a/plant-eyes/client.ss +++ b/plant-eyes/scripts/client.ss @@ -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 diff --git a/plant-eyes/controller.ss b/plant-eyes/scripts/controller.ss similarity index 97% rename from plant-eyes/controller.ss rename to plant-eyes/scripts/controller.ss index 96977c8..31665c5 100644 --- a/plant-eyes/controller.ss +++ b/plant-eyes/scripts/controller.ss @@ -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 diff --git a/plant-eyes/game-modes.ss b/plant-eyes/scripts/game-modes.ss similarity index 95% rename from plant-eyes/game-modes.ss rename to plant-eyes/scripts/game-modes.ss index c1242bb..506f056 100644 --- a/plant-eyes/game-modes.ss +++ b/plant-eyes/scripts/game-modes.ss @@ -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)) diff --git a/plant-eyes/jabberer.ss b/plant-eyes/scripts/jabberer.ss similarity index 96% rename from plant-eyes/jabberer.ss rename to plant-eyes/scripts/jabberer.ss index 2d65908..29bca81 100644 --- a/plant-eyes/jabberer.ss +++ b/plant-eyes/scripts/jabberer.ss @@ -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)) diff --git a/plant-eyes/list-utils.ss b/plant-eyes/scripts/list-utils.ss similarity index 91% rename from plant-eyes/list-utils.ss rename to plant-eyes/scripts/list-utils.ss index bb7f049..e274ee4 100644 --- a/plant-eyes/list-utils.ss +++ b/plant-eyes/scripts/list-utils.ss @@ -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)) @@ -47,4 +49,4 @@ (cond ((null? l) #f) ((eq? (car l) k) n) - (else (which-element k (cdr l) (+ n 1))))) \ No newline at end of file + (else (which-element k (cdr l) (+ n 1))))) diff --git a/plant-eyes/logic.ss b/plant-eyes/scripts/logic.ss similarity index 99% rename from plant-eyes/logic.ss rename to plant-eyes/scripts/logic.ss index c38ac5a..1439e4a 100644 --- a/plant-eyes/logic.ss +++ b/plant-eyes/scripts/logic.ss @@ -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 diff --git a/plant-eyes/message.ss b/plant-eyes/scripts/message.ss similarity index 95% rename from plant-eyes/message.ss rename to plant-eyes/scripts/message.ss index a3cf23f..999f0a2 100644 --- a/plant-eyes/message.ss +++ b/plant-eyes/scripts/message.ss @@ -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)) ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/plant-eyes/ornament-views.ss b/plant-eyes/scripts/ornament-views.ss similarity index 98% rename from plant-eyes/ornament-views.ss rename to plant-eyes/scripts/ornament-views.ss index a5871cd..442b6ee 100644 --- a/plant-eyes/ornament-views.ss +++ b/plant-eyes/scripts/ornament-views.ss @@ -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) diff --git a/plant-eyes/sound.ss b/plant-eyes/scripts/sound.ss similarity index 82% rename from plant-eyes/sound.ss rename to plant-eyes/scripts/sound.ss index 9cd4972..dafaf3b 100644 --- a/plant-eyes/sound.ss +++ b/plant-eyes/scripts/sound.ss @@ -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)) diff --git a/plant-eyes/view.ss b/plant-eyes/scripts/view.ss similarity index 98% rename from plant-eyes/view.ss rename to plant-eyes/scripts/view.ss index dd491fa..9940170 100644 --- a/plant-eyes/view.ss +++ b/plant-eyes/scripts/view.ss @@ -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,15 +612,12 @@ (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)) - (set! twigs (cons + (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) @@ -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) diff --git a/plant-eyes/xmpp.ss b/plant-eyes/scripts/xmpp.ss similarity index 100% rename from plant-eyes/xmpp.ss rename to plant-eyes/scripts/xmpp.ss diff --git a/plant-eyes/test-scripts/butterflies.scm b/plant-eyes/test-scripts/butterflies.scm new file mode 100644 index 0000000..622deb9 --- /dev/null +++ b/plant-eyes/test-scripts/butterflies.scm @@ -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)) \ No newline at end of file diff --git a/plant-eyes/test-scripts/camera-dir.scm b/plant-eyes/test-scripts/camera-dir.scm new file mode 100644 index 0000000..eb3053d --- /dev/null +++ b/plant-eyes/test-scripts/camera-dir.scm @@ -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))))) \ No newline at end of file diff --git a/plant-eyes/test-scripts/classtest.scm b/plant-eyes/test-scripts/classtest.scm new file mode 100644 index 0000000..b415071 --- /dev/null +++ b/plant-eyes/test-scripts/classtest.scm @@ -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) \ No newline at end of file diff --git a/plant-eyes/test-scripts/dust.scm b/plant-eyes/test-scripts/dust.scm new file mode 100644 index 0000000..24ed48e --- /dev/null +++ b/plant-eyes/test-scripts/dust.scm @@ -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)) \ No newline at end of file diff --git a/plant-eyes/test-scripts/earth.scm b/plant-eyes/test-scripts/earth.scm new file mode 100644 index 0000000..ae78b3b --- /dev/null +++ b/plant-eyes/test-scripts/earth.scm @@ -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)) + + \ No newline at end of file diff --git a/plant-eyes/test-scripts/earth2.scm b/plant-eyes/test-scripts/earth2.scm new file mode 100644 index 0000000..b1671cd --- /dev/null +++ b/plant-eyes/test-scripts/earth2.scm @@ -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)))) + + + + + diff --git a/plant-eyes/extrude.scm b/plant-eyes/test-scripts/extrude.scm similarity index 100% rename from plant-eyes/extrude.scm rename to plant-eyes/test-scripts/extrude.scm diff --git a/plant-eyes/test-scripts/fin-test.scm b/plant-eyes/test-scripts/fin-test.scm new file mode 100644 index 0000000..6114699 --- /dev/null +++ b/plant-eyes/test-scripts/fin-test.scm @@ -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)) + diff --git a/plant-eyes/test-scripts/insect-test.scm b/plant-eyes/test-scripts/insect-test.scm new file mode 100644 index 0000000..d24c772 --- /dev/null +++ b/plant-eyes/test-scripts/insect-test.scm @@ -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)))) + diff --git a/plant-eyes/plant-eyes-proto.scm b/plant-eyes/test-scripts/plant-eyes-proto.scm similarity index 100% rename from plant-eyes/plant-eyes-proto.scm rename to plant-eyes/test-scripts/plant-eyes-proto.scm diff --git a/plant-eyes/ribbontest.scm b/plant-eyes/test-scripts/ribbontest.scm similarity index 100% rename from plant-eyes/ribbontest.scm rename to plant-eyes/test-scripts/ribbontest.scm diff --git a/plant-eyes/test-scripts/ripple.scm b/plant-eyes/test-scripts/ripple.scm new file mode 100644 index 0000000..95443cd --- /dev/null +++ b/plant-eyes/test-scripts/ripple.scm @@ -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)) + diff --git a/plant-eyes/test-scripts/serialise-test.scm b/plant-eyes/test-scripts/serialise-test.scm new file mode 100644 index 0000000..e67c45f --- /dev/null +++ b/plant-eyes/test-scripts/serialise-test.scm @@ -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 '()) \ No newline at end of file diff --git a/plant-eyes/test-scripts/shader-test.scm b/plant-eyes/test-scripts/shader-test.scm new file mode 100644 index 0000000..da968c5 --- /dev/null +++ b/plant-eyes/test-scripts/shader-test.scm @@ -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))) \ No newline at end of file diff --git a/plant-eyes/test-scripts/spark.scm b/plant-eyes/test-scripts/spark.scm new file mode 100644 index 0000000..eafd714 --- /dev/null +++ b/plant-eyes/test-scripts/spark.scm @@ -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) \ No newline at end of file diff --git a/plant-eyes/test-scripts/spider.scm b/plant-eyes/test-scripts/spider.scm new file mode 100644 index 0000000..172e962 --- /dev/null +++ b/plant-eyes/test-scripts/spider.scm @@ -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)))) diff --git a/plant-eyes/test-scripts/twiglets.scm b/plant-eyes/test-scripts/twiglets.scm new file mode 100644 index 0000000..e393dec --- /dev/null +++ b/plant-eyes/test-scripts/twiglets.scm @@ -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") + diff --git a/plant-eyes/test-scripts/worm-test.scm b/plant-eyes/test-scripts/worm-test.scm new file mode 100644 index 0000000..4c3451c --- /dev/null +++ b/plant-eyes/test-scripts/worm-test.scm @@ -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))))