1138 lines
39 KiB
Scheme
1138 lines
39 KiB
Scheme
;#lang scheme
|
|
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
; hex ornament/groworld game : fluxus version
|
|
|
|
;(require fluxus-016/drflux.ss)
|
|
(require scheme/class)
|
|
|
|
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
; tweakables
|
|
|
|
(define num-insects 20)
|
|
(define pickup-drop-probability 10)
|
|
|
|
(define (vec3->vec4 v a)
|
|
(vector (vx v) (vy v) (vz v) a))
|
|
|
|
(define (bg-colour) (vector 0.2 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) (vec3->vec4 (hsv->rgb (vector 0.1 (rndf) 1)) 0.2))
|
|
|
|
;(define texpath "")
|
|
(define texpath "textures/")
|
|
|
|
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
; odds and sods
|
|
|
|
; return a version of list l with v inserted at the nth
|
|
; position and with c as a counter
|
|
(define (insert l n v c)
|
|
(cond
|
|
((null? l) l)
|
|
((eq? c n) (cons v (insert (cdr l) n v (+ c 1))))
|
|
(else (cons (car l) (insert (cdr l) n v (+ c 1))))))
|
|
|
|
(define (list-remove l i)
|
|
(if (zero? i)
|
|
(cdr l)
|
|
(cons (car l) (list-remove (cdr l) (- i 1)))))
|
|
|
|
(define (shuffle l)
|
|
(if (null? l)
|
|
'()
|
|
(let ((i (random (length l))))
|
|
(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)
|
|
(cond
|
|
((null? l) n)
|
|
((car l) (bitwise-ior (arithmetic-shift 1 c)
|
|
(bool-list->num (cdr l) n (+ c 1))))
|
|
(else (bool-list->num (cdr l) n (+ c 1)))))
|
|
|
|
; how to find your way around a hexagon
|
|
; .
|
|
; 5 (NW) / \ 0 (NE)
|
|
; / \
|
|
; 4 (W)| | 1 (E)
|
|
; | |
|
|
; \ /
|
|
; 3 (SW) \ / 2 (SE)
|
|
; `
|
|
|
|
(define NE 0)
|
|
(define E 1)
|
|
(define SE 2)
|
|
(define SW 3)
|
|
(define W 4)
|
|
(define NW 5)
|
|
|
|
(define directions (list NE E SE SW W NW))
|
|
|
|
(define (rdirection d)
|
|
(cond
|
|
((eq? d NE) SW)
|
|
((eq? d E) W)
|
|
((eq? d SE) NW)
|
|
((eq? d SW) NE)
|
|
((eq? d W) E)
|
|
((eq? d NW) SE)))
|
|
|
|
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
; util for building random plants
|
|
|
|
(define (make-random-plant depth)
|
|
(let ((num-children (cond ((> depth 2) 0)
|
|
((< depth 1) (choose (list 2 3)))
|
|
(else (choose (list 0 1 2 3))))))
|
|
(cond
|
|
((eq? num-children 0) (list (choose (list "11")) (list)))
|
|
((eq? num-children 1) (list "1-1" (list (make-random-plant (+ depth 1)))))
|
|
((eq? num-children 2) (list "2-1" (list (make-random-plant (+ depth 1))
|
|
(make-random-plant (+ depth 1)))))
|
|
((eq? num-children 3) (list "3-1" (list (make-random-plant (+ depth 1))
|
|
(make-random-plant (+ depth 1)) (make-random-plant (+ depth 1)))))
|
|
((eq? num-children 4) (list "4-1" (list (make-random-plant (+ depth 1))
|
|
(make-random-plant (+ depth 1)) (make-random-plant (+ depth 1))
|
|
(make-random-plant (+ depth 1)))))
|
|
((eq? num-children 5) (list "5-1" (list (make-random-plant (+ depth 1))
|
|
(make-random-plant (+ depth 1)) (make-random-plant (+ depth 1))
|
|
(make-random-plant (+ depth 1)) (make-random-plant (+ depth 1))))))))
|
|
|
|
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
; how this works
|
|
;
|
|
; logic side view side
|
|
; ---------- ---------
|
|
; * no fluxus code | * no game code
|
|
; |
|
|
; comb-cell | comb-cell-view
|
|
; \ | /
|
|
; insect \ | / insect-view
|
|
; \ \ messages / /
|
|
; honey-comb ===========> honey-comb-view
|
|
; / | \
|
|
; garden | garden-view
|
|
;
|
|
;
|
|
;
|
|
;
|
|
|
|
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
; logic
|
|
|
|
; messages passed between the honey-comb 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-struct plant-update (id desc))
|
|
|
|
(define comb-cell%
|
|
(class object%
|
|
(field
|
|
(id #f) ; id of the owner plant
|
|
(pos '())
|
|
(neighbours '(#f #f #f #f #f #f))
|
|
(pickup #f)
|
|
(connections '(#f #f #f #f #f #f))
|
|
(visible #f)
|
|
(update-me #f)
|
|
(upstream #f)) ; the cell we are connected to (if we are)
|
|
|
|
(define/public (get-id)
|
|
id)
|
|
|
|
(define/public (set-id! s)
|
|
(set! id s))
|
|
|
|
(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))
|
|
|
|
(define/public (visible?)
|
|
visible)
|
|
|
|
(define/public (get-pos)
|
|
pos)
|
|
|
|
(define/public (set-pos! s)
|
|
(set! pos s))
|
|
|
|
(define/public (get-neighbours)
|
|
neighbours)
|
|
|
|
(define/public (get-neighbour d)
|
|
(list-ref neighbours d))
|
|
|
|
(define/public (set-neighbour! d n)
|
|
(set! neighbours (insert neighbours d n 0)))
|
|
|
|
(define/public (get-pickup)
|
|
pickup)
|
|
|
|
(define/public (set-pickup! s)
|
|
(when visible (set! update-me #t))
|
|
(set! pickup s))
|
|
|
|
(define/public (get-connections)
|
|
connections)
|
|
|
|
(define/public (no-connections?)
|
|
(equal? connections (list #f #f #f #f #f #f)))
|
|
|
|
(define/public (set-connection! d n)
|
|
(set! update-me #t)
|
|
(set! visible #t)
|
|
(set! connections (insert connections d n 0))
|
|
; tell all our neighbours to become visible
|
|
(for-each
|
|
(lambda (n)
|
|
(when n (send n set-visible! #t)))
|
|
neighbours))
|
|
|
|
(define/public (get-connection d)
|
|
(list-ref connections d))
|
|
|
|
(define/public (get-connection-num)
|
|
(bool-list->num connections 0 0))
|
|
|
|
; returns the first attachable neighbour found, and sets it's connection
|
|
(define (search/attach-to-neighbour l dirs)
|
|
(cond
|
|
((null? l) dirs)
|
|
((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-id! id)
|
|
(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) 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
|
|
(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)))
|
|
|
|
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
|
|
(define plant%
|
|
(class object%
|
|
(init-field
|
|
(id "default")
|
|
(pos '())) ; the seed position
|
|
|
|
(field
|
|
(update-me #t)
|
|
(desc (make-random-plant 3)))
|
|
|
|
(define/public (get-id)
|
|
id)
|
|
|
|
(define/public (update-me?)
|
|
(let ((r update-me))
|
|
(set! update-me #f)
|
|
r))
|
|
|
|
(define/public (get-desc)
|
|
desc)
|
|
|
|
(define/public (get-pos)
|
|
pos)
|
|
|
|
(define/public (init x y)
|
|
(set! pos (list x y)))
|
|
|
|
(super-new)))
|
|
|
|
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
|
|
(define garden%
|
|
(class object%
|
|
(field
|
|
(plants '()))
|
|
|
|
(define/public (add-plant plant)
|
|
(set! plants (cons (list (send plant get-id) plant) plants)))
|
|
|
|
; returns a list of plant descriptions needing updating by the view
|
|
(define/public (update)
|
|
(foldl
|
|
(lambda (plant r)
|
|
(if (send (cadr plant) update-me?)
|
|
(cons (make-plant-update (car plant)
|
|
(send (cadr plant) get-desc)) r)
|
|
r))
|
|
'()
|
|
plants))
|
|
|
|
(super-new)))
|
|
|
|
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
|
|
(define honey-comb%
|
|
(class object%
|
|
(field
|
|
(cells '())
|
|
(width 0)
|
|
(height 0)
|
|
(insects '())
|
|
(garden (make-object garden%)))
|
|
|
|
(define/public (get-cell x y)
|
|
(list-ref cells (+ (* y height) x)))
|
|
|
|
(define/public (init w h)
|
|
(set! width w)
|
|
(set! height h)
|
|
|
|
; 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
|
|
; o o o o o o o o o o o
|
|
; o o o o o o o o o o o
|
|
; o o o o o o o o o o o
|
|
|
|
(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))
|
|
(send cell set-neighbour! E (get-cell (+ x 1) y)))
|
|
(when (and (< x (- width 1)) (< y (- height 1)))
|
|
(send cell set-neighbour! SE (get-cell (if (odd? y) (+ x 1) x) (+ y 1))))
|
|
|
|
(when (and (> x 0) (> y 0))
|
|
(send cell set-neighbour! NW (get-cell (if (odd? y) x (- x 1)) (- y 1))))
|
|
(when (> x 0)
|
|
(send cell set-neighbour! W (get-cell (- x 1) y)))
|
|
(when (and (> x 0) (< y (- height 1)))
|
|
(send cell set-neighbour! SW (get-cell (if (odd? y) x (- x 1)) (+ y 1))))))))
|
|
|
|
|
|
(define/public (seed id x y)
|
|
(send garden add-plant (make-object plant% id (list x y)))
|
|
(send (get-cell x y) set-connection! SE #t)
|
|
(send (get-cell x y) set-id! id)
|
|
(send (get-cell x (+ y 1)) set-connection! NW #t)
|
|
(send (get-cell x (+ y 1)) set-id! id))
|
|
|
|
(define/public (update time delta)
|
|
|
|
(append
|
|
|
|
; get updates from the garden
|
|
(send garden update)
|
|
|
|
; 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)
|
|
(if (send cell update-me?)
|
|
(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)))
|
|
|
|
(super-new)))
|
|
|
|
;======================================================================
|
|
; 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
|
|
(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))
|
|
|
|
(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))))
|
|
|
|
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
; pluggable plants code follows
|
|
|
|
; pixel primitive things for getting connection points
|
|
|
|
; converts a 2D vector into an angle, with some dodgy dave maths
|
|
(define (2dvec->angle x y)
|
|
(let ((q (/ 3.141 2)))
|
|
(when (zero? y) (set! y 0.0001))
|
|
(cond
|
|
((>= y 0)
|
|
(fmod (* (+ q q q (- q (atan (/ x y)))) 57.2957795) 360))
|
|
(else
|
|
(fmod (* (+ q (- q (atan (/ x y)))) 57.2957795) 360)))))
|
|
|
|
(define (i->pos i)
|
|
(vector (modulo i (pixels-width))
|
|
(quotient i (pixels-width)) 0))
|
|
|
|
(define (pos->i pos)
|
|
(+ (* (round (vy pos)) (pixels-width)) (round (vx pos))))
|
|
|
|
(define (pixels-ref name pos)
|
|
(pdata-ref name (pos->i pos)))
|
|
|
|
(define (pixels-set! name pos s)
|
|
(pdata-set! name (pos->i pos) s))
|
|
|
|
(define (search i)
|
|
(cond
|
|
((eq? i (pdata-size)) i)
|
|
((< (vr (pdata-ref "c" i)) 0.5) i)
|
|
(else (search (+ i 1)))))
|
|
|
|
(define (flood pos tc av)
|
|
(define (rec-flood pos)
|
|
(pixels-set! "c" pos (vector 1 0 1))
|
|
(set! tc (+ tc 1))
|
|
(set! av (vadd av pos))
|
|
(when (< (vr (pixels-ref "c" (vadd pos (vector -1 0 0)))) 0.5)
|
|
(rec-flood (vadd pos (vector -1 0 0))))
|
|
(when (< (vr (pixels-ref "c" (vadd pos (vector 1 0 0)))) 0.5)
|
|
(rec-flood (vadd pos (vector 1 0 0))))
|
|
(when (< (vr (pixels-ref "c" (vadd pos (vector 0 1 0)))) 0.5)
|
|
(rec-flood (vadd pos (vector 0 1 0))))
|
|
(when (< (vr (pixels-ref "c" (vadd pos (vector 0 -1 0)))) 0.5)
|
|
(rec-flood (vadd pos (vector 0 -1 0)))))
|
|
(rec-flood pos)
|
|
(vmul av (/ 1 tc)))
|
|
|
|
(define (find-centroids pos l)
|
|
(let ((i (search pos)))
|
|
(cond ((eq? i (pdata-size)) l)
|
|
(else
|
|
(find-centroids i
|
|
(cons (flood (i->pos i) 0 (vector 0 0 0)) l))))))
|
|
|
|
(define (convert-to-pos l)
|
|
(map
|
|
(lambda (cp)
|
|
(vector (- (- (/ (vx cp) (pixels-width)) 0.5))
|
|
(/ (vy cp) (pixels-height)) 0))
|
|
l))
|
|
|
|
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
; a cache for the connection points - should save this out
|
|
|
|
(define connection-cache '())
|
|
|
|
(define (get-connection-list id)
|
|
(let ((ret (assoc id connection-cache)))
|
|
(cond
|
|
(ret (cdr ret))
|
|
(else
|
|
(let* ((tex (load-primitive (string-append "textures/comp-cp-" id ".png")))
|
|
(connections (with-primitive tex (convert-to-pos (find-centroids 0 '())))))
|
|
(set! connection-cache (cons (cons id connections) connection-cache))
|
|
(destroy tex)
|
|
connections)))))
|
|
|
|
|
|
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
; a plant component
|
|
|
|
(define-struct component (root (col #:mutable) children))
|
|
|
|
(define (build-component id col children)
|
|
(cond
|
|
((null? children)
|
|
(let ((root (with-state
|
|
(translate (vector 0 0.5 (* 0.01 (rndf))))
|
|
(hint-none)
|
|
(hint-solid)
|
|
(hint-unlit)
|
|
(hint-depth-sort)
|
|
(texture (load-texture (string-append "textures/comp-" id ".png")))
|
|
(build-plane))))
|
|
(make-component root col '())))
|
|
(else
|
|
(let* ((connection-list (get-connection-list id))
|
|
(root (with-state
|
|
(hint-depth-sort)
|
|
(translate (vector 0 0.5 (* 0.01 (rndf))))
|
|
; (rotate (vector 0 0 90))
|
|
(texture (load-texture (string-append "textures/comp-" id ".png")))
|
|
(build-plane)))
|
|
(comp (make-component root col
|
|
(map
|
|
(lambda (child connection)
|
|
(with-state
|
|
(parent root)
|
|
(translate (vadd connection (vector 0 0 (* 0.01 (rndf)))))
|
|
(rotate (vector 0 0 (2dvec->angle
|
|
(vx connection) (- (vy connection) 0.5))))
|
|
(rotate (vector 0 0 0))
|
|
(build-component (car child) col (cadr child))))
|
|
children
|
|
connection-list))))
|
|
(with-primitive root (apply-transform))
|
|
comp))))
|
|
|
|
(define (random-leaf component)
|
|
(cond
|
|
((null? (component-children component)) component)
|
|
(else (random-leaf (choose (component-children component))))))
|
|
|
|
(define (component-leaves component)
|
|
(cond
|
|
((null? (component-children component)) (list component))
|
|
(else
|
|
(foldl
|
|
(lambda (child r)
|
|
(append (component-leaves child) r))
|
|
'()
|
|
(component-children component)))))
|
|
|
|
(define (component-print component)
|
|
(printf "~a~n" (component-children component)))
|
|
|
|
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
|
|
(define cell-view%
|
|
(class object%
|
|
(field
|
|
(root 0)
|
|
(root2 0)
|
|
(pickup-root 0)
|
|
(t 0)
|
|
(pos '(0 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))
|
|
|
|
(define/public (get-root)
|
|
root)
|
|
|
|
(define/public (get-pos)
|
|
pos)
|
|
|
|
(define/public (set-pos! s)
|
|
(set! pos s))
|
|
|
|
(define (build-prim code)
|
|
(let ((p (with-state
|
|
;(hint-wire)
|
|
(parent owner)
|
|
(hint-depth-sort)
|
|
(opacity 0)
|
|
(colour (root-colour))
|
|
(hint-unlit)
|
|
(when (odd? (cadr pos))
|
|
(translate (vector 0.5 0 0)))
|
|
(translate (vector (car pos) (* 0.85 (cadr pos)) (* 0.001 (rndf))))
|
|
(scale 0.57)
|
|
(rotate (vector 0 0 90))
|
|
(build-ngon 6))))
|
|
(with-primitive p
|
|
(update-texture code))
|
|
p))
|
|
|
|
(define/public (build code)
|
|
(set! root (build-prim code))
|
|
(set! root2 (build-prim code)))
|
|
|
|
(define (update-texture code)
|
|
(texture (load-texture (string-append texpath "roots-ornate.png")))
|
|
(pdata-map!
|
|
(lambda (t tref)
|
|
(let ((size (/ 1 8)))
|
|
(vadd (vmul tref size) (vector (* 1 size (+ 1 (modulo code 8)))
|
|
(* size 1 (+ 1 (quotient code 8))) 0))))
|
|
"t" "tref"))
|
|
|
|
(define/public (new-code code)
|
|
(when (not (zero? root2))
|
|
(destroy root2)
|
|
(with-primitive root (opacity 1)))
|
|
(set! root2 (build-prim code))
|
|
(set! t 0))
|
|
|
|
(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))
|
|
|
|
(when (not (zero? root2))
|
|
(destroy root)
|
|
(set! root root2)
|
|
(set! root2 0))))
|
|
|
|
(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 (string-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 (string-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
|
|
(translate (vector 0 0 0.2))
|
|
(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.2 (+ 0.1 (rndf)))))
|
|
(vector s s 1)))
|
|
"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 plant-view%
|
|
(class object%
|
|
(field
|
|
(root 0)
|
|
(desc '()))
|
|
|
|
(define/public (set-desc! s)
|
|
(set! desc s)
|
|
|
|
(when (not (zero? root))
|
|
(destroy root))
|
|
|
|
; build the plant
|
|
)
|
|
|
|
|
|
(super-new)))
|
|
|
|
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
|
|
(define garden-view%
|
|
(class object%
|
|
(field
|
|
(plants '()))
|
|
|
|
(define/public (add-plant! id plant)
|
|
(set! plants (cons (list id plant) plants)))
|
|
|
|
(super-new)))
|
|
|
|
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
|
|
(define honey-comb-view%
|
|
(class object%
|
|
(field
|
|
(root 0)
|
|
(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
|
|
(garden-view (make-object garden-view%)))
|
|
|
|
(define/public (init)
|
|
(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))
|
|
(build-surface))
|
|
|
|
(define (get-pos-from-prim p l)
|
|
(cond
|
|
((null? l) #f)
|
|
((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 (add-absorb! s)
|
|
(set! absorb-list (cons s absorb-list)))
|
|
|
|
(define (surface-texture x y)
|
|
(pdata-map!
|
|
(lambda (t)
|
|
(let ((size (/ 1 3)))
|
|
(vadd (vmul t size)
|
|
(vector (* size (+ x 1)) (* size (+ y 1)) 0))))
|
|
"t")
|
|
(texture (load-texture (string-append texpath "surface2.png"))))
|
|
|
|
(define (make-surface lev top len l)
|
|
(cond
|
|
((zero? len) l)
|
|
(else (make-surface
|
|
(if (zero? (random 2))
|
|
(if (< lev top) (+ lev 1) lev)
|
|
(if (> lev (- top 1)) (- lev 1) lev))
|
|
top (- len 1) (cons lev l)))))
|
|
|
|
(define/public (build-surface)
|
|
(let ((s (make-surface 12 13 20 '())))
|
|
(for ((i (in-range 1 (- (length s) 1))))
|
|
(let ((x i) (y (list-ref s i))
|
|
(yb (list-ref s (- i 1)))
|
|
(ya (list-ref s (+ i 1))))
|
|
|
|
(let ((p (with-state
|
|
(parent root)
|
|
(hint-unlit)
|
|
(when (odd? y)
|
|
(translate (vector 0.5 0 0)))
|
|
(translate (vector x (* 0.85 y) (* 0.001 (rndf))))
|
|
(scale 0.57)
|
|
(rotate (vector 0 0 90))
|
|
(build-ngon 6))))
|
|
(with-primitive p
|
|
(surface-texture
|
|
(cond
|
|
((> yb y) 0)
|
|
((< yb y) 2)
|
|
(else 1))
|
|
(cond
|
|
((> ya y) 0)
|
|
((< ya y) 2)
|
|
(else 1)))))))))
|
|
|
|
|
|
(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 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)
|
|
(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)))
|
|
((plant-update? item)
|
|
(printf "got a plant update!~n"))))
|
|
update-list))
|
|
|
|
(super-new)))
|
|
|
|
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
|
|
|
|
(clear)
|
|
(clear-colour (bg-colour))
|
|
(clear-texture-cache)
|
|
(show-axis 0)
|
|
(set-camera-transform (mtranslate (vector -10 -6 -8)))
|
|
|
|
(define hc (make-object honey-comb%))
|
|
(define hcv (make-object honey-comb-view%))
|
|
(define g (make-object garden%))
|
|
|
|
(send hc init 20 20)
|
|
|
|
(with-state
|
|
; (translate (vector -50 -42.5 0))
|
|
; (translate (vector -10 -8.5 0))
|
|
(send hcv init))
|
|
|
|
(send hc seed "dave@fo.am" 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 update t d) t d))
|
|
|
|
(every-frame (animate))
|