added nutrients (pickups) and worms
This commit is contained in:
Dave Griffiths
parent
c9fdfcc45e
commit
68d44b0343
2 changed files with 471 additions and 63 deletions
Binary file not shown.
|
|
@ -1,5 +1,22 @@
|
|||
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||||
; hex groworld game : fluxus version
|
||||
|
||||
(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
|
||||
|
||||
|
|
@ -23,6 +40,9 @@
|
|||
(cons (list-ref 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
|
||||
; list as a binary sequence
|
||||
(define (bool-list->num l n c)
|
||||
|
|
@ -63,20 +83,30 @@
|
|||
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||||
; 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%
|
||||
(class object%
|
||||
(field
|
||||
(pos '())
|
||||
(neighbours '(#f #f #f #f #f #f))
|
||||
(contents '())
|
||||
(pickup #f)
|
||||
(connections '(#f #f #f #f #f #f))
|
||||
(visible #f)
|
||||
(update-me #f))
|
||||
(update-me #f)
|
||||
(upstream #f)) ; the cell we are connected to (if we are)
|
||||
|
||||
(define/public (update-me?)
|
||||
(let ((r update-me))
|
||||
(set! update-me #f)
|
||||
r))
|
||||
|
||||
(define/public (get-upstream)
|
||||
upstream)
|
||||
|
||||
(define/public (set-visible! s)
|
||||
(set! update-me #t)
|
||||
(set! visible s))
|
||||
|
|
@ -84,6 +114,12 @@
|
|||
(define/public (visible?)
|
||||
visible)
|
||||
|
||||
(define/public (get-pos)
|
||||
pos)
|
||||
|
||||
(define/public (set-pos! s)
|
||||
(set! pos s))
|
||||
|
||||
(define/public (get-neighbours)
|
||||
neighbours)
|
||||
|
||||
|
|
@ -93,8 +129,12 @@
|
|||
(define/public (set-neighbour! d n)
|
||||
(set! neighbours (insert neighbours d n 0)))
|
||||
|
||||
(define/public (get-contents)
|
||||
contents)
|
||||
(define/public (get-pickup)
|
||||
pickup)
|
||||
|
||||
(define/public (set-pickup! s)
|
||||
(when visible (set! update-me #t))
|
||||
(set! pickup s))
|
||||
|
||||
(define/public (get-connections)
|
||||
connections)
|
||||
|
|
@ -119,22 +159,61 @@
|
|||
(bool-list->num connections 0 0))
|
||||
|
||||
; 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
|
||||
((null? l) #f)
|
||||
((null? l) dirs)
|
||||
((not (send (get-neighbour (car l)) no-connections?))
|
||||
(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))
|
||||
(else (search/attach-to-neighbour (cdr l)))))
|
||||
(else (search/attach-to-neighbour (cdr l) dirs))))
|
||||
|
||||
(define/public (grow)
|
||||
; only possible to grow when we are a clear cell
|
||||
(when (equal? connections (list #f #f #f #f #f #f))
|
||||
(let ((dir (search/attach-to-neighbour (shuffle directions))))
|
||||
(when dir
|
||||
; it's dir is false if we have nothing around us to
|
||||
; connect to, probably shouldn't happen, haven't decided yet
|
||||
(set-connection! dir #t)))))
|
||||
(let ((dir (search/attach-to-neighbour (shuffle directions) '())))
|
||||
(when dir
|
||||
(set-connection! dir #t))
|
||||
#;(for-each
|
||||
(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)))
|
||||
|
||||
|
|
@ -145,7 +224,8 @@
|
|||
(field
|
||||
(cells '())
|
||||
(width 0)
|
||||
(height 0))
|
||||
(height 0)
|
||||
(insects '()))
|
||||
|
||||
(define/public (get-cell x y)
|
||||
(list-ref cells (+ (* y height) x)))
|
||||
|
|
@ -157,6 +237,9 @@
|
|||
; first build the cells
|
||||
(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:
|
||||
|
||||
; o o o o o o o o o o o
|
||||
|
|
@ -167,6 +250,7 @@
|
|||
(for ((x (in-range 0 width)))
|
||||
(for ((y (in-range 0 height)))
|
||||
(let ((cell (get-cell x y)))
|
||||
(send cell set-pos! (list x y))
|
||||
(when (and (< x (- width 1)) (> y 0))
|
||||
(send cell set-neighbour! NE (get-cell (if (odd? y) (+ x 1) x) (- y 1))))
|
||||
(when (< x (- width 1))
|
||||
|
|
@ -182,32 +266,38 @@
|
|||
(send cell set-neighbour! SW (get-cell (if (odd? y) x (- x 1)) (+ y 1))))))))
|
||||
|
||||
(define/public (seed x y)
|
||||
|
||||
(send (get-cell x y) set-connection! SE #t)
|
||||
(send (get-cell x (+ y 1)) set-connection! NW #t)
|
||||
|
||||
#;(let ((seed (get-cell x y)))
|
||||
; set all directions to be connected
|
||||
(for-each
|
||||
(lambda (d)
|
||||
(send seed set-connection! d #t))
|
||||
directions)
|
||||
|
||||
(for-each
|
||||
(lambda (n d)
|
||||
(send n set-connection! (rdirection d) #t))
|
||||
(send seed get-neighbours)
|
||||
directions)))
|
||||
(send (get-cell x (+ y 1)) set-connection! NW #t))
|
||||
|
||||
(define/public (get-update-list)
|
||||
(let ((i -1))
|
||||
(define/public (get-update-list time delta)
|
||||
|
||||
(append
|
||||
|
||||
; look for pickups over roots
|
||||
(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
|
||||
(lambda (cell r)
|
||||
(set! i (+ i 1))
|
||||
(if (send cell update-me?)
|
||||
(cons (list
|
||||
(list (modulo i width) (quotient i height))
|
||||
(send cell get-connection-num)) r)
|
||||
(let ((upstream (send cell get-upstream)))
|
||||
(cons (make-cell-update (send cell get-pos)
|
||||
(send cell get-connection-num)
|
||||
(send cell get-pickup)
|
||||
(if upstream (send upstream get-pos) #f)) r))
|
||||
r))
|
||||
'()
|
||||
cells)))
|
||||
|
|
@ -217,6 +307,13 @@
|
|||
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||||
; 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)
|
||||
(let ((p (build-polygons n 'polygon)))
|
||||
(with-primitive p
|
||||
|
|
@ -236,14 +333,81 @@
|
|||
(pdata-map! (lambda (n) (vector 0 0 1)) "n"))
|
||||
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%
|
||||
(class object%
|
||||
(field
|
||||
(root 0)
|
||||
(root2 0)
|
||||
(pickup-root 0)
|
||||
(t 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)
|
||||
(set! owner s))
|
||||
|
|
@ -263,7 +427,7 @@
|
|||
(parent owner)
|
||||
(hint-depth-sort)
|
||||
(opacity 0)
|
||||
(colour (vector 0.9 1 0.5))
|
||||
(colour (root-colour))
|
||||
(hint-unlit)
|
||||
(when (odd? (cadr pos))
|
||||
(translate (vector 0.5 0 0)))
|
||||
|
|
@ -280,7 +444,7 @@
|
|||
(set! root2 (build-prim code)))
|
||||
|
||||
(define (update-texture code)
|
||||
(texture (load-texture "textures/roots-ornate.png"))
|
||||
(texture (load-texture (append texpath "roots-ornate.png")))
|
||||
(pdata-map!
|
||||
(lambda (t tref)
|
||||
(let ((size (/ 1 8)))
|
||||
|
|
@ -295,15 +459,33 @@
|
|||
(set! root2 (build-prim code))
|
||||
(set! t 0))
|
||||
|
||||
(define/public (update)
|
||||
(set! t (+ t 0.04))
|
||||
|
||||
(define/public (set-pickup! type)
|
||||
(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)
|
||||
(with-primitive root
|
||||
(opacity (- 1 t)))
|
||||
(with-primitive root2
|
||||
(opacity t)))
|
||||
|
||||
|
||||
(when (> t 1)
|
||||
(with-primitive root
|
||||
(opacity 1))
|
||||
|
|
@ -316,14 +498,193 @@
|
|||
(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%
|
||||
(class object%
|
||||
(field
|
||||
(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)
|
||||
(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)
|
||||
(cond
|
||||
|
|
@ -331,30 +692,71 @@
|
|||
((eq? (send (cadr (car l)) get-root) p) (caar 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)
|
||||
(if (mouse-button 1)
|
||||
(get-pos-from-prim (mouse-over) cells)
|
||||
#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
|
||||
(lambda (cell)
|
||||
(send (cadr cell) update))
|
||||
(send (cadr cell) update time delta))
|
||||
cells)
|
||||
(for-each
|
||||
(lambda (insect)
|
||||
(send (cadr insect) update time delta))
|
||||
insects)
|
||||
|
||||
; read the update list, and dispatch based on type
|
||||
(for-each
|
||||
(lambda (item)
|
||||
(let*
|
||||
((pos (car item))
|
||||
(code (cadr item))
|
||||
(s (assoc pos cells)))
|
||||
(cond
|
||||
(s (send (cadr s) new-code code))
|
||||
(else
|
||||
(let ((cell (make-object cell-view%)))
|
||||
(send cell set-pos! pos)
|
||||
(send cell set-owner! root)
|
||||
(send cell build code)
|
||||
(set! cells (cons (list pos cell) cells)))))))
|
||||
(cond
|
||||
((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
|
||||
(let ((cell (make-object cell-view%)))
|
||||
(send cell set-pos! pos)
|
||||
(send cell set-owner! root)
|
||||
(send cell build code)
|
||||
(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))
|
||||
|
||||
(super-new)))
|
||||
|
|
@ -362,28 +764,34 @@
|
|||
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||||
|
||||
(clear)
|
||||
(clear-colour (vector 0.5 0.2 0.1))
|
||||
(clear-colour (bg-colour))
|
||||
(clear-texture-cache)
|
||||
(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 hcv (make-object honey-comb-view%))
|
||||
|
||||
(send hc init 100 100)
|
||||
(send hc init 20 20)
|
||||
|
||||
(with-state
|
||||
(translate (vector -50 -42.5 0))
|
||||
; (translate (vector -50 -42.5 0))
|
||||
; (translate (vector -10 -8.5 0))
|
||||
(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 49 53) grow)
|
||||
|
||||
(define t 0)
|
||||
(define d 0.04)
|
||||
|
||||
(define (animate)
|
||||
; (set! d (delta))
|
||||
(set! t (+ t d))
|
||||
(let ((clicked (send hcv deal-with-input)))
|
||||
(when clicked
|
||||
(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))
|
||||
|
|
|
|||
Loading…
Reference in a new issue