diff --git a/hex-ornament/hex-ornament.scm b/hex-ornament/hex-ornament.scm index c5951c1..1fb4622 100644 --- a/hex-ornament/hex-ornament.scm +++ b/hex-ornament/hex-ornament.scm @@ -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))