nutrient absorbing and twig shrinking, with bugs

This commit is contained in:
Dave Griffiths 2009-08-19 17:16:48 +01:00
parent 03d4bc8c0b
commit 1d040a0c36
5 changed files with 224 additions and 60 deletions

View file

@ -6,7 +6,7 @@
(define branch-width-reduction 0.5)
(define twig-jitter 0.1)
(define branch-jitter 0.5)
(define max-twig-points 15)
(define max-twig-points 10)
(define start-twig-dist 0.05)
(define start-twig-width 0.1)
(define default-max-twigs 10)
@ -43,11 +43,12 @@
(else (cons (car l) (flatten (cdr l))))))
(define/pubment (update) ; need to augement this if we have child logic objects,
(let ((m messages)) ; and call update on them too.
(let ((l (inner '() update)) ; and call update on them too.
(m messages))
(set! messages '())
(append
m
(flatten (inner '() update))))) ; the augmented method gets called here
(flatten l)))) ; the augmented method gets called here
(super-new)))
@ -86,6 +87,9 @@
(define/public (set-id! s)
(set! id s))
(define/public (get-energy-level)
energy-level)
(define/public (get-type)
type)
@ -248,14 +252,22 @@
; returns true if it's succeded
(define/public (check-nutrient nutrient)
; check each point in our twig
(let* ((found (foldl
(let* ((i -1) (found (foldl
(lambda (point found)
(set! i (+ i 1))
; if we havent found anything yet and it's intersecting
(cond ((and (not found) (< (vdist (vadd (send plant get-pos) point)
(send nutrient get-pos))
(+ width (send nutrient get-size))))
(set! energy-level (+ energy-level 1))
(send nutrient deplete)
(send-message 'deplete-nutrient
(list
(list 'plant-id (send plant get-id))
(list 'nutrient-id (send nutrient get-id))
(list 'amount nutrient-field-deplete-loss)
(list 'twig-id id)
(list 'twig-point i)))
#t)
(else #f)))
#f
@ -273,6 +285,13 @@
(define/augment (update)
(set! energy-level (- energy-level twig-energy-loss))
(printf "~a~n" energy-level)
(when (< energy-level 0)
(printf "sending~n")
(send-message 'shrink-twig
(list (list 'plant-id (send plant get-id))
(list 'twig-id id))))
(append
(map
(lambda (ornament)
@ -345,12 +364,16 @@
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; nutrient fields are areas where nutrients exist
(define nutrient-field-logic%
(define nutrient-logic%
(class game-logic-object%
(init-field
(id #f)
(pos (vector 0 0 0))
(size 0))
(define/public (get-id)
id)
(define/public (get-pos)
pos)
@ -428,26 +451,19 @@
(foldl
(lambda (twig found)
(if (not found)
(send twig check-pickup pickup)
(send (cadr twig) check-pickup pickup)
#f))
#f
twigs))
(define/public (destroy-twig twig)
(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)
(cond
((null? in)
(cons thing out))
((zero? count)
(destroy-twig (car in))
(cons thing out))
(else (cons-twig thing (cdr in) (- count 1) (append out (list (car in)))))))
(define/public (check-nutrient nutrient)
(foldl
(lambda (twig found)
(if (not found)
(send (cadr twig) check-nutrient nutrient)
#f))
#f
twigs))
(define/public (add-twig twig)
(send twig set-id! (get-next-twig-id))
@ -458,7 +474,7 @@
(list 'plant-id id)
(list 'amount grow-amount)))
(send-message 'new-twig (send twig get-desc-list))
(set! twigs (cons-twig twig twigs max-twigs '())))
(set! twigs (cons (list (send twig get-id) twig) twigs)))
(define/public (add-sub-twig ptwig point-index dir)
(set! leader-twig (send ptwig add-twig point-index dir))
@ -466,16 +482,16 @@
(define/public (get-random-twig)
(if (not (null? twigs))
(send (choose twigs) get-random-twig)
(send (cadr (choose twigs)) get-random-twig)
#f))
(define/public (get-twig-from-dir dir)
(let ((dir (vnormalise dir)))
(cadr (foldl
(lambda (twig l)
(let ((d (vdot (vnormalise (send twig get-dir)) dir)))
(let ((d (vdot (vnormalise (send (cadr twig) get-dir)) dir)))
(if (> d (car l))
(list d twig)
(list d (cadr twig))
l)))
(list -99 #f)
twigs))))
@ -491,7 +507,7 @@
(append
(map
(lambda (twig)
(send twig serialise))
(send (cadr twig) serialise))
twigs))))
(define/augment (update)
@ -519,9 +535,17 @@
point-index))
(else
(error "property not understood " property)))))))))
(for-each
(lambda (twig)
(when (< (send (cadr twig) get-energy-level) 0)
(set! twigs (assoc-remove (car twig) twigs))))
twigs)
(map
(lambda (twig)
(send twig update))
(send (cadr twig) update))
twigs))
(super-new)))
@ -533,6 +557,7 @@
(field
(plants '())
(pickups '())
(nutrients '())
(player #f))
(inherit send-message)
@ -545,7 +570,15 @@
(add-pickup (make-object pickup-logic% i (list-ref pickup 0)
(list-ref pickup 2)))
(set! i (+ i 1)))
pickups))))
pickups)))
(let ((i 0))
(for-each
(lambda (nutrient)
(add-nutrient (make-object nutrient-logic% i (list-ref nutrient 2)
(list-ref nutrient 3)))
(set! i (+ i 1)))
(list-ref world-list 2))))
(define/public (add-player plant)
(printf "new player plant added ~a~n" (send plant get-id))
@ -575,6 +608,14 @@
(list 'pos (send pickup get-pos))))
(set! pickups (cons pickup pickups)))
(define/public (add-nutrient nutrient)
(send-message 'new-nutrient
(list
(list 'nutrient-id (send nutrient get-id))
(list 'pos (send nutrient get-pos))
(list 'size (send nutrient get-size))))
(set! nutrients (cons nutrient nutrients)))
(define/public (serialise)
(send player serialise))
@ -590,15 +631,28 @@
plants))
pickups)
(for-each
(lambda (nutrient)
(for-each
(lambda (plant)
(send plant check-nutrient nutrient))
plants))
nutrients)
; remove the pickups that have been 'picked up'
(set! pickups (filter
(lambda (pickup)
(not (send pickup picked-up?)))
pickups))
(append
(map
(lambda (plant)
(send plant update))
plants))
plants)
(map
(lambda (nutrient)
(send nutrient update))
nutrients)))
(super-new)))

View file

@ -36,10 +36,12 @@
; side - eg. lsystem, or different methods per plant (or per twig even)
(define world-list (let* ((f (open-input-file "world.txt"))
(o (list (read f)(read f)(read f))))
(o (list (read f)(read f)(read f)(read f))))
(close-input-port f)
o))
(printf "~a~n" (length world-list))
(clear)
(clear-shader-cache)

View file

@ -4,7 +4,7 @@
; the fluxus code to make things look the way they do
(define debug-messages #f) ; prints out all the messages sent to the renderer
(define debug-messages #t) ; prints out all the messages sent to the renderer
(define audio-on #t)
(define (ornament-colour) (vector 0.5 1 0.4))
@ -245,6 +245,34 @@
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
(define nutrient-view%
(class object%
(init-field
(id -1)
(pos (vector 0 0 0))
(size 0))
(field
(root (with-state
(translate pos)
(scale size)
(build-sphere 10 10))))
(define/public (deplete amount)
(when (> size 0)
(set! size (- size amount))
(with-primitive root
(identity)
(translate pos)
(scale size))))
(define/public (update t d)
0)
(super-new)))
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
(define twig-view%
(class object%
(init-field
@ -265,11 +293,16 @@
(markers '())
(grow-t -1)
(marker-destroy-t 0)
(grow-speed default-grow-speed))
(grow-speed default-grow-speed)
(shrink-t 0)
(delme #f))
(define/public (get-id)
id)
(define/public (delme?)
delme)
(define/public (get-dir)
dir)
@ -316,6 +349,9 @@
(set! grow-t 0)
(set! markers (cons (build-locator) markers)))
(define/public (start-shrinking)
(set! shrink-t (if (growing?) grow-t grow-overshoot)))
(define/pubment (add-point point width)
(play-sound "snd/event01.wav" point (+ 0.1 (rndf)) 0.3)
(set! markers (append markers (list (with-state
@ -356,6 +392,12 @@
(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)))
@ -434,7 +476,7 @@
(class twig-view%
(inherit growing?)
(inherit-field index radius num-points pos dir col tex grow-t)
(inherit-field index radius num-points pos dir col tex grow-t shrink-t)
(field
(profile '())
@ -484,6 +526,10 @@
(with-primitive root
(partial-extrude grow-t profile path widths (vector 1 0 0) 0.05)))
(when (> shrink-t 0)
(with-primitive root
(partial-extrude shrink-t profile path widths (vector 1 0 0) 0.05)))
#;(when (not (growing?))
(with-primitive root
(pre-ripple)
@ -578,11 +624,12 @@
#f)))
(define/public (destroy-branch-twig twig-id)
(when (get-twig twig-id) ; might have destroyed itself already
(for-each
(lambda (twig-id)
(destroy-branch-twig twig-id))
(send (get-twig twig-id) get-child-twig-ids))
(send (get-twig twig-id) destroy-twig)
(send (get-twig twig-id) destroy-twig))
(set! twigs (assoc-remove twig-id twigs)))
(define/public (destroy-plant)
@ -592,6 +639,13 @@
(destroy-branch-twig (car twig)))
twigs))
(define/public (shrink-twig twig-id)
(send (get-twig twig-id) start-shrinking)
(for-each
(lambda (twig-id)
(shrink-twig twig-id))
(send (get-twig twig-id) get-child-twig-ids)))
(define/public (add-twig parent-twig-id point-index twig)
(let ((ptwig (get-twig parent-twig-id)))
(when ptwig
@ -630,6 +684,15 @@
(send (cadr twig) set-excitations! a b))
twigs))
(define/public (nutrient-absorb twig-id twig-point)
(with-primitive nutrients
(let ((p (random (pdata-size))))
(pdata-set! "twig" p twig-id)
(pdata-set! "point" p twig-point)
(pdata-set! "p" p (send (get-twig twig-id) get-point twig-point))
(pdata-set! "offset" p (vmul (srndvec) (
send (get-twig twig-id) get-width twig-point))))))
(define/public (update-nutrients t d)
(when (not (null? twigs))
(with-primitive nutrients
@ -638,26 +701,26 @@
(let* ((twig-id (inexact->exact twig-id))
(twig (get-twig twig-id))
(point (inexact->exact point)))
(if twig
(cond
((or (< point 1) (not twig))
(let* ((new-twig (choose twigs))
(num-points (send (cadr new-twig) get-num-points))
(new-point (if (zero? num-points) 0 (random num-points))))
(pdata-set! "twig" i (car new-twig))
(pdata-set! "point" i new-point)
(pdata-set! "offset" i (vmix offset (vmul (srndvec) (send (cadr new-twig) get-width new-point)) 0.2))
(send (cadr new-twig) get-point new-point)))
((< point 1) (pdata-set! "twig" i -1) (vector 0 0 0))
((< (vdist (vadd (send twig get-point point) offset) p) 0.1)
(pdata-set! "point" i (- point 1))
(vadd p (vmul (vnormalise (vsub (vadd (send twig get-point (- point 1)) offset) p)) (* speed d))))
(else
(vadd p (vmul (vnormalise (vsub (vadd (send twig get-point point) offset) p)) (* speed d)))))))
(vadd p (vmul (vnormalise (vsub (vadd (send twig get-point point) offset) p)) (* speed d)))))
(vector 0 0 0))))
"p" "twig" "point" "offset" "speed"))))
(define/public (update t d)
(update-nutrients t d)
(with-primitive seed
(scale (+ 1 (* 0.001 (sin (* 2 t))))))
(for-each
(lambda (twig)
(when (send (cadr twig) delme?)
(destroy-branch-twig (car twig))))
twigs)
(for-each
(lambda (twig)
@ -726,6 +789,7 @@
(field
(plants '()) ; map of ids -> plants
(pickups '()) ; map of ids -> pickups
(nutrients '()) ; map of ids -> nutrients
(camera-dist 1)
(env-root (with-state (scale 1000) (build-locator)))
(root-camera-t 0)
@ -789,7 +853,7 @@
(load-primitive (list-ref stone 1)))))
(with-primitive p (apply-transform) (recalc-bb)) ; apply the transform to speed up the ray tracing, don't have to tranform the ray into object space
p))
(list-ref world-list 2))))
(list-ref world-list 3))))
(define/public (get-stones)
stones)
@ -821,17 +885,32 @@
(define/public (get-pickup pickup-id)
(cadr (assq pickup-id pickups)))
(define/public (get-nutrient nutrient-id)
(cadr (assq nutrient-id nutrients)))
(define/public (add-pickup pickup-id type pos)
(set! pickups (cons (list pickup-id (make-object pickup-view% pickup-id type pos)) pickups)))
(define/public (add-nutrient nutrient-id pos size)
(set! nutrients (cons (list nutrient-id (make-object nutrient-view% nutrient-id pos size)) nutrients)))
(define/public (pick-up-pickup pickup-id)
(send (get-pickup pickup-id) pick-up)
(set! pickups (assoc-remove pickup-id pickups)))
(define/public (deplete-nutrient nutrient-id amount plant-id twig-id twig-point)
(send (get-nutrient nutrient-id) deplete amount)
(when (get-plant plant-id)
(send (get-plant plant-id) nutrient-absorb twig-id twig-point)))
(define/public (add-ornament plant-id twig-id point-index property)
(when (get-plant plant-id)
(send (get-plant plant-id) add-ornament twig-id point-index property)))
(define/public (shrink-twig plant-id twig-id)
(when (get-plant plant-id)
(send (get-plant plant-id) shrink-twig twig-id)))
(define/public (set-excitations! a b)
(for-each
(lambda (plant)
@ -923,10 +1002,30 @@
(send msg get-data 'type)
(send msg get-data 'pos)))
((eq? (send msg get-name) 'new-nutrient)
(add-nutrient
(send msg get-data 'nutrient-id)
(send msg get-data 'pos)
(send msg get-data 'size)))
((eq? (send msg get-name) 'pick-up-pickup)
(pick-up-pickup
(send msg get-data 'pickup-id)))
((eq? (send msg get-name) 'deplete-nutrient)
(deplete-nutrient
(send msg get-data 'nutrient-id)
(send msg get-data 'amount)
(send msg get-data 'plant-id)
(send msg get-data 'twig-id)
(send msg get-data 'twig-point)))
((eq? (send msg get-name) 'shrink-twig)
(printf "hello~n")
(shrink-twig
(send msg get-data 'plant-id)
(send msg get-data 'twig-id)))
((eq? (send msg get-name) 'new-ornament)
(add-ornament
(send msg get-data 'plant-id)

View file

@ -28,6 +28,7 @@
(let ((f (open-output-file fn)))
(write (extract-list 'seed s) f)
(write (extract-list 'pickup s) f)
(write (extract-list 'nutrients s) f)
(write (extract-list 'stone s) f)
(close-output-port f)))
@ -35,7 +36,7 @@
(list-ref l (random (length l))))
(define (init num-seeds num-pickups num-stones area size)
(define (init num-seeds num-pickups num-nutrients num-stones area size)
(append
(build-list num-seeds
(lambda (_)
@ -52,6 +53,13 @@
0.5
(vmul (rndvec) 360) 0))))
(build-list num-nutrients
(lambda (_)
(make-ob 'nutrients 'nutrients "meshes/seed.obj"
(vmul (srndvec) (* 150 area))
(* (rndf) 10)
(vmul (rndvec) 0) 0)))
(build-list num-stones
(lambda (_)
@ -68,7 +76,8 @@
(cond
((eq? (ob-type ob) 'seed) (colour (vector 0 1 0)))
((eq? (ob-type ob) 'pickup) (backfacecull 0) (hint-unlit) (colour (vector 1 1 0)))
((eq? (ob-type ob) 'stone) (colour (vector 1 0.5 0))))
((eq? (ob-type ob) 'stone) (colour (vector 1 0.5 0)))
((eq? (ob-type ob) 'nutrients) (hint-unlit) (colour (vector 1 1 1))))
(load-primitive (ob-mesh ob))))
(when (eq? (ob-type ob) 'stone) (with-primitive (ob-root ob) (hide 1))))
l))
@ -100,7 +109,7 @@
(clear)
(clear-colour 0)
(define s (init 5 200 200 1 10))
(define s (init 5 200 100 100 1 10))
(build s)
(define l (make-light 'spot 'free))

File diff suppressed because one or more lines are too long