From a013bb0508718f0fae40b70c43bff488f19afb83 Mon Sep 17 00:00:00 2001 From: Dave Griffiths Date: Wed, 24 Jun 2009 16:34:25 +0100 Subject: [PATCH] logical growth works, added a view side with ribbon roots for preview --- plant-eyes/plant-eyes-logic.scm | 349 +++++++++++++++++++++++++++----- plant-eyes/plant-eyes.scm | 4 +- 2 files changed, 303 insertions(+), 50 deletions(-) diff --git a/plant-eyes/plant-eyes-logic.scm b/plant-eyes/plant-eyes-logic.scm index 71dcaf0..f3a178b 100644 --- a/plant-eyes/plant-eyes-logic.scm +++ b/plant-eyes/plant-eyes-logic.scm @@ -9,25 +9,38 @@ ; notes: ; ; * keeping with a render/logic separation, although this is quite different to -; the hexagon game. the main advantage is that the logic can be ticked at a -; lower frequency - or even different parts at different rates, whereas the -; renderer side needs ticking every frame +; the hexagon game. the main advantages: +; - just a divide and conquer strategy for staying sane +; - able to debug the logic without the renderer, or vice versa +; - the logic can be ticked at a lower frequency - or even different +; parts at different rates, whereas the renderer side needs ticking every +; frame ; -; * need to try to keep all the intensive every thing vs every thing checking +; * the view just knows about line segments for branches/roots, so these can be +; created in any way in the logic side - lsystem, etc - or different ways +; +; * 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 collected up and dispached in the renderer side +; at any point, and have them automatically collected up and dispatched to +; the renderer side ; ; * line segments are computed in the logic side, and can be represented any ; way by the renderer - maybe the players plant will be geometry and everyone ; elses will be ribbons (stoopid LOD) -(define branch-probability 10) ; as in, one in 10 -(define branch-width-reduction 0.95) +(define debug-messages #f) ; prints out all the messages sent to the renderer + +(define branch-probability 3) ; as in one in branch-probability chance +(define branch-width-reduction 0.5) +(define twig-jitter 0.5) +(define branch-jitter 1) +(define max-twig-points 10) +(define start-twig-width 0.1) ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ; a message for sending betwixt logic and render side @@ -39,6 +52,9 @@ ; '((name "archibold") (age 53)) ; shouldn't put logic objects in here - 'raw' data only + (define/public (get-name) + name) + (define/public (get-data arg-name) (cadr (assoc arg-name data))) @@ -72,8 +88,8 @@ (let ((m messages)) ; and call update on them too. (set! messages '()) (append - (flatten (inner (void) update)) ; the augmented method gets called here - m))) + m + (flatten (inner (void) update))))) ; the augmented method gets called here (super-new))) @@ -87,13 +103,15 @@ (plant #f) ; the plant we belong to (type 'root) ; or 'shoot (dir (vector 0 1 0)) ; the general direction we are pointing in - (width 1)) ; the width of this root + (width 0) ; the width of this root + (num-points max-twig-points)) ; number of points in this twig (field (points '()) ; the 3d points for this twig (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 - + (ornaments '()) ; the things attached to this twig, an assoc list with point index + (last-point (vector 0 0 0))) + (inherit send-message) (define/public (get-id) @@ -108,21 +126,34 @@ (define/public (get-dir) dir) + (define/public (get-width) + width) + + (define/public (get-num-points) + num-points) + (define/public (get-point point-index) (list-ref points point-index)) (define/public (grow) - (let ((new-point (vector 0 0 0))) ; todo: grow along dir - (set! points (append points (list new-point))) ; - (send-message 'twig-grow (list - (list 'plant-id (send plant get-id)) - (list 'twig-id id) - (list 'point new-point)))) - (when (zero? (random branch-probability)) - (add-twig (- (length twigs) 1) - (make-object twig-logic% (send plant get-next-twig-id) plant type dir - ; todo dir+rnd - (* width branch-width-reduction)))) + (when (< (length points) num-points) + (let ((new-point (if (zero? (length points)) + (vector 0 0 0) ; first point should be at the origin + (vadd last-point dir (vmul (srndvec) twig-jitter))))) + (set! last-point new-point) + (set! points (append points (list new-point))) + (send-message 'twig-grow (list + (list 'plant-id (send plant get-id)) + (list 'twig-id id) + (list 'point new-point)))) + (when (and (> 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))))) (for-each (lambda (twig) (send (cadr twig) grow)) @@ -131,15 +162,20 @@ (define/public (add-twig point-index twig) (send-message 'new-twig (list (list 'plant-id (send plant get-id)) - (list 'twig-id id) - (list 'point-index point-index))) + (list 'parent-twig-id id) + (list 'point-index point-index) + (list 'twig-id (send twig get-id)) + (list 'type (send twig get-type)) + (list 'dir (send twig get-dir)) + (list 'width (send twig get-width)) + (list 'num-points (send twig get-num-points)) + )) (set! twigs (cons (list point-index twig) twigs))) (define/public (get-twig point-index) (cadr (assq point-index twigs))) (define/public (add-ornament point-index ornament) - ; tell the renderer something has occurred (send-message 'new-ornament (list (send plant get-id) @@ -157,7 +193,8 @@ (let ((found (foldl (lambda (point found) ; if we havent found anything yet and it's intersecting - (cond ((and (not found) (< (vdist point (send pickup get-pos)) (+ width (send pickup get-size)))) + (cond ((and (not found) (< (vdist point (send pickup get-pos)) + (+ width (send pickup get-size)))) (add-ornament (send pickup create-ornament plant)) #t) (else #f))) @@ -243,6 +280,9 @@ (define/public (get-id) id) + (define/public (get-pos) + pos) + (define/public (grow) (for-each (lambda (twig) @@ -265,7 +305,10 @@ twigs)) (define/public (destroy-twig twig) - 0) + (send-message 'destroy-branch-twig (list + (list 'plant-id id) + (list 'twig-id (send twig get-id)) + ))) ; a util to keep a fixed size list of twigs, calling destroy twig when needed. (define (cons-twig thing in count out) @@ -279,9 +322,13 @@ (define/public (add-twig twig) (send twig set-id! (get-next-twig-id)) - (send-message 'new-root-twig (list + (send-message 'new-branch-twig (list (list 'plant-id id) - (list 'twig-id (send twig get-id)))) + (list 'twig-id (send twig get-id)) + (list 'type (send twig get-type)) + (list 'dir (send twig get-dir)) + (list 'width (send twig get-width)) + (list 'num-points (send twig get-num-points)))) (set! twigs (cons-twig twig twigs max-twigs '()))) (define/augment (update) @@ -294,6 +341,8 @@ ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + (define game-logic% (class game-logic-object% (field @@ -303,7 +352,9 @@ (inherit send-message) (define/public (add-plant plant) - (send-message 'new-plant '("hello")) + (send-message 'new-plant (list + (list 'plant-id (send plant get-id)) + (list 'pos (send plant get-pos)))) (set! plants (cons plant plants))) (define/public (add-pickups pickup) @@ -327,25 +378,227 @@ (super-new))) -(define (run) - (let ((l (send game update))) - (for-each - (lambda (m) - (send m print)) - l))) +;============================================================================== +;============================================================================== + +(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 + (root (let ((p (with-state + (translate pos) + (hint-unlit) + ;(concat (maim dir (vector 0 0 1))) + (build-ribbon num-points)))) + (with-primitive p + (pdata-map! + (lambda (w) + 0) + "w") + (pdata-set! "w" 0 radius)) + p)) + (index 0) + (parent-twig-id -1) + (child-twig-ids '())) + + (define/public (get-id) + id) + + (define/public (get-root) + root) + + (define/public (set-parent-twig-id s) + (set! parent-twig-id s)) + + (define/public (get-point point-index) + (with-primitive root + (pdata-ref "p" point-index))) + + (define/public (add-child-twig-id twig-id) + (set! child-twig-ids (cons twig-id child-twig-ids))) + + (define/public (grow point) + (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") + (pdata-index-map! ; do a similar thing with the width + (lambda (i w) + (if (< i (+ index 1)) + w + radius)) + "w")) + (set! index (+ index 1))) + + (super-new))) ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -(define game (make-object game-logic%)) +(define plant-view% + (class object% + + (init-field + (id "none") + (pos (vector 0 0 0))) + + (field + (twigs '()) ; a assoc list map between ids and twigs stored flat here, + ; for fast access, but prims heirachically in the scenegraph + (root (with-state + (translate pos) + (build-locator))) + (seed (with-state + (parent root) + (texture (load-texture "textures/skin.png")) + (backfacecull 0) + (opacity 0.6) + (colour (vector 0.8 1 0.6)) + (hint-depth-sort) + (hint-unlit) + (load-primitive "meshes/seed.obj")))) + + (define/public (get-id) + id) + + (define/public (get-twig twig-id) + (cadr (assq twig-id twigs))) + + (define/public (add-branch-twig twig) + ; attach to seed + (with-primitive (send twig get-root) + (parent root)) + (set! twigs (cons (list (send twig get-id) twig) twigs))) + + (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)) + (translate (send ptwig get-point point-index))) + + ; tell the twigs about this relationship (might turn out to be overkill) + (send ptwig add-child-twig-id (send twig get-id)) + (send twig set-parent-twig-id parent-twig-id) + + (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 (update t) + + (with-primitive root + (scale (+ 1 (* 0.001 (sin (* 2 t)))))) + + (for-each + (lambda (twig) + (send twig update t)) + twigs)) + + (super-new))) + +;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +(define game-view% + (class object% + (field + (plants '())) ; map of ids -> plants + + (define/public (add-plant plant) + (set! plants (cons (list (send plant get-id) plant) plants))) + + (define/public (get-plant plant-id) + (cadr (assq plant-id plants))) + + (define/public (add-branch-twig plant-id twig) + (send (get-plant plant-id) add-branch-twig twig)) + + (define/public (add-twig plant-id parent-twig-id point-index twig) + (send (get-plant plant-id) add-twig parent-twig-id point-index twig)) + + (define/public (update messages) + (when debug-messages + (for-each + (lambda (msg) + (send msg print)) + messages)) + (for-each + (lambda (msg) + (cond + + ((eq? (send msg get-name) 'new-plant) + (add-plant (make-object plant-view% + (send msg get-data 'plant-id) + (send msg get-data 'pos)))) + + ((eq? (send msg get-name) 'new-branch-twig) + (add-branch-twig (send msg get-data 'plant-id) + (make-object twig-view% + (send msg get-data 'twig-id) + (vector 0 0 0) + (send msg get-data 'type) + (send msg get-data 'dir) + (send msg get-data 'width) + (send msg get-data 'num-points)))) + + ((eq? (send msg get-name) 'new-twig) + (add-twig (send msg get-data 'plant-id) + (send msg get-data 'parent-twig-id) + (send msg get-data 'point-index) + (make-object twig-view% + (send msg get-data 'twig-id) + (vector 0 0 0) ; will be filled in by add-twig + (send msg get-data 'type) + (send msg get-data 'dir) + (send msg get-data 'width) + (send msg get-data 'num-points)))) + + ((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))) + + )) + messages)) + + (super-new))) + +;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +(clear) +(define gl (make-object game-logic%)) +(define gv (make-object game-view%)) + (define plant1 (make-object plant-logic% "dave@fo.am" (vector 0 0 0))) -(define plant2 (make-object plant-logic% "plant00001@fo.am" (vector 0 1 0))) +(define plant2 (make-object plant-logic% "plant00001@fo.am" (vector 6 0 0))) -(send game add-plant plant1) -(send game add-plant plant2) -(run) -(send plant1 add-twig (make-object twig-logic% 0 plant1 (vector 0 1 0) 1)) -(run) -(for ((i (in-range 0 50))) - (send plant1 grow) - (run)) +(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)) + +(define t 0) +(define tick-time 0) +(define tick 0.5) + +(define (animate) + (when (< tick-time t) + (set! tick-time (+ t tick)) + (send plant2 grow) + (send gv update (send gl update))) + (set! t (+ t 0.02))) + +#;(for ((i (in-range 0 100))) + (animate)) + +(every-frame (animate)) \ No newline at end of file diff --git a/plant-eyes/plant-eyes.scm b/plant-eyes/plant-eyes.scm index 2de4726..8d50774 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)