groworld/hex-ornament/hex-ornament.scm

1274 lines
44 KiB
Scheme
Raw Normal View History

2009-07-09 11:52:56 +00:00
;#lang scheme/base
2009-06-08 15:25:32 +00:00
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2009-06-08 15:54:51 +00:00
; hex ornament/groworld game : fluxus version
2009-06-08 15:25:32 +00:00
2009-07-09 11:52:56 +00:00
;(require fluxus-016/drflux)
(require scheme/class)
2009-06-08 15:25:32 +00:00
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; tweakables
2009-06-15 11:19:54 +00:00
(define hex-width 40)
(define hex-height 40)
(define num-insects 50)
2009-06-08 15:25:32 +00:00
(define pickup-drop-probability 10)
2009-06-15 11:19:54 +00:00
(define surface-start 34)
(define surface-upper 39)
(define surface-lower 30)
2009-06-08 15:54:51 +00:00
(define (vec3->vec4 v a)
(vector (vx v) (vy v) (vz v) a))
2009-06-08 15:54:51 +00:00
2009-06-15 11:19:54 +00:00
(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)))
2009-06-08 15:25:32 +00:00
(define (root-colour) (vector 0.6 0.5 0.5))
(define (pickup-colour) (hsv->rgb (vector 0.1 (rndf) 1)))
2009-06-10 11:45:37 +00:00
(define (absorb-colour) (vec3->vec4 (hsv->rgb (vector (rndf) 0.2 (+ 0.6 (rndf)))) 0.2))
2009-06-08 15:25:32 +00:00
(define (type->colour type)
(cond
((string=? type "knobbly") (vector 1 0.6 0.6))
2009-06-15 11:19:54 +00:00
((string=? type "lollypop") (vector 0.6 0.6 1))
((string=? type "nik") (vector 0.6 1 0.6))
(else (vector 1 1 1))))
2009-06-08 15:54:51 +00:00
;(define texpath "")
2009-06-08 15:25:32 +00:00
(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))))))
2009-06-08 15:25:32 +00:00
(define (choose l)
(list-ref l (random (length l))))
2009-06-08 15:25:32 +00:00
; 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
;
2009-06-15 11:19:54 +00:00
; 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
2009-06-15 11:19:54 +00:00
; / | \
; plant | plant-view
;
;
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; logic
; messages passed between the honey-comb logic and the view
2009-06-15 11:19:54 +00:00
(define-struct init-update (surface-pos-list))
(define-struct cell-update (pos code pickup upstream type))
2009-06-08 15:25:32 +00:00
(define-struct insect-update (id pos dir t))
(define-struct absorb-event (cell-pos type))
(define-struct plant-update (id desc pos type))
2009-06-15 11:19:54 +00:00
(define-struct controller-update (grow-pos))
2009-06-08 15:25:32 +00:00
(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
2009-06-08 15:25:32 +00:00
((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))
2009-06-08 15:25:32 +00:00
(set! upstream (get-neighbour (car l)))
#;(search/attach-to-neighbour (cdr l) (cons (car l) dirs))
(car l))
2009-06-08 15:25:32 +00:00
(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))
2009-06-08 15:25:32 +00:00
(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
2009-06-08 15:25:32 +00:00
(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))
2009-06-10 11:45:37 +00:00
(set! next-update (+ time d))
2009-06-08 15:25:32 +00:00
(set! cell (cadr m))
2009-06-10 11:45:37 +00:00
(make-insect-update id (send cell get-pos) (car m) d)))
2009-06-08 15:25:32 +00:00
(else #f)))
(super-new)))
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
(define plant%
(class object%
(init-field
(id "none")
(type "none")
(pos '())) ; the seed position
(field
(update-me #t)
2009-06-10 11:45:37 +00:00
(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)
2009-06-10 11:45:37 +00:00
(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)
2009-06-08 15:25:32 +00:00
(height 0)
(insects '())
2009-06-15 11:19:54 +00:00
(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%))))
2009-06-08 15:25:32 +00:00
; 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)))
2009-06-08 15:25:32 +00:00
(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)))
2009-06-15 11:19:54 +00:00
(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)
2009-06-15 11:19:54 +00:00
(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)))
2009-06-08 15:25:32 +00:00
(define/public (update time delta)
2009-06-08 15:25:32 +00:00
(append
2009-06-15 11:19:54 +00:00
; 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)
2009-06-08 15:25:32 +00:00
(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)
2009-06-08 15:25:32 +00:00
(send cell get-pickup)
(if upstream (send upstream get-pos) #f)
(if plant (send plant get-type) #f)) r))
r))
'()
2009-06-10 11:45:37 +00:00
cells)
; get updates from the garden
(send garden update)))
(super-new)))
;======================================================================
; graphics and interaction
2009-06-08 15:25:32 +00:00
; more odds and sods...
(define (direction-normal d)
(let ((a (* 2 1.141 60)))
2009-06-10 11:45:37 +00:00
(vmul (vector (sin (* a d)) (cos (* a d)) 0) -1)))
2009-06-08 15:25:32 +00:00
(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))
2009-06-15 11:19:54 +00:00
(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)))
2009-06-08 15:25:32 +00:00
; 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))
2009-06-10 11:45:37 +00:00
;(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)
2009-06-15 11:19:54 +00:00
(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
2009-06-10 11:45:37 +00:00
(lambda (child connection)
2009-06-15 11:19:54 +00:00
(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))))
2009-06-10 11:45:37 +00:00
children
connection-list))))
2009-06-15 11:19:54 +00:00
(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)))
2009-06-08 15:25:32 +00:00
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
(define cell-view%
(class object%
(field
(root 0)
2009-06-10 11:45:37 +00:00
(tile1 0)
(tile2 0)
2009-06-15 11:19:54 +00:00
(bgtile 0)
2009-06-08 15:25:32 +00:00
(pickup-root 0)
(t 0)
(pos '(0 0))
2009-06-08 15:25:32 +00:00
(owner 0)
(type #f) ; the plant type of the owner of the roots, if any
2009-06-08 15:25:32 +00:00
(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)
2009-06-10 11:45:37 +00:00
(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))
2009-06-10 11:45:37 +00:00
(define (build-prim code)
2009-06-15 11:19:54 +00:00
(let ((p (build-hex 0 0 root)))
(with-primitive p
2009-06-15 11:19:54 +00:00
(hint-depth-sort)
(colour (root-colour))
(opacity 0)
(update-texture code))
p))
(define/public (build code)
2009-06-10 11:45:37 +00:00
(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)))
2009-06-15 11:19:54 +00:00
(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"))))
2009-06-10 11:45:37 +00:00
(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)
2009-06-10 11:45:37 +00:00
(when (not (zero? tile2))
(destroy tile2)
(with-primitive tile1 (opacity 1)))
(set! tile2 (build-prim code))
(set! t 0))
2009-06-08 15:25:32 +00:00
(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))
2009-06-10 11:45:37 +00:00
(parent root)
2009-06-08 15:25:32 +00:00
(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)
2009-06-10 11:45:37 +00:00
(with-primitive tile1
(opacity (- 1 t)))
2009-06-10 11:45:37 +00:00
(with-primitive tile2
(opacity t)))
2009-06-08 15:25:32 +00:00
(when (> t 1)
2009-06-10 11:45:37 +00:00
(with-primitive tile1
(opacity 1))
2009-06-10 11:45:37 +00:00
(when (not (zero? tile2))
(destroy tile1)
(set! tile1 tile2)
(set! tile2 0))))
(super-new)))
2009-06-08 15:25:32 +00:00
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
(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)
2009-06-10 11:45:37 +00:00
(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))
2009-06-08 15:25:32 +00:00
(define/override (build)
2009-06-10 11:45:37 +00:00
(set! root (build-ribbon 20))
2009-06-08 15:25:32 +00:00
(with-primitive root
(hide 1)
(translate (vector 0 0 -0.1))
(hint-unlit)
(set! hidden #t)
(colour (worm-colour))
2009-06-08 15:54:51 +00:00
(texture (load-texture (string-append texpath "worm.png")))
2009-06-10 11:45:37 +00:00
(let ((width (+ 0.05 (* 0.05 (rndf)))))
(pdata-index-map!
(lambda (i w)
width #;(+ 0.05 (* (abs (sin (* i 0.5))) 0.1)))
"w"))
2009-06-08 15:25:32 +00:00
#;(pdata-map!
(lambda (c)
(vector 1 1 1))
"c")))
(define/override (update time delta)
2009-06-10 11:45:37 +00:00
(cond ((or (zero? d) (> t d) (equal? from2 (vector 0 0 0)))
2009-06-08 15:25:32 +00:00
(set! hidden #t)
(with-primitive root (hide 1)))
(else
2009-06-10 11:45:37 +00:00
(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)))
2009-06-08 15:25:32 +00:00
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
(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
2009-06-08 15:54:51 +00:00
(texture (load-texture (string-append texpath "particle.png")))
2009-06-08 15:25:32 +00:00
(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))
2009-06-08 15:25:32 +00:00
(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)
2009-06-08 15:54:51 +00:00
(let ((s (* 0.2 (+ 0.1 (rndf)))))
(vector s s 1)))
2009-06-08 15:25:32 +00:00
"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))
2009-06-10 11:45:37 +00:00
(set! root (build-locator))
; build the plant
2009-06-10 11:45:37 +00:00
(with-state
(parent root)
(hint-depth-sort)
2009-06-15 11:19:54 +00:00
(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)
2009-06-10 11:45:37 +00:00
(let ((plant (make-object plant-view%)))
(with-state
(parent (send hex get-root))
(send plant build desc type)
2009-06-10 11:45:37 +00:00
(set! plants (cons (list id plant) plants)))))
(super-new)))
2009-06-08 15:25:32 +00:00
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
(define honey-comb-view%
(class object%
(field
(root 0)
2009-06-08 15:25:32 +00:00
(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
2009-06-10 11:45:37 +00:00
(garden (make-object garden-view%)))
(define/public (init)
2009-06-08 15:25:32 +00:00
(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))
2009-06-15 11:19:54 +00:00
insects)))
2009-06-15 11:19:54 +00:00
(define (get-pos-from-prim-impl p l)
(cond
((null? l) #f)
2009-06-10 11:45:37 +00:00
((eq? (send (cadr (car l)) get-tile) p) (caar l))
2009-06-15 11:19:54 +00:00
(else (get-pos-from-prim-impl p (cdr l)))))
2009-06-15 11:19:54 +00:00
(define/public (get-pos-from-prim p)
(get-pos-from-prim-impl p cells))
2009-06-08 15:25:32 +00:00
(define/public (get-cell-from-pos pos)
(cadr (assoc pos cells)))
2009-06-15 11:19:54 +00:00
2009-06-08 15:25:32 +00:00
(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")
2009-06-15 11:19:54 +00:00
(texture (load-texture (string-append texpath "surface3.png"))))
2009-06-15 11:19:54 +00:00
(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))))))))
2009-06-08 15:25:32 +00:00
(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)
2009-06-08 15:25:32 +00:00
(send (cadr cell) update time delta))
cells)
2009-06-08 15:25:32 +00:00
(for-each
(lambda (insect)
(send (cadr insect) update time delta))
insects)
; read the update list, and dispatch based on type
(for-each
(lambda (item)
2009-06-08 15:25:32 +00:00
(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)))
2009-06-08 15:25:32 +00:00
(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))
2009-06-08 15:25:32 +00:00
(send cell build code)
(set! cells (cons (list pos cell) cells)))))))
2009-06-15 11:19:54 +00:00
2009-06-08 15:25:32 +00:00
((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)))))
2009-06-15 11:19:54 +00:00
2009-06-08 15:25:32 +00:00
((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)))
2009-06-15 11:19:54 +00:00
((plant-update? item)
2009-06-10 11:45:37 +00:00
(send garden add-plant!
(plant-update-id item)
(plant-update-desc item)
(get-cell-from-pos (plant-update-pos item))
2009-06-15 11:19:54 +00:00
(plant-update-type item)))
((init-update? item)
(build-surface (init-update-surface-pos-list item)))))
update-list))
(super-new)))
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2009-06-15 11:19:54 +00:00
(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)))
2009-06-15 11:19:54 +00:00
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
(clear)
2009-06-08 15:25:32 +00:00
(clear-colour (bg-colour))
(define hc (make-object honey-comb%))
(define hcv (make-object honey-comb-view%))
(define g (make-object garden%))
2009-06-15 11:19:54 +00:00
(define con (make-object controller%))
2009-06-15 11:19:54 +00:00
(send hc init hex-width hex-height)
(send hcv init)
2009-06-15 11:19:54 +00:00
(send hc seed "dave@fo.am" "knobbly" 45)
(send hc seed "plant00002@fo.am" "lollypop" 30)
(send hc seed "plant00003@fo.am" "nik" 15)
2009-06-15 11:19:54 +00:00
(with-state
(colour (sky-colour))
(hint-unlit)
(translate (vector 0 (- surface-upper 0.6) 0))
(scale (vector 100 10 1))
(build-plane))
2009-06-08 15:25:32 +00:00
(define t 0)
(define d 0.04)
(define (animate)
2009-06-15 11:19:54 +00:00
; (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))