1274 lines
44 KiB
Scheme
1274 lines
44 KiB
Scheme
;#lang scheme/base
|
|
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
; hex ornament/groworld game : fluxus version
|
|
|
|
;(require fluxus-016/drflux)
|
|
(require scheme/class)
|
|
|
|
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
; tweakables
|
|
|
|
(define hex-width 40)
|
|
(define hex-height 40)
|
|
|
|
(define num-insects 50)
|
|
(define pickup-drop-probability 10)
|
|
|
|
(define surface-start 34)
|
|
(define surface-upper 39)
|
|
(define surface-lower 30)
|
|
|
|
(define (vec3->vec4 v a)
|
|
(vector (vx v) (vy v) (vz v) a))
|
|
|
|
(define (bg-colour) (vmul (vector 0.9 0.8 0.7) 0.2))
|
|
(define (sky-colour) (vector 0.7 0.8 1))
|
|
(define (worm-colour) (hsv->rgb (vector 0.1 (rndf) 1)))
|
|
(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 (rndf) 0.2 (+ 0.6 (rndf)))) 0.2))
|
|
|
|
(define (type->colour type)
|
|
(cond
|
|
((string=? type "knobbly") (vector 1 0.6 0.6))
|
|
((string=? type "lollypop") (vector 0.6 0.6 1))
|
|
((string=? type "nik") (vector 0.6 1 0.6))
|
|
(else (vector 1 1 1))))
|
|
|
|
;(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 "0" "1")) (list)))
|
|
((eq? num-children 1) (list "1-0" (list (make-random-plant (+ depth 1)))))
|
|
((eq? num-children 2) (list "2-0" (list (make-random-plant (+ depth 1))
|
|
(make-random-plant (+ depth 1)))))
|
|
((eq? num-children 3) (list "3-0" (list (make-random-plant (+ depth 1))
|
|
(make-random-plant (+ depth 1)) (make-random-plant (+ depth 1)))))
|
|
((eq? num-children 4) (list "4-0" (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-0" (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 rendering side
|
|
; ---------- --------------
|
|
; (no fluxus code allowed) | (no game code allowed)
|
|
; |
|
|
; comb-cell | comb-cell-view
|
|
; \ | /
|
|
; insect \ | / insect-view
|
|
; \ \ messages / /
|
|
; honey-comb ===========> honey-comb-view
|
|
; / | \
|
|
; garden | garden-view
|
|
; / | \
|
|
; plant | plant-view
|
|
;
|
|
;
|
|
|
|
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
; logic
|
|
|
|
; messages passed between the honey-comb logic and the view
|
|
(define-struct init-update (surface-pos-list))
|
|
(define-struct cell-update (pos code pickup upstream type))
|
|
(define-struct insect-update (id pos dir t))
|
|
(define-struct absorb-event (cell-pos type))
|
|
(define-struct plant-update (id desc pos type))
|
|
(define-struct controller-update (grow-pos))
|
|
|
|
(define comb-cell%
|
|
(class object%
|
|
(field
|
|
(plant #f) ; 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-plant)
|
|
plant)
|
|
|
|
(define/public (set-plant! s)
|
|
(set! plant 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)
|
|
(send n set-plant! plant)))
|
|
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)
|
|
(set! plant (send (get-neighbour (car l)) get-plant))
|
|
(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)
|
|
(d (+ 5.5 (* 2 (rndf))))) ; time to get from one cell to another
|
|
|
|
(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 d))
|
|
(set! cell (cadr m))
|
|
(make-insect-update id (send cell get-pos) (car m) d)))
|
|
(else #f)))
|
|
|
|
(super-new)))
|
|
|
|
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
|
|
(define plant%
|
|
(class object%
|
|
(init-field
|
|
(id "none")
|
|
(type "none")
|
|
(pos '())) ; the seed position
|
|
|
|
(field
|
|
(update-me #t)
|
|
(desc (make-random-plant 0)))
|
|
|
|
(define/public (get-id)
|
|
id)
|
|
|
|
(define/public (get-type)
|
|
type)
|
|
|
|
(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)
|
|
(send (cadr plant) get-pos)
|
|
(send (cadr plant) get-type)) r)
|
|
r))
|
|
'()
|
|
plants))
|
|
|
|
(super-new)))
|
|
|
|
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
|
|
(define honey-comb%
|
|
(class object%
|
|
(field
|
|
(cells '())
|
|
(width 0)
|
|
(height 0)
|
|
(insects '())
|
|
(garden (make-object garden%))
|
|
(surface-cells '())
|
|
(first-time #t))
|
|
|
|
(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)))))))
|
|
(set! surface-cells (calc-surface-cells 0 surface-start surface-upper surface-lower '())))
|
|
|
|
; we need to calculate the surface cells here, as we have the information
|
|
; to calculate an unbroken line of hexes
|
|
(define/public (calc-surface-cells x y upper lower l)
|
|
; calculate the surface hexes
|
|
(let* ((direction (choose (cond
|
|
((> y (- upper 1)) (list E NE))
|
|
((< y lower) (list E SE))
|
|
(else (list SE E NE)))))
|
|
(next-cell (send (get-cell x y) get-neighbour direction)))
|
|
(cond ((not next-cell) l)
|
|
(else
|
|
(let ((pos (send next-cell get-pos)))
|
|
(calc-surface-cells (car pos) (cadr pos) upper lower
|
|
(cons (list (list x y) direction) l)))))))
|
|
|
|
(define/public (seed id type i)
|
|
(let* ((x (car (car (list-ref surface-cells i))))
|
|
(y (cadr (car (list-ref surface-cells i))))
|
|
(plant (make-object plant% id type (list x y))))
|
|
(send garden add-plant plant)
|
|
(send (get-cell x (- y 1)) set-plant! plant)
|
|
(send (get-cell x (- y 1)) set-connection! SE #t)
|
|
#;(send (get-cell x (- y 1)) set-plant! plant)
|
|
#;(send (get-cell x (- y 1)) set-connection! NW #t)))
|
|
|
|
(define/public (update time delta)
|
|
|
|
(append
|
|
|
|
; first frame, send the cells that represent the surface, so they can be drawn
|
|
(cond (first-time (set! first-time #f) (list (make-init-update surface-cells)))
|
|
(else '()))
|
|
|
|
; 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))
|
|
(plant (send cell get-plant)))
|
|
(cons (make-cell-update (send cell get-pos)
|
|
(send cell get-connection-num)
|
|
(send cell get-pickup)
|
|
(if upstream (send upstream get-pos) #f)
|
|
(if plant (send plant get-type) #f)) r))
|
|
r))
|
|
'()
|
|
cells)
|
|
|
|
; get updates from the garden
|
|
(send garden update)))
|
|
|
|
(super-new)))
|
|
|
|
;======================================================================
|
|
; graphics and interaction
|
|
|
|
; more odds and sods...
|
|
|
|
(define (direction-normal d)
|
|
(let ((a (* 2 1.141 60)))
|
|
(vmul (vector (sin (* a d)) (cos (* a d)) 0) -1)))
|
|
|
|
(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-hex x y root)
|
|
(with-state
|
|
;(hint-wire)
|
|
(parent root)
|
|
(hint-unlit)
|
|
(when (odd? y)
|
|
(translate (vector 0.5 0 0)))
|
|
(translate (vector x (* 0.85 y) (* 0.001 (rndf))))
|
|
(scale (vector 0.58 0.57 1))
|
|
(rotate (vector 0 0 90))
|
|
(build-ngon 6)))
|
|
|
|
; 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 type)
|
|
(let ((ret (assoc (list id type) connection-cache)))
|
|
(cond
|
|
(ret (cdr ret))
|
|
(else
|
|
(let* ((tex (load-primitive (string-append "plants/" type "/branches/comp-cp-" id ".png")))
|
|
(connections (with-primitive tex (convert-to-pos (find-centroids 0 '())))))
|
|
(set! connection-cache (cons (cons (list id type) connections) connection-cache))
|
|
;(printf "~a:~a~n" id (length connections))
|
|
(destroy tex)
|
|
connections)))))
|
|
|
|
|
|
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
; a plant component
|
|
|
|
(define-struct component (root (col #:mutable) children))
|
|
|
|
(define (build-component id type col children)
|
|
(cond
|
|
((null? children)
|
|
(let ((root (with-state
|
|
(colour col)
|
|
(hint-unlit)
|
|
(hint-depth-sort)
|
|
(translate (vector 0 0.5 0))
|
|
(texture (load-texture (string-append "plants/" type "/leaves/comp-" id ".png")))
|
|
(build-plane))))
|
|
(make-component root col '())))
|
|
(else
|
|
(let ((connection-list (get-connection-list id type))
|
|
(root (with-state
|
|
(colour col)
|
|
(hint-unlit)
|
|
(hint-depth-sort)
|
|
(translate (vector 0 0.5 0))
|
|
(texture (load-texture (string-append "plants/" type "/branches/comp-" id ".png")))
|
|
(build-plane))))
|
|
(when (not (eq? (length connection-list) (length children)))
|
|
(printf "something wrong: ~a children:~a connections:~a~n" id (length children) (length connection-list) ))
|
|
|
|
(let ((comp (make-component root col
|
|
(map
|
|
(lambda (child connection)
|
|
(with-state
|
|
(parent root)
|
|
(translate (vadd connection (vector 0 0 (* 0.001 (rndf)))))
|
|
(rotate (vector 0 0 (2dvec->angle
|
|
(vx connection) (- (vy connection) 0.5))))
|
|
;(scale 0.9)
|
|
(build-component (car child) type 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)
|
|
(tile1 0)
|
|
(tile2 0)
|
|
(bgtile 0)
|
|
(pickup-root 0)
|
|
(t 0)
|
|
(pos '(0 0))
|
|
(owner 0)
|
|
(type #f) ; the plant type of the owner of the roots, if any
|
|
(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-tile)
|
|
tile1)
|
|
|
|
(define/public (get-pos)
|
|
pos)
|
|
|
|
(define/public (set-pos! s)
|
|
(set! pos s))
|
|
|
|
(define/public (set-type! s)
|
|
(set! type s))
|
|
|
|
(define (build-prim code)
|
|
(let ((p (build-hex 0 0 root)))
|
|
(with-primitive p
|
|
(hint-depth-sort)
|
|
(colour (root-colour))
|
|
(opacity 0)
|
|
(update-texture code))
|
|
p))
|
|
|
|
(define/public (build code)
|
|
(set! root (with-state
|
|
(parent owner)
|
|
(when (odd? (cadr pos))
|
|
(translate (vector 0.5 0 0)))
|
|
(translate (vector (car pos) (* 0.85 (cadr pos)) 0))
|
|
(build-locator)))
|
|
|
|
(when (zero? bgtile)
|
|
(set! bgtile (build-hex 0 0 root))
|
|
(with-primitive bgtile
|
|
(hint-depth-sort)
|
|
(texture (load-texture (string-append texpath "stones.png")))
|
|
(translate (vector 0 0 -0.1))
|
|
(rotate (vector 0 0 (* (random 6) 60))))
|
|
(let ((code (random 4)))
|
|
(with-primitive bgtile
|
|
(pdata-map!
|
|
(lambda (t)
|
|
(let ((size (/ 1 2)))
|
|
(vadd (vmul t size) (vector (* 1 size (+ 1 (modulo code 2)))
|
|
(* size 1 (+ 1 (quotient code 2))) 0))))
|
|
"t"))))
|
|
|
|
(set! tile1 (build-prim code))
|
|
(set! tile2 (build-prim code)))
|
|
|
|
(define (update-texture code)
|
|
; todo: variations
|
|
(when type
|
|
(texture (load-texture (string-append "plants/" type "/roots/roots.png")))
|
|
(colour (type->colour type)))
|
|
(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? tile2))
|
|
(destroy tile2)
|
|
(with-primitive tile1 (opacity 1)))
|
|
(set! tile2 (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 root)
|
|
(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 tile1
|
|
(opacity (- 1 t)))
|
|
(with-primitive tile2
|
|
(opacity t)))
|
|
|
|
(when (> t 1)
|
|
(with-primitive tile1
|
|
(opacity 1))
|
|
|
|
(when (not (zero? tile2))
|
|
(destroy tile1)
|
|
(set! tile1 tile2)
|
|
(set! tile2 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)
|
|
(from2 (vector 0 0 0))
|
|
(from-dir2 (vector 0 0 0)))
|
|
|
|
(define/override (goto-cell cell dir dur)
|
|
(set! from2 from)
|
|
(set! from to)
|
|
(set! from-dir2 from-dir)
|
|
(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/override (build)
|
|
(set! root (build-ribbon 20))
|
|
(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.05 (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? from2 (vector 0 0 0)))
|
|
(set! hidden #t)
|
|
(with-primitive root (hide 1)))
|
|
(else
|
|
(let ((t (/ t d))) ; normalise time
|
|
(with-primitive root
|
|
(when hidden
|
|
(set! hidden #f)
|
|
(pdata-map!
|
|
(lambda (p)
|
|
from)
|
|
"p"))
|
|
(hide 0)
|
|
(pdata-index-map!
|
|
(lambda (i p)
|
|
(let ((st (- t (* i 0.05))))
|
|
(if (< st 0)
|
|
(hermite (+ st 1) from2 from (vmul from-dir2 2) (vmul from-dir 2))
|
|
(hermite st from to (vmul from-dir 2) (vmul to-dir 2)))))
|
|
"p")))))
|
|
|
|
(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 (build s type)
|
|
(set! desc s)
|
|
|
|
(when (not (zero? root))
|
|
(destroy root))
|
|
|
|
(set! root (build-locator))
|
|
|
|
; build the plant
|
|
(with-state
|
|
(parent root)
|
|
(hint-depth-sort)
|
|
(translate (vector 0.2 0.3 0.1))
|
|
(build-component "1-0" type (type->colour type) (list desc))))
|
|
|
|
|
|
(super-new)))
|
|
|
|
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
|
|
(define garden-view%
|
|
(class object%
|
|
(field
|
|
(plants '()))
|
|
|
|
(define/public (add-plant! id desc hex type)
|
|
(let ((plant (make-object plant-view%)))
|
|
(with-state
|
|
(parent (send hex get-root))
|
|
(send plant build desc type)
|
|
(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 (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)))
|
|
|
|
(define (get-pos-from-prim-impl p l)
|
|
(cond
|
|
((null? l) #f)
|
|
((eq? (send (cadr (car l)) get-tile) p) (caar l))
|
|
(else (get-pos-from-prim-impl p (cdr l)))))
|
|
|
|
(define/public (get-pos-from-prim p)
|
|
(get-pos-from-prim-impl p cells))
|
|
|
|
(define/public (get-cell-from-pos pos)
|
|
(cadr (assoc pos cells)))
|
|
|
|
|
|
|
|
(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 "surface3.png"))))
|
|
|
|
(define (surface-contains? pos l)
|
|
(cond
|
|
((null? l) #f)
|
|
((equal? (car (car l)) pos) #t)
|
|
(else (surface-contains? pos (cdr l)))))
|
|
|
|
(define/public (build-surface l)
|
|
(let ((s (reverse l)))
|
|
(for ((i (in-range 1 (- (length s) 1))))
|
|
(let ((x (caar (list-ref s i)))
|
|
(y (cadr (car (list-ref s i))))
|
|
(d (car (cdr (list-ref s i))))
|
|
(ld (car (cdr (list-ref s (- i 1))))))
|
|
(let ((p (with-state
|
|
(colour (sky-colour))
|
|
(build-hex x y root))))
|
|
(with-primitive p
|
|
(surface-texture
|
|
(cond
|
|
((eq? ld NE) 0)
|
|
((eq? ld E) 1)
|
|
((eq? ld SE) 2))
|
|
(cond
|
|
((eq? d NE) 2)
|
|
((eq? d E) 1)
|
|
((eq? d SE) 0)))))
|
|
(for ((i (in-range (+ y 1) (+ surface-upper 1))))
|
|
(when (not (surface-contains? (list x i) s))
|
|
(with-state
|
|
(colour (sky-colour))
|
|
(build-hex x i root))))))))
|
|
|
|
(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))
|
|
(send (cadr s) set-type! (cell-update-type item)))
|
|
(else
|
|
(let ((cell (make-object cell-view%)))
|
|
(send cell set-pos! pos)
|
|
(send cell set-owner! root)
|
|
(send cell set-type! (cell-update-type item))
|
|
(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)
|
|
(send garden add-plant!
|
|
(plant-update-id item)
|
|
(plant-update-desc item)
|
|
(get-cell-from-pos (plant-update-pos item))
|
|
(plant-update-type item)))
|
|
|
|
((init-update? item)
|
|
(build-surface (init-update-surface-pos-list item)))))
|
|
|
|
|
|
|
|
update-list))
|
|
|
|
(super-new)))
|
|
|
|
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
|
|
(define controller%
|
|
(class object%
|
|
(field
|
|
(camera-pos (vector -13 -27 -5)))
|
|
|
|
(define/public (update)
|
|
(when (key-pressed "a")
|
|
(set! camera-pos (vadd camera-pos (vector 0.1 0 0))))
|
|
(when (key-pressed "d")
|
|
(set! camera-pos (vadd camera-pos (vector -0.1 0 0))))
|
|
(when (key-pressed "s")
|
|
(set! camera-pos (vadd camera-pos (vector 0 0.1 0))))
|
|
(when (key-pressed "w")
|
|
(set! camera-pos (vadd camera-pos (vector 0 -0.1 0))))
|
|
(when (key-pressed "z")
|
|
(set! camera-pos (vadd camera-pos (vector 0 0 0.1))))
|
|
(when (key-pressed "x")
|
|
(set! camera-pos (vadd camera-pos (vector 0 0 -0.1))))
|
|
(set-camera-transform (mtranslate camera-pos))
|
|
(if (mouse-button 1)
|
|
(mouse-over)
|
|
0))
|
|
|
|
(super-new)))
|
|
|
|
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
|
|
(clear)
|
|
(clear-colour (bg-colour))
|
|
(define hc (make-object honey-comb%))
|
|
(define hcv (make-object honey-comb-view%))
|
|
(define g (make-object garden%))
|
|
(define con (make-object controller%))
|
|
|
|
(send hc init hex-width hex-height)
|
|
(send hcv init)
|
|
|
|
(send hc seed "dave@fo.am" "knobbly" 45)
|
|
(send hc seed "plant00002@fo.am" "lollypop" 30)
|
|
(send hc seed "plant00003@fo.am" "nik" 15)
|
|
|
|
(with-state
|
|
(colour (sky-colour))
|
|
(hint-unlit)
|
|
(translate (vector 0 (- surface-upper 0.6) 0))
|
|
(scale (vector 100 10 1))
|
|
(build-plane))
|
|
|
|
(define t 0)
|
|
(define d 0.04)
|
|
|
|
(define (animate)
|
|
; (set! d (delta))
|
|
(set! t (+ t d))
|
|
(let ((clicked (send con update)))
|
|
(when (not (zero? clicked))
|
|
(let ((pos (send hcv get-pos-from-prim clicked)))
|
|
(when pos
|
|
(send (send hc get-cell (car pos) (cadr pos)) grow)))))
|
|
(send hcv update (send hc update t d) t d))
|
|
|
|
|
|
;(for ((i (in-range 0 10))) (animate))
|
|
(every-frame (animate))
|