added pluggables code, refactored the structure and first pass garden + plants
This commit is contained in:
Dave Griffiths
parent
66dbdd9277
commit
b1789e048b
1 changed files with 355 additions and 20 deletions
|
|
@ -1,6 +1,8 @@
|
|||
;#lang scheme
|
||||
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||||
; hex ornament/groworld game : fluxus version
|
||||
|
||||
;(require fluxus-016/drflux.ss)
|
||||
(require scheme/class)
|
||||
|
||||
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||||
|
|
@ -10,9 +12,9 @@
|
|||
(define pickup-drop-probability 10)
|
||||
|
||||
(define (vec3->vec4 v a)
|
||||
(vector (vx v) (vy v) (vz v) a))
|
||||
(vector (vx v) (vy v) (vz v) a))
|
||||
|
||||
(define (bg-colour) (vector 0.5 0.2 0.1))
|
||||
(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)))
|
||||
|
|
@ -84,17 +86,59 @@
|
|||
((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 logic and the view
|
||||
; 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)
|
||||
|
|
@ -103,6 +147,12 @@
|
|||
(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)
|
||||
|
|
@ -168,6 +218,7 @@
|
|||
((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))
|
||||
|
|
@ -221,6 +272,60 @@
|
|||
|
||||
(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%
|
||||
|
|
@ -229,7 +334,8 @@
|
|||
(cells '())
|
||||
(width 0)
|
||||
(height 0)
|
||||
(insects '()))
|
||||
(insects '())
|
||||
(garden (make-object garden%)))
|
||||
|
||||
(define/public (get-cell x y)
|
||||
(list-ref cells (+ (* y height) x)))
|
||||
|
|
@ -267,16 +373,23 @@
|
|||
(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))))))))
|
||||
(send cell set-neighbour! SW (get-cell (if (odd? y) x (- x 1)) (+ y 1))))))))
|
||||
|
||||
(define/public (seed x y)
|
||||
|
||||
(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 1)) set-connection! NW #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 (get-update-list time delta)
|
||||
(define/public (update time delta)
|
||||
|
||||
(append
|
||||
|
||||
; get updates from the garden
|
||||
(send garden update)
|
||||
|
||||
; look for pickups over roots
|
||||
(foldl
|
||||
(lambda (cell r)
|
||||
|
|
@ -308,7 +421,7 @@
|
|||
|
||||
(super-new)))
|
||||
|
||||
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||||
;======================================================================
|
||||
; graphics and interaction
|
||||
|
||||
; more odds and sods...
|
||||
|
|
@ -394,6 +507,145 @@
|
|||
(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%
|
||||
|
|
@ -566,10 +818,10 @@
|
|||
(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-index-map!
|
||||
(lambda (i w)
|
||||
width #;(+ 0.05 (* (abs (sin (* i 0.5))) 0.1)))
|
||||
"w"))
|
||||
#;(pdata-map!
|
||||
(lambda (c)
|
||||
(vector 1 1 1))
|
||||
|
|
@ -628,7 +880,7 @@
|
|||
(let ((pos (with-primitive (send cell get-root)
|
||||
(vtransform (vector 0 0 0) (get-transform)))))
|
||||
(with-primitive root
|
||||
(translate (vector 0 0 0.2))
|
||||
(translate (vector 0 0 0.2))
|
||||
(hint-depth-sort)
|
||||
(pdata-map!
|
||||
(lambda (p)
|
||||
|
|
@ -668,6 +920,37 @@
|
|||
|
||||
(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)))
|
||||
|
||||
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||||
|
||||
|
|
@ -677,7 +960,8 @@
|
|||
(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
|
||||
(absorb-list '()) ; just a list of absorb effects
|
||||
(garden-view (make-object garden-view%)))
|
||||
|
||||
(define/public (init)
|
||||
(set! root (build-locator))
|
||||
|
|
@ -689,7 +973,8 @@
|
|||
(for-each
|
||||
(lambda (insect)
|
||||
(send (cadr insect) build))
|
||||
insects)))
|
||||
insects))
|
||||
(build-surface))
|
||||
|
||||
(define (get-pos-from-prim p l)
|
||||
(cond
|
||||
|
|
@ -708,6 +993,52 @@
|
|||
(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
|
||||
|
|
@ -761,13 +1092,16 @@
|
|||
(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)))))
|
||||
(add-absorb! a)))
|
||||
((plant-update? item)
|
||||
(printf "got a plant update!~n"))))
|
||||
update-list))
|
||||
|
||||
(super-new)))
|
||||
|
||||
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||||
|
||||
|
||||
(clear)
|
||||
(clear-colour (bg-colour))
|
||||
(clear-texture-cache)
|
||||
|
|
@ -776,6 +1110,7 @@
|
|||
|
||||
(define hc (make-object honey-comb%))
|
||||
(define hcv (make-object honey-comb-view%))
|
||||
(define g (make-object garden%))
|
||||
|
||||
(send hc init 20 20)
|
||||
|
||||
|
|
@ -784,7 +1119,7 @@
|
|||
; (translate (vector -10 -8.5 0))
|
||||
(send hcv init))
|
||||
|
||||
(send hc seed 10 10)
|
||||
(send hc seed "dave@fo.am" 10 10)
|
||||
;(send (send hc get-cell 50 52) grow)
|
||||
;(send (send hc get-cell 49 53) grow)
|
||||
|
||||
|
|
@ -792,11 +1127,11 @@
|
|||
(define d 0.04)
|
||||
|
||||
(define (animate)
|
||||
; (set! d (delta))
|
||||
; (set! d (delta))
|
||||
(set! t (+ t d))
|
||||
(let ((clicked (send hcv deal-with-input)))
|
||||
(when clicked
|
||||
(send (send hc get-cell (car clicked) (cadr clicked)) grow)))
|
||||
(send hcv update (send hc get-update-list t d) t d))
|
||||
(send hcv update (send hc update t d) t d))
|
||||
|
||||
(every-frame (animate))
|
||||
|
|
|
|||
Loading…
Reference in a new issue