diff --git a/plant-eyes/plant-eyes.scm b/plant-eyes/plant-eyes.scm index 860002a..ecd4ef4 100644 --- a/plant-eyes/plant-eyes.scm +++ b/plant-eyes/plant-eyes.scm @@ -1,5 +1,5 @@ -#lang scheme/base -(require fluxus-016/drflux) +;#lang scheme/base +;(require fluxus-016/drflux) (require scheme/class) ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -32,29 +32,35 @@ ; * 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) +(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 wire-mode #f) +(define fog-col (earth-colour)) +(define fog-strength 0.001) + (define debug-messages #f) ; prints out all the messages sent to the renderer -(define logic-tick 1) ; time between logic updates +(define logic-tick 0.5) ; time between logic updates (define branch-probability 6) ; as in one in branch-probability chance (define branch-width-reduction 0.5) (define twig-jitter 0.1) (define branch-jitter 0.5) -(define max-twig-points 20) -(define start-twig-dist 0.3) -(define start-twig-width 0.3) +(define max-twig-points 30) +(define start-twig-dist 0.05) +(define start-twig-width 0.2) (define default-max-twigs 10) (define default-scale-factor 1.05) -(define default-grow-speed 1) +(define default-grow-speed (/ 1 logic-tick)) (define root-camera-time (* max-twig-points logic-tick)) (define num-pickups 10) -(define pickup-dist-radius 20) +(define pickup-dist-radius 200) (define pickup-size 1) (define max-ornaments 2) ; per twig (define ornament-grow-probability 4) (define curl-amount 40) - -(define (ornament-colour) (vector 0.5 1 0.4)) -(define (pickup-colour) (vector 1 1 1)) +(define start-size 50) (define (assoc-remove k l) (cond @@ -133,6 +139,7 @@ (define twig-logic% (class game-logic-object% (init-field + (last-point (vector 0 0 0)) (id #f) ; our id (for matching up with the renderer geometry) (plant #f) ; the plant we belong to (type 'root) ; or 'shoot @@ -144,13 +151,17 @@ (field (points '()) ; the 3d points for this twig + (widths '()) (twigs '()) ; children are stored with the point number they are connected to. (ornaments '()) ; the things attached to this twig, an assoc list with point index - (last-point (vector 0 0 0)) ; distance between points (branch #f) ; are we a main branch twig? + (w 0) ; the width of this segment (curl (vmul (crndvec) curl-amount))) ; the angles to turn each point, if curly (inherit send-message) + + (define/public (set-pos s) + (set! last-point s)) (define/public (get-id) id) @@ -195,42 +206,41 @@ (when (< (length points) num-points) (let ((new-point (if (zero? (length points)) ; first point should be at edge of the seed if we are a branch - (if branch (vmul dir 1) (vector 0 0 0)) + (if branch (vadd last-point (vmul dir dist)) + last-point) (vadd last-point (vmul dir dist))))) - (set! dir (vmix dir ndir 0.5)) - - #;(cond (curly - (set! dir (vtransform dir (mrotate curl))) - (when (not branch) - (set! curl (vmul curl 1.2)) - (set! dist (* dist 0.9)))) - (else - (set! dir (vadd dir (vmul (srndvec) twig-jitter))))) + (set! dir ndir) + (set! w (* width (- 1 (/ (length points) num-points)))) (set! last-point new-point) (set! points (append points (list new-point))) + (set! widths (append widths (list w))) (send-message 'twig-grow (list (list 'plant-id (send plant get-id)) (list 'twig-id id) - (list 'point new-point)))) - (when (and (> (length points) 1) (> num-points 1) + (list 'point new-point) + (list 'width w))) + #;(when (and (> (length points) 1) (> num-points 1) (zero? (random branch-probability))) - (add-twig (- (length points) 1) - (make-object twig-logic% (send plant get-next-twig-id) - plant - type - (vadd dir (vmul (srndvec) branch-jitter)) - (* width branch-width-reduction) - (quotient num-points 2) - render-type - dist)))) + (add-twig (- (length points) 1) (vadd dir (vmul (srndvec) branch-jitter)))))) (for-each (lambda (twig) (send (cadr twig) grow ndir)) twigs)) - (define/public (add-twig point-index twig) + (define/public (add-twig point-index dir) + (let ((twig (make-object twig-logic% + (get-point point-index) + (send plant get-next-twig-id) + plant + type + dir + (list-ref widths point-index) + (quotient num-points 2) + render-type + dist))) + (send-message 'new-twig (list (list 'plant-id (send plant get-id)) (list 'parent-twig-id id) @@ -242,7 +252,8 @@ (list 'num-points (send twig get-num-points)) (list 'render-type (send twig get-render-type)) )) - (set! twigs (cons (list point-index twig) twigs))) + (set! twigs (cons (list point-index twig) twigs)) + twig)) (define/public (get-twig point-index) (cadr (assq point-index twigs))) @@ -377,7 +388,7 @@ (twigs '()) ; a assoc list map of ages to twigs (properties '()) ; a list of symbols - properties come from pickups (ornaments '()) ; map of ids to ornaments on the plant - (size 5) ; the age of this plant + (size start-size) ; the age of this plant (max-twigs default-max-twigs) ; the maximum twigs allowed at any time - oldest removed first (next-twig-id 0) (next-ornament-id 0) @@ -442,6 +453,7 @@ (set! size (* size grow-amount)) (send twig scale size) (send twig set-branch! #t) + (send twig set-pos pos) (send-message 'grow-seed (list (list 'plant-id id) @@ -702,10 +714,10 @@ (define/public (add-child-twig-id twig-id) (set! child-twig-ids (cons twig-id child-twig-ids))) - (define/pubment (grow point) + (define/pubment (grow point width) (let ((growing-noise (oa-load-sample (fullpath "snd/event01.wav")))) (oa-play growing-noise (vector 0 0 0) (rndf) 0.3)) - (inner (void) grow point)) + (inner (void) grow point width)) (define/public (add-ornament point-index property) (when (< (length ornaments) max-ornaments) @@ -761,7 +773,7 @@ (with-primitive root (pdata-ref "p" point-index))) - (define/augment (grow point) + (define/augment (grow point width) (with-primitive root (pdata-index-map! ; set all the remaining points to the end (lambda (i p) ; in order to hide them @@ -773,7 +785,7 @@ (lambda (i w) (if (< i (+ index 1)) w - radius)) + width)) "w")) (set! index (+ index 1))) @@ -798,25 +810,20 @@ (widths '())) (define/override (build) - (set! profile (build-circle-profile 7 1)) - (set! path (build-list num-points (lambda (n) (vector 0 0 0)))) - (set! widths (build-list num-points (lambda (n) (let ((t (/ n num-points))) - (if (eq? n (- num-points 1)) 0 - (* radius - (if (zero? t) 1 - (+ (* t 0.5) - (* (- (/ 1 t) 1) 0.1))))))))) + (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) - ;(hint-none) - ;(hint-wire) - (translate pos) - (texture (load-texture "textures/skin.png")) - (opacity 0.6) + (when wire-mode + (hint-none) + (hint-wire)) + (texture (load-texture "textures/root2.png")) + ;(opacity 0.6) (colour (vmul (vector 0.8 1 0.6) 2)) #;(colour (vector 1 1 1)) #;(texture (load-texture "textures/root.png")) - (build-partial-extrusion profile path 6)))) + (build-partial-extrusion profile path 3)))) p))) (define/override (get-root) @@ -830,22 +837,21 @@ ((zero? c) (cons s (list-set (cdr l) (- c 1) s))) (else (cons (car l) (list-set (cdr l) (- c 1) s))))) - (define/augment (grow point) - #;(when (zero? index) (set! path (list-set path index point))) - (set! path (list-set path (+ index 1) point)) + (define/augment (grow point width) + (set! path (list-set path index point)) + (set! widths (list-set widths index width)) (set! anim-t 0) (set! index (+ index 1))) - (define/augment (update t d) + (define/augment (update t d) (when (< anim-t 1) (with-primitive root - (partial-extrude (+ (- index 1) anim-t) + (partial-extrude (+ (- index 2) anim-t) profile path widths (vector 1 0 0) 0.05))) (set! anim-t (+ anim-t (* d grow-speed)))) (define/public (get-end-pos) - (with-primitive root - (pdata-ref "p" (* index (length profile))))) + (with-primitive root (pdata-ref "p" (- (* index (length profile)) 1)))) (super-new))) @@ -866,13 +872,16 @@ (build-locator))) (seed (with-state (parent root) - (texture (load-texture "textures/skin.png")) + (texture (load-texture "textures/root2.png")) (backfacecull 0) (opacity 0.6) (colour (vector 0.8 1 0.6)) (hint-depth-sort) - (scale 0.5) - (hint-unlit) + (scale (* 0.12 start-size)) + (when wire-mode + (hint-none) + (hint-wire)) + ;(hint-unlit) (load-primitive "meshes/seed.obj")))) (define/public (get-id) @@ -901,12 +910,12 @@ (define/public (add-twig parent-twig-id point-index twig) (let ((ptwig (get-twig parent-twig-id))) - ; attach to parent twig - (with-primitive (send twig get-root) - (parent (send ptwig get-root))) - + ; attach to parent twig (send twig set-pos! (send ptwig get-point point-index)) (send twig build) + (with-primitive (send twig get-root) + (parent (send ptwig get-root))) + ; tell the twigs about this relationship (might turn out to be overkill) (send ptwig add-child-twig-id (send twig get-id)) @@ -914,8 +923,8 @@ (set! twigs (cons (list (send twig get-id) twig) twigs)))) - (define/public (grow-twig twig-id point) - (send (get-twig twig-id) grow point)) + (define/public (grow-twig twig-id point width) + (send (get-twig twig-id) grow point width)) (define/public (grow-seed amount) (with-primitive seed (scale amount))) @@ -937,16 +946,22 @@ ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -(define (build-env-box top bottom left right front back) +(define (build-env-box top bottom left right front back lower) (let ((p (build-locator))) (with-state (parent p) (hint-unlit) - (with-state + + (let ((t (with-state (texture (load-texture top)) (translate (vector 0 0.5 0)) (rotate (vector 90 0 0)) - (build-plane)) + (build-plane)))) + (when lower (with-primitive t + (pdata-map! + (lambda (t) + (vmul t 10)) + "t")))) (with-state (texture (load-texture left)) @@ -972,11 +987,13 @@ (rotate (vector 0 90 0)) (build-plane)) - (with-state + (when lower + (with-state (texture (load-texture bottom)) (translate (vector 0 -0.5 0)) - (rotate (vector 90 0 0)) - (build-plane)) + (rotate (vector 90 0 0)) + (build-plane))) + p))) ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -988,7 +1005,7 @@ (plants '()) ; map of ids -> plants (pickups '()) ; map of ids -> pickups (camera-dist 1) - (env-root (with-state (scale 20) (build-locator))) + (env-root (with-state (scale 1000) (build-locator))) (root-camera-t 0) #;(upper-env (with-state (parent env-root) @@ -1005,6 +1022,23 @@ (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))) (nutrients (let ((p (with-state (hint-depth-sort) (texture (load-texture "textures/particle.png")) @@ -1012,7 +1046,7 @@ (with-primitive p (pdata-map! (lambda (p) - (vmul (vadd (crndvec) (vector 0 -1 0)) 90)) + (vmul (vadd (crndvec) (vector 0 -1 0)) 900)) "p") (pdata-map! (lambda (s) @@ -1026,10 +1060,9 @@ (light-diffuse l (vector 1 1 1)) (light-position l (vector 10 50 -4))) - (clear-colour (vector 0.5 0.3 0.2)) - - (fog (vector 0.5 0.3 0.2) 0.02 1 100) - #;(fog (vector 0.2 0.5 0.3) 0.02 1 100)) + (clear-colour fog-col) + (clip 0.5 10000) + (fog fog-col fog-strength 1 100)) (define/public (add-plant plant) (set! plants (cons (list (send plant get-id) plant) plants))) @@ -1146,7 +1179,8 @@ ((eq? (send msg get-name) 'twig-grow) (send (get-plant (send msg get-data 'plant-id)) grow-twig (send msg get-data 'twig-id) - (send msg get-data 'point))) + (send msg get-data 'point) + (send msg get-data 'width))) ((eq? (send msg get-name) 'new-pickup) (add-pickup @@ -1210,22 +1244,29 @@ (define/public (setup) (lock-camera cam) - (camera-lag 0.1) + (camera-lag 0.2) (clip 1 1000) - (set-camera-transform (mtranslate (vector 0 0 -1)))) + (set-camera-transform (mtranslate (vector 0 0 -4)))) (define/public (update) (when (key-pressed-this-frame " ") - (set! current-twig (make-object twig-logic% 0 player-plant 'root - (vmul fwd -1) - start-twig-width max-twig-points 'extruded)) + (cond ((and current-twig (not current-twig-growing)) + (let ((new-twig (send current-twig add-twig current-point + (vector 0 1 0) #;(vsub (send current-twig get-point current-point) + (send current-twig get-point (- current-point 1)))))) + (set! current-twig-growing #t) + (set! current-twig new-twig))) + (else + (set! current-twig (make-object twig-logic% (vector 0 0 0) 0 player-plant 'root + (vmul fwd -1) + start-twig-width max-twig-points 'extruded)) (send player-plant add-twig current-twig) - (set! current-twig-growing #t)) + (set! current-twig-growing #t)))) - (when (or (key-pressed "a") (key-special-pressed 100)) (set! yaw (+ yaw 1))) - (when (or (key-pressed "d") (key-special-pressed 102)) (set! yaw (- yaw 1))) - (when (or (key-pressed "w") (key-special-pressed 101)) (set! tilt (+ tilt 1))) - (when (or (key-pressed "s") (key-special-pressed 103)) (set! tilt (- tilt 1))) + (when (or (key-pressed "a") (key-special-pressed 100)) (set! yaw (+ yaw 2))) + (when (or (key-pressed "d") (key-special-pressed 102)) (set! yaw (- yaw 2))) + (when (or (key-pressed "w") (key-special-pressed 101)) (set! tilt (+ tilt 2))) + (when (or (key-pressed "s") (key-special-pressed 103)) (set! tilt (- tilt 2))) ; clamp tilt to prevent gimbal lock (when (> tilt 88) (set! tilt 88)) @@ -1233,7 +1274,7 @@ (when (key-pressed-this-frame "q") (cond ((not current-twig) - (set! current-twig (send player-plant get-twig-from-dir (vmul fwd 1))) + (set! current-twig (send player-plant get-twig-from-dir (vmul fwd -1))) (set! current-point 2)) (else (when (< current-point (- (send current-twig get-num-points) 1)) @@ -1245,33 +1286,35 @@ (when (< current-point 2) (set! current-twig #f) (set! pos (vector 0 0 0)) - (set-camera-transform (mtranslate (vector 0 0 -1))))))) + #;(set-camera-transform (mtranslate (vector 0 0 -1))))))) + + ; get camera fwd vector from key-presses + (set! fwd (vtransform (vector 0 0 1) + (mmul + (mrotate (vector 0 yaw 0)) + (mrotate (vector tilt 0 0))))) + ; if we are on a twig not growing (cond ((and current-twig (not current-twig-growing)) (set! pos (send current-twig get-point current-point)) - (when (> current-point 0) - (set! fwd (vnormalise (vsub (send current-twig get-point (- current-point 1)) - pos))))) + #;(when (> current-point 0) + (set! fwd (vmix fwd (vnormalise (vsub (send current-twig get-point + (- current-point 1)) + pos)) 0.5)))) (else (when current-twig-growing - (set-camera-transform (mtranslate (vector 0 0 0))) (let ((twig-view (send (send game-view get-plant (send player-plant get-id)) get-twig (send current-twig get-id)))) (when twig-view (set! pos (vsub (send twig-view get-end-pos) - (vmul (send current-twig get-dir) 5))))) + (vmul (send current-twig get-dir) 1))))) (when (eq? (send current-twig get-num-points) (send current-twig get-length)) (set! current-twig-growing #f) - (set! current-twig #f))) + (set! current-point (- (send current-twig get-num-points) 1)))))) - ; get camera fwd vector from key-presses - (set! fwd (vtransform (vector 0 0 1) - (mmul - (mrotate (vector 0 yaw 0)) - (mrotate (vector tilt 0 0))))))) (let* ((side (vnormalise (vcross up fwd))) (up (vnormalise (vcross fwd side)))) @@ -1297,14 +1340,14 @@ (send gl setup) (define plant1 (make-object plant-logic% "dave@fo.am" (vector 0 0 0))) -(define plant2 (make-object plant-logic% "plant00001@fo.am" (vector 0 0 9))) +(define plant2 (make-object plant-logic% "plant00001@fo.am" (vector 0 0 90))) (send c set-player-plant plant1) (send gl add-plant plant1) (send gl add-plant plant2) -(send plant2 add-twig (make-object twig-logic% 0 plant2 'root (vector 0 -1 0) start-twig-width 10 'ribbon)) +(send plant2 add-twig (make-object twig-logic% (vector 0 0 0) 0 plant2 'root (vector 0 -1 0) start-twig-width 10 'ribbon)) (define tick-time 0) diff --git a/plant-eyes/textures/earth-bottom.png b/plant-eyes/textures/earth-bottom.png new file mode 100644 index 0000000..7c24668 Binary files /dev/null and b/plant-eyes/textures/earth-bottom.png differ diff --git a/plant-eyes/textures/earth-side.png b/plant-eyes/textures/earth-side.png new file mode 100644 index 0000000..444e4b8 Binary files /dev/null and b/plant-eyes/textures/earth-side.png differ diff --git a/plant-eyes/textures/earth-top.png b/plant-eyes/textures/earth-top.png new file mode 100644 index 0000000..bcbbd3c Binary files /dev/null and b/plant-eyes/textures/earth-top.png differ diff --git a/plant-eyes/textures/floor.png b/plant-eyes/textures/floor.png new file mode 100644 index 0000000..3d33b2f Binary files /dev/null and b/plant-eyes/textures/floor.png differ diff --git a/plant-eyes/textures/grid.png b/plant-eyes/textures/grid.png new file mode 100644 index 0000000..f27b9a3 Binary files /dev/null and b/plant-eyes/textures/grid.png differ diff --git a/plant-eyes/textures/root2.png b/plant-eyes/textures/root2.png new file mode 100644 index 0000000..f33be6b Binary files /dev/null and b/plant-eyes/textures/root2.png differ diff --git a/plant-eyes/textures/sky-side.png b/plant-eyes/textures/sky-side.png new file mode 100644 index 0000000..150fbea Binary files /dev/null and b/plant-eyes/textures/sky-side.png differ diff --git a/plant-eyes/textures/sky-top.png b/plant-eyes/textures/sky-top.png new file mode 100644 index 0000000..8c8c09d Binary files /dev/null and b/plant-eyes/textures/sky-top.png differ diff --git a/plant-eyes/textures/v5roots.png b/plant-eyes/textures/v5roots.png new file mode 100644 index 0000000..93c0ef6 Binary files /dev/null and b/plant-eyes/textures/v5roots.png differ diff --git a/plant-eyes/textures/v5roots2.png b/plant-eyes/textures/v5roots2.png new file mode 100644 index 0000000..39b2a57 Binary files /dev/null and b/plant-eyes/textures/v5roots2.png differ diff --git a/roots/roots.scm b/roots/roots.scm index 85f54d5..6e38e21 100644 --- a/roots/roots.scm +++ b/roots/roots.scm @@ -8,16 +8,16 @@ (vector x y 0))) (define (build-ellipse rmin rmaj num-verts) - (define p (build-polygons (* 3 num-verts) 'triangle-list)) + (define p (build-polygons num-verts 'polygon)) (with-primitive p - (for ([i (in-range 0 (* 3 num-verts) 3) ]) - (pdata-set! "p" i (vector 0 0 0)) - (pdata-set! "n" i (vector 0 0 1)) - (pdata-set! "p" (+ i 1) (calc-xyz (/ i 3) num-verts rmin)) - (pdata-set! "n" (+ i 1) (vnormalise (calc-xyz (/ i 3) num-verts rmin))) - (pdata-set! "p" (+ i 2) (calc-xyz (+ (/ i 3) 1) num-verts rmin)) - (pdata-set! "n" (+ i 2) (vnormalise (calc-xyz (+ (/ i 3) 1) num-verts rmin)))) - (poly-convert-to-indexed)) + (for ([i (in-range 0 num-verts)]) + ;(pdata-set! "p" i (vector 0 0 0)) + ;(pdata-set! "n" i (vector 0 0 1)) + (pdata-set! "p" i (calc-xyz i num-verts rmin)) + #;(pdata-set! "n" i (vnormalise (calc-xyz i num-verts rmin))) + ;(pdata-set! "p" (+ i 2) (calc-xyz (+ (/ i 3) 1) num-verts rmin)) + #;(pdata-set! "n" (+ i 2) (vnormalise (calc-xyz (+ (/ i 3) 1) num-verts rmin)))) + #;(poly-convert-to-indexed)) p) (define-struct stones ((pos-list #:mutable) size-list (root #:mutable) (obj-list #:mutable))) @@ -42,7 +42,7 @@ (parent root) (map (lambda (pos size) - (if (and (< size 0.4) (zero? (random 3))) + (if (and #f (< size 0.4) (zero? (random 3))) (let ((o (with-state (hint-unlit) (scale 0.2) @@ -51,9 +51,13 @@ (with-primitive o (apply-transform)) o) (with-state - ;(hint-unlit) + ;(hint-none) + (hint-wire) + (hint-unlit) + (line-width 2) + (wire-colour 0) (hint-ignore-depth) - (colour (hsv->rgb (vector (+ 0 (* 0.2 (rndf))) 0.5 (+ 0.1 (rndf))))) + (colour (hsv->rgb (vector (+ -0.1 (* 0.2 (rndf))) 0.5 (+ 0.1 (rndf))))) (translate pos) (build-ellipse size size 32)))) (stones-pos-list stones) @@ -146,12 +150,12 @@ (light-diffuse 0 (vector 0.2 0.2 0.2)) (light-diffuse l (vector 1 1 1)) -(define s (stones-build (stones-init 100 5 1))) +(define s (stones-build (stones-init 1000 5 1))) -(define roots (build-list 10 (lambda (_) (build-root (* 5 (crndf)))))) +#;(define roots (build-list 10 (lambda (_) (build-root (* 5 (crndf)))))) (define (animate) - (for-each + #;(for-each (lambda (root) (with-primitive root (nudge s 0.01)