added nutrients (pickups) and worms

This commit is contained in:
Dave Griffiths 2009-06-08 16:25:32 +01:00
parent c9fdfcc45e
commit 68d44b0343
2 changed files with 471 additions and 63 deletions

Binary file not shown.

View file

@ -1,5 +1,22 @@
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; hex groworld game : fluxus version
(require scheme/class) (require scheme/class)
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; tweakables
(define num-insects 20)
(define pickup-drop-probability 10)
(define (bg-colour) (vector 0.5 0.2 0.1))
(define (worm-colour) (hsv->rgb (vector 0.1 (rndf) 0.5)))
(define (root-colour) (vector 0.6 0.5 0.5))
(define (pickup-colour) (hsv->rgb (vector 0.1 (rndf) 1)))
(define (absorb-colour) (hsv->rgb (vector 0.1 (rndf) 1)))
(define texpath "textures/")
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; odds and sods ; odds and sods
@ -23,6 +40,9 @@
(cons (list-ref l i) (cons (list-ref l i)
(shuffle (list-remove l i)))))) (shuffle (list-remove l i))))))
(define (choose l)
(list-ref l (random (length l))))
; convert a list of bools into a number, treating the ; convert a list of bools into a number, treating the
; list as a binary sequence ; list as a binary sequence
(define (bool-list->num l n c) (define (bool-list->num l n c)
@ -63,20 +83,30 @@
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; logic ; logic
; messages passed between the logic and the view
(define-struct cell-update (pos code pickup upstream))
(define-struct insect-update (id pos dir t))
(define-struct absorb-event (cell-pos type))
(define comb-cell% (define comb-cell%
(class object% (class object%
(field (field
(pos '())
(neighbours '(#f #f #f #f #f #f)) (neighbours '(#f #f #f #f #f #f))
(contents '()) (pickup #f)
(connections '(#f #f #f #f #f #f)) (connections '(#f #f #f #f #f #f))
(visible #f) (visible #f)
(update-me #f)) (update-me #f)
(upstream #f)) ; the cell we are connected to (if we are)
(define/public (update-me?) (define/public (update-me?)
(let ((r update-me)) (let ((r update-me))
(set! update-me #f) (set! update-me #f)
r)) r))
(define/public (get-upstream)
upstream)
(define/public (set-visible! s) (define/public (set-visible! s)
(set! update-me #t) (set! update-me #t)
(set! visible s)) (set! visible s))
@ -84,6 +114,12 @@
(define/public (visible?) (define/public (visible?)
visible) visible)
(define/public (get-pos)
pos)
(define/public (set-pos! s)
(set! pos s))
(define/public (get-neighbours) (define/public (get-neighbours)
neighbours) neighbours)
@ -93,8 +129,12 @@
(define/public (set-neighbour! d n) (define/public (set-neighbour! d n)
(set! neighbours (insert neighbours d n 0))) (set! neighbours (insert neighbours d n 0)))
(define/public (get-contents) (define/public (get-pickup)
contents) pickup)
(define/public (set-pickup! s)
(when visible (set! update-me #t))
(set! pickup s))
(define/public (get-connections) (define/public (get-connections)
connections) connections)
@ -119,22 +159,61 @@
(bool-list->num connections 0 0)) (bool-list->num connections 0 0))
; returns the first attachable neighbour found, and sets it's connection ; returns the first attachable neighbour found, and sets it's connection
(define (search/attach-to-neighbour l) (define (search/attach-to-neighbour l dirs)
(cond (cond
((null? l) #f) ((null? l) dirs)
((not (send (get-neighbour (car l)) no-connections?)) ((not (send (get-neighbour (car l)) no-connections?))
(send (get-neighbour (car l)) set-connection! (rdirection (car l)) #t) (send (get-neighbour (car l)) set-connection! (rdirection (car l)) #t)
(set! upstream (get-neighbour (car l)))
#;(search/attach-to-neighbour (cdr l) (cons (car l) dirs))
(car l)) (car l))
(else (search/attach-to-neighbour (cdr l))))) (else (search/attach-to-neighbour (cdr l) dirs))))
(define/public (grow) (define/public (grow)
; only possible to grow when we are a clear cell ; only possible to grow when we are a clear cell
(when (equal? connections (list #f #f #f #f #f #f)) (when (equal? connections (list #f #f #f #f #f #f))
(let ((dir (search/attach-to-neighbour (shuffle directions)))) (let ((dir (search/attach-to-neighbour (shuffle directions) '())))
(when dir (when dir
; it's dir is false if we have nothing around us to (set-connection! dir #t))
; connect to, probably shouldn't happen, haven't decided yet #;(for-each
(set-connection! dir #t))))) (lambda (d)
(set-connection! d #t))
dir))))
(super-new)))
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
(define insect%
(class object%
(init-field
(id 0)
(cell 0)
(t (+ 0.5 (rndf))))
(field
(next-update 0))
(define/public (get-id)
id)
(define/public (get-cell)
cell)
(define (move cell)
(let* ((i (random (length (send cell get-neighbours))))
(n (list-ref (send cell get-neighbours) i)))
(if n (list i n) (move cell))))
(define/public (update time delta)
(cond ((> time next-update)
(let ((m (move cell)))
(when (zero? (random pickup-drop-probability))
(send cell set-pickup! 'default))
(set! next-update (+ time t))
(set! cell (cadr m))
(make-insect-update id (send cell get-pos) (car m) t)))
(else #f)))
(super-new))) (super-new)))
@ -145,7 +224,8 @@
(field (field
(cells '()) (cells '())
(width 0) (width 0)
(height 0)) (height 0)
(insects '()))
(define/public (get-cell x y) (define/public (get-cell x y)
(list-ref cells (+ (* y height) x))) (list-ref cells (+ (* y height) x)))
@ -157,6 +237,9 @@
; first build the cells ; first build the cells
(set! cells (build-list (* w h) (lambda (_) (make-object comb-cell%)))) (set! cells (build-list (* w h) (lambda (_) (make-object comb-cell%))))
; now build the insects
(set! insects (build-list num-insects (lambda (id) (make-object insect% id (choose cells)))))
; then stitch them together like this: ; then stitch them together like this:
; o o o o o o o o o o o ; o o o o o o o o o o o
@ -167,6 +250,7 @@
(for ((x (in-range 0 width))) (for ((x (in-range 0 width)))
(for ((y (in-range 0 height))) (for ((y (in-range 0 height)))
(let ((cell (get-cell x y))) (let ((cell (get-cell x y)))
(send cell set-pos! (list x y))
(when (and (< x (- width 1)) (> y 0)) (when (and (< x (- width 1)) (> y 0))
(send cell set-neighbour! NE (get-cell (if (odd? y) (+ x 1) x) (- y 1)))) (send cell set-neighbour! NE (get-cell (if (odd? y) (+ x 1) x) (- y 1))))
(when (< x (- width 1)) (when (< x (- width 1))
@ -182,32 +266,38 @@
(send cell set-neighbour! SW (get-cell (if (odd? y) x (- x 1)) (+ y 1)))))))) (send cell set-neighbour! SW (get-cell (if (odd? y) x (- x 1)) (+ y 1))))))))
(define/public (seed x y) (define/public (seed x y)
(send (get-cell x y) set-connection! SE #t) (send (get-cell x y) set-connection! SE #t)
(send (get-cell x (+ y 1)) set-connection! NW #t) (send (get-cell x (+ y 1)) set-connection! NW #t))
#;(let ((seed (get-cell x y))) (define/public (get-update-list time delta)
; set all directions to be connected
(for-each
(lambda (d)
(send seed set-connection! d #t))
directions)
(for-each (append
(lambda (n d)
(send n set-connection! (rdirection d) #t))
(send seed get-neighbours)
directions)))
(define/public (get-update-list) ; look for pickups over roots
(let ((i -1)) (foldl
(lambda (cell r)
(let ((pickup (send cell get-pickup)))
(cond ((and (not (send cell no-connections?)) pickup)
(send cell set-pickup! #f)
(cons (make-absorb-event (send cell get-pos) pickup) r))
(else r))))
'()
cells)
(foldl
(lambda (insect r)
(let ((l (send insect update time delta)))
(if l (cons l r) r)))
'()
insects)
(foldl (foldl
(lambda (cell r) (lambda (cell r)
(set! i (+ i 1))
(if (send cell update-me?) (if (send cell update-me?)
(cons (list (let ((upstream (send cell get-upstream)))
(list (modulo i width) (quotient i height)) (cons (make-cell-update (send cell get-pos)
(send cell get-connection-num)) r) (send cell get-connection-num)
(send cell get-pickup)
(if upstream (send upstream get-pos) #f)) r))
r)) r))
'() '()
cells))) cells)))
@ -217,6 +307,13 @@
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; graphics and interaction ; graphics and interaction
; more odds and sods...
(define (direction-normal d)
(let ((a (* 2 1.141 60)))
(vector (sin (* a d)) (cos (* a d)) 0)))
(define (build-ngon n) (define (build-ngon n)
(let ((p (build-polygons n 'polygon))) (let ((p (build-polygons n 'polygon)))
(with-primitive p (with-primitive p
@ -236,14 +333,81 @@
(pdata-map! (lambda (n) (vector 0 0 1)) "n")) (pdata-map! (lambda (n) (vector 0 0 1)) "n"))
p)) p))
(define (build-ngon n)
(let ((p (build-polygons n 'polygon)))
(with-primitive p
(pdata-index-map!
(lambda (i p)
(let ((a (* (/ i n) (* 2 3.141))))
(vector (cos a) (sin a) 0)))
"p")
(pdata-map!
(lambda (t p)
(let ((p (vtransform p (mmul
(mrotate (vector 0 0 -90))
(mscale (vector -1 1 1))))))
(vsub (vmul p 0.45) (vector 0.5 0.5 0))))
"t" "p")
(pdata-copy "t" "tref")
(pdata-map! (lambda (n) (vector 0 0 1)) "n"))
p))
; 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 (lerp t p1 p2)
(vadd (vmul p1 (- 1 t)) (vmul p2 t)))
(define (lerp-tangent t p1 p2)
(let ((p (lerp t p1 p2)))
(list p (vsub (lerp (- t 0.01) p1 p2) p))))
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
(define cell-view% (define cell-view%
(class object% (class object%
(field (field
(root 0) (root 0)
(root2 0) (root2 0)
(pickup-root 0)
(t 0) (t 0)
(pos '(0 0)) (pos '(0 0))
(owner 0)) (owner 0)
(upstream-pos '()))
(define/public (get-upstream-pos)
upstream-pos)
(define/public (set-upstream-pos! s)
(set! upstream-pos s))
(define/public (set-owner! s) (define/public (set-owner! s)
(set! owner s)) (set! owner s))
@ -263,7 +427,7 @@
(parent owner) (parent owner)
(hint-depth-sort) (hint-depth-sort)
(opacity 0) (opacity 0)
(colour (vector 0.9 1 0.5)) (colour (root-colour))
(hint-unlit) (hint-unlit)
(when (odd? (cadr pos)) (when (odd? (cadr pos))
(translate (vector 0.5 0 0))) (translate (vector 0.5 0 0)))
@ -280,7 +444,7 @@
(set! root2 (build-prim code))) (set! root2 (build-prim code)))
(define (update-texture code) (define (update-texture code)
(texture (load-texture "textures/roots-ornate.png")) (texture (load-texture (append texpath "roots-ornate.png")))
(pdata-map! (pdata-map!
(lambda (t tref) (lambda (t tref)
(let ((size (/ 1 8))) (let ((size (/ 1 8)))
@ -295,8 +459,26 @@
(set! root2 (build-prim code)) (set! root2 (build-prim code))
(set! t 0)) (set! t 0))
(define/public (update) (define/public (set-pickup! type)
(set! t (+ t 0.04)) (when (and (not type) (not (zero? pickup-root)))
(destroy pickup-root)
(set! pickup-root 0))
(when type
(when (not (zero? pickup-root))
(destroy pickup-root)
(set! pickup-root 0))
(set! pickup-root (with-state
(colour (pickup-colour))
(parent owner)
(translate (with-primitive root (vtransform (vector 0 0 0) (get-transform))))
(build-torus 0.03 0.2 10 10)))))
(define/public (update time delta)
(set! t (+ t delta))
(when (not (zero? pickup-root))
(with-primitive pickup-root
(rotate (vector 0 2 0))))
(when (< t 1) (when (< t 1)
(with-primitive root (with-primitive root
@ -316,14 +498,193 @@
(super-new))) (super-new)))
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
(define insect-view%
(class object%
(field
(root 0)
(from (vector 0 0 0))
(to (vector 0 0 0))
(from-dir (vector 1 0 0))
(to-dir (vector 1 0 0))
(t 0)
(d 0))
(define/public (build)
(set! root (build-cube))
(with-primitive root (hide 1)))
(define/public (goto-cell cell dir dur)
(set! from to)
(set! from-dir to-dir)
(set! to (with-primitive (send cell get-root)
(vtransform (vector 0 0 0) (get-transform))))
(set! to-dir (direction-normal dir))
(set! t 0)
(set! d dur))
(define/public (update time delta)
(cond ((or (zero? d) (> t d) (equal? from (vector 0 0 0)))
(with-primitive root (hide 1))
(set! from (vector 0 0 0)))
(else
(with-primitive root
(hide 0)
(identity)
(let ((h (hermite-tangent (/ t d) from to (vmul from-dir 2) (vmul to-dir 2))
#;(lerp-tangent (/ t d) from to)))
(translate (car h))
(concat (maim (vector 0 0 1) (vnormalise (cadr h)))))
(scale 0.2))))
(set! t (+ t delta)))
(super-new)))
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
(define worm-view%
(class insect-view%
(inherit-field root from to from-dir to-dir t d)
(field (hidden #t))
(define/override (build)
(set! root (build-ribbon 50))
(with-primitive root
(hide 1)
(translate (vector 0 0 -0.1))
(hint-unlit)
(set! hidden #t)
(colour (worm-colour))
(texture (load-texture (append texpath "worm.png")))
(let ((width (+ 0.05 (* 0.1 (rndf)))))
(pdata-index-map!
(lambda (i w)
width #;(+ 0.05 (* (abs (sin (* i 0.5))) 0.1)))
"w"))
#;(pdata-map!
(lambda (c)
(vector 1 1 1))
"c")))
(define/override (update time delta)
(cond ((or (zero? d) (> t d) (equal? from (vector 0 0 0)))
(set! hidden #t)
(with-primitive root (hide 1)))
(else
(with-primitive root
(when hidden
(set! hidden #f)
(pdata-map!
(lambda (p)
from)
"p"))
(hide 0)
;(identity)
(let ((h (hermite-tangent (/ t d) from to (vmul from-dir 2) (vmul to-dir 2))))
;(translate (car h))
(pdata-set! "p" (- (pdata-size) 1) (car h))
(for ((i (in-range 0 (- (pdata-size) 1))))
(pdata-set! "p" i (pdata-ref "p" (+ i 1))))))))
(set! t (+ t delta)))
(super-new)))
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
(define absorb-view%
(class object%
(field
(cell #f)
(root 0)
(next-time 0)
(target (vector 0 0 0))
(speed 0.5)
(alive #t)
(t 0))
(define/public (set-cell! s)
(set! cell s))
(define/public (alive?)
alive)
(define/public (build p)
(set! root (with-state
(texture (load-texture (append texpath "particle.png")))
(parent p)
(build-particles 20)))
(let ((pos (with-primitive (send cell get-root)
(vtransform (vector 0 0 0) (get-transform)))))
(with-primitive root
(hint-depth-sort)
(pdata-map!
(lambda (p)
(vadd pos (vmul (srndvec) 0.3)))
"p")
(pdata-map!
(lambda (c)
(absorb-colour))
"c")
(pdata-map!
(lambda (s)
(let ((s (* 0.75 (+ 1 (rndf)))))
(vector s s 1 0.3)))
"s"))))
(define/public (update time delta hcv)
(set! t (+ t delta))
(with-primitive root
(pdata-map!
(lambda (p)
(vadd p (vadd (vmul (vsub target p) 0.05) (vmul (srndvec) 0.06))))
"p"))
(when (> time next-time)
(set! next-time (+ time speed))
(let ((upstream-pos (send cell get-upstream-pos)))
(cond (upstream-pos
(set! cell (send hcv get-cell-from-pos (send cell get-upstream-pos)))
(set! target (with-primitive (send cell get-root)
(vtransform (vector 0 0 0) (get-transform)))))
(else
(set! alive #f)
(destroy root))))))
(super-new)))
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
(define honey-comb-view% (define honey-comb-view%
(class object% (class object%
(field (field
(root 0) (root 0)
(cells '())) ; an associative array mapping position to cell-view obs (cells '()) ; an associative list mapping position to cell-views
(insects '()) ; an associative list mapping id to insect-views
(absorb-list '())) ; just a list of absorb effects
(define/public (init) (define/public (init)
(set! root (build-locator))) (set! root (build-locator))
(set! insects (build-list num-insects
(lambda (id)
(list id (make-object worm-view%)))))
(with-state
(parent root)
(for-each
(lambda (insect)
(send (cadr insect) build))
insects)))
(define (get-pos-from-prim p l) (define (get-pos-from-prim p l)
(cond (cond
@ -331,30 +692,71 @@
((eq? (send (cadr (car l)) get-root) p) (caar l)) ((eq? (send (cadr (car l)) get-root) p) (caar l))
(else (get-pos-from-prim p (cdr l))))) (else (get-pos-from-prim p (cdr l)))))
(define/public (get-cell-from-pos pos)
(cadr (assoc pos cells)))
(define/public (deal-with-input) (define/public (deal-with-input)
(if (mouse-button 1) (if (mouse-button 1)
(get-pos-from-prim (mouse-over) cells) (get-pos-from-prim (mouse-over) cells)
#f)) #f))
(define/public (update update-list) (define/public (add-absorb! s)
(set! absorb-list (cons s absorb-list)))
(define/public (update update-list time delta)
; do the per-frame update on all the things
(set! absorb-list
(filter
(lambda (absorb)
(send absorb update time delta this)
(send absorb alive?))
absorb-list))
(for-each (for-each
(lambda (cell) (lambda (cell)
(send (cadr cell) update)) (send (cadr cell) update time delta))
cells) cells)
(for-each
(lambda (insect)
(send (cadr insect) update time delta))
insects)
; read the update list, and dispatch based on type
(for-each (for-each
(lambda (item) (lambda (item)
(let*
((pos (car item))
(code (cadr item))
(s (assoc pos cells)))
(cond (cond
(s (send (cadr s) new-code code)) ((cell-update? item)
(let*
((pos (cell-update-pos item))
(code (cell-update-code item))
(s (assoc pos cells)))
(cond
(s
(send (cadr s) new-code code)
(send (cadr s) set-pickup! (cell-update-pickup item))
(send (cadr s) set-upstream-pos! (cell-update-upstream item)))
(else (else
(let ((cell (make-object cell-view%))) (let ((cell (make-object cell-view%)))
(send cell set-pos! pos) (send cell set-pos! pos)
(send cell set-owner! root) (send cell set-owner! root)
(send cell build code) (send cell build code)
(set! cells (cons (list pos cell) cells))))))) (set! cells (cons (list pos cell) cells)))))))
((insect-update? item)
(let* ((pos (insect-update-pos item))
(c (assoc pos cells))
(insect (cadr (assoc (insect-update-id item) insects))))
; only need to update if we can see the cell
(when c (send insect goto-cell
(cadr c)
(insect-update-dir item)
(insect-update-t item)))))
((absorb-event? item)
(let ((a (make-object absorb-view%)))
(send a set-cell! (get-cell-from-pos (absorb-event-cell-pos item)))
(send a build root)
(add-absorb! a)))))
update-list)) update-list))
(super-new))) (super-new)))
@ -362,28 +764,34 @@
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
(clear) (clear)
(clear-colour (vector 0.5 0.2 0.1)) (clear-colour (bg-colour))
(clear-texture-cache) (clear-texture-cache)
(show-axis 0) (show-axis 0)
(set-camera-transform (mtranslate (vector 0 0 -8))) (set-camera-transform (mtranslate (vector -10 -6 -8)))
(define hc (make-object honey-comb%)) (define hc (make-object honey-comb%))
(define hcv (make-object honey-comb-view%)) (define hcv (make-object honey-comb-view%))
(send hc init 100 100) (send hc init 20 20)
(with-state (with-state
(translate (vector -50 -42.5 0)) ; (translate (vector -50 -42.5 0))
; (translate (vector -10 -8.5 0))
(send hcv init)) (send hcv init))
(send hc seed 50 50) (send hc seed 10 10)
;(send (send hc get-cell 50 52) grow) ;(send (send hc get-cell 50 52) grow)
;(send (send hc get-cell 49 53) grow) ;(send (send hc get-cell 49 53) grow)
(define t 0)
(define d 0.04)
(define (animate) (define (animate)
; (set! d (delta))
(set! t (+ t d))
(let ((clicked (send hcv deal-with-input))) (let ((clicked (send hcv deal-with-input)))
(when clicked (when clicked
(send (send hc get-cell (car clicked) (cadr clicked)) grow))) (send (send hc get-cell (car clicked) (cadr clicked)) grow)))
(send hcv update (send hc get-update-list))) (send hcv update (send hc get-update-list t d) t d))
(every-frame (animate)) (every-frame (animate))