390 lines
12 KiB
Scheme
390 lines
12 KiB
Scheme
|
(require scheme/class)
|
||
|
|
|
||
|
|
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||
|
|
; 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))))))
|
||
|
|
|
||
|
|
; 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)))
|
||
|
|
|
||
|
|
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||
|
|
; logic
|
||
|
|
|
||
|
|
(define comb-cell%
|
||
|
|
(class object%
|
||
|
|
(field
|
||
|
|
(neighbours '(#f #f #f #f #f #f))
|
||
|
|
(contents '())
|
||
|
|
(connections '(#f #f #f #f #f #f))
|
||
|
|
(visible #f)
|
||
|
|
(update-me #f))
|
||
|
|
|
||
|
|
(define/public (update-me?)
|
||
|
|
(let ((r update-me))
|
||
|
|
(set! update-me #f)
|
||
|
|
r))
|
||
|
|
|
||
|
|
(define/public (set-visible! s)
|
||
|
|
(set! update-me #t)
|
||
|
|
(set! visible s))
|
||
|
|
|
||
|
|
(define/public (visible?)
|
||
|
|
visible)
|
||
|
|
|
||
|
|
(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-contents)
|
||
|
|
contents)
|
||
|
|
|
||
|
|
(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)
|
||
|
|
(cond
|
||
|
|
((null? l) #f)
|
||
|
|
((not (send (get-neighbour (car l)) no-connections?))
|
||
|
|
(send (get-neighbour (car l)) set-connection! (rdirection (car l)) #t)
|
||
|
|
(car l))
|
||
|
|
(else (search/attach-to-neighbour (cdr l)))))
|
||
|
|
|
||
|
|
(define/public (grow)
|
||
|
|
; only possible to grow when we are a clear cell
|
||
|
|
(when (equal? connections (list #f #f #f #f #f #f))
|
||
|
|
(let ((dir (search/attach-to-neighbour (shuffle directions))))
|
||
|
|
(when dir
|
||
|
|
; it's dir is false if we have nothing around us to
|
||
|
|
; connect to, probably shouldn't happen, haven't decided yet
|
||
|
|
(set-connection! dir #t)))))
|
||
|
|
|
||
|
|
(super-new)))
|
||
|
|
|
||
|
|
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||
|
|
|
||
|
|
(define honey-comb%
|
||
|
|
(class object%
|
||
|
|
(field
|
||
|
|
(cells '())
|
||
|
|
(width 0)
|
||
|
|
(height 0))
|
||
|
|
|
||
|
|
(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%))))
|
||
|
|
|
||
|
|
; 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)))
|
||
|
|
(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 x y)
|
||
|
|
|
||
|
|
(send (get-cell x y) set-connection! SE #t)
|
||
|
|
(send (get-cell x (+ y 1)) set-connection! NW #t)
|
||
|
|
|
||
|
|
#;(let ((seed (get-cell x y)))
|
||
|
|
; set all directions to be connected
|
||
|
|
(for-each
|
||
|
|
(lambda (d)
|
||
|
|
(send seed set-connection! d #t))
|
||
|
|
directions)
|
||
|
|
|
||
|
|
(for-each
|
||
|
|
(lambda (n d)
|
||
|
|
(send n set-connection! (rdirection d) #t))
|
||
|
|
(send seed get-neighbours)
|
||
|
|
directions)))
|
||
|
|
|
||
|
|
(define/public (get-update-list)
|
||
|
|
(let ((i -1))
|
||
|
|
(foldl
|
||
|
|
(lambda (cell r)
|
||
|
|
(set! i (+ i 1))
|
||
|
|
(if (send cell update-me?)
|
||
|
|
(cons (list
|
||
|
|
(list (modulo i width) (quotient i height))
|
||
|
|
(send cell get-connection-num)) r)
|
||
|
|
r))
|
||
|
|
'()
|
||
|
|
cells)))
|
||
|
|
|
||
|
|
(super-new)))
|
||
|
|
|
||
|
|
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||
|
|
; graphics and interaction
|
||
|
|
|
||
|
|
(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 cell-view%
|
||
|
|
(class object%
|
||
|
|
(field
|
||
|
|
(root 0)
|
||
|
|
(root2 0)
|
||
|
|
(t 0)
|
||
|
|
(pos '(0 0))
|
||
|
|
(owner 0))
|
||
|
|
|
||
|
|
(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 (vector 0.9 1 0.5))
|
||
|
|
(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 "textures/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 (update)
|
||
|
|
(set! t (+ t 0.04))
|
||
|
|
|
||
|
|
(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 honey-comb-view%
|
||
|
|
(class object%
|
||
|
|
(field
|
||
|
|
(root 0)
|
||
|
|
(cells '())) ; an associative array mapping position to cell-view obs
|
||
|
|
|
||
|
|
(define/public (init)
|
||
|
|
(set! root (build-locator)))
|
||
|
|
|
||
|
|
(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 (deal-with-input)
|
||
|
|
(if (mouse-button 1)
|
||
|
|
(get-pos-from-prim (mouse-over) cells)
|
||
|
|
#f))
|
||
|
|
|
||
|
|
(define/public (update update-list)
|
||
|
|
(for-each
|
||
|
|
(lambda (cell)
|
||
|
|
(send (cadr cell) update))
|
||
|
|
cells)
|
||
|
|
(for-each
|
||
|
|
(lambda (item)
|
||
|
|
(let*
|
||
|
|
((pos (car item))
|
||
|
|
(code (cadr item))
|
||
|
|
(s (assoc pos cells)))
|
||
|
|
(cond
|
||
|
|
(s (send (cadr s) new-code code))
|
||
|
|
(else
|
||
|
|
(let ((cell (make-object cell-view%)))
|
||
|
|
(send cell set-pos! pos)
|
||
|
|
(send cell set-owner! root)
|
||
|
|
(send cell build code)
|
||
|
|
(set! cells (cons (list pos cell) cells)))))))
|
||
|
|
update-list))
|
||
|
|
|
||
|
|
(super-new)))
|
||
|
|
|
||
|
|
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||
|
|
|
||
|
|
(clear)
|
||
|
|
(clear-colour (vector 0.5 0.2 0.1))
|
||
|
|
(clear-texture-cache)
|
||
|
|
(show-axis 0)
|
||
|
|
(set-camera-transform (mtranslate (vector 0 0 -8)))
|
||
|
|
|
||
|
|
(define hc (make-object honey-comb%))
|
||
|
|
(define hcv (make-object honey-comb-view%))
|
||
|
|
|
||
|
|
(send hc init 100 100)
|
||
|
|
|
||
|
|
(with-state
|
||
|
|
(translate (vector -50 -42.5 0))
|
||
|
|
(send hcv init))
|
||
|
|
|
||
|
|
(send hc seed 50 50)
|
||
|
|
;(send (send hc get-cell 50 52) grow)
|
||
|
|
;(send (send hc get-cell 49 53) grow)
|
||
|
|
|
||
|
|
(define (animate)
|
||
|
|
(let ((clicked (send hcv deal-with-input)))
|
||
|
|
(when clicked
|
||
|
|
(send (send hc get-cell (car clicked) (cadr clicked)) grow)))
|
||
|
|
(send hcv update (send hc get-update-list)))
|
||
|
|
|
||
|
|
(every-frame (animate))
|