logical growth works, added a view side with ribbon roots for preview
This commit is contained in:
Dave Griffiths
parent
cf07513ea7
commit
a013bb0508
2 changed files with 303 additions and 50 deletions
|
|
@ -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))
|
||||
|
|
@ -1,5 +1,5 @@
|
|||
#lang scheme/base
|
||||
(require fluxus-016/drflux)
|
||||
;#lang scheme/base
|
||||
;(require fluxus-016/drflux)
|
||||
(require scheme/class)
|
||||
|
||||
|
||||
|
|
|
|||
Loading…
Reference in a new issue