diff --git a/hex-ornament/hex-ornament-win32.zip b/hex-ornament/hex-ornament-win32.zip deleted file mode 100755 index e7fb84a..0000000 Binary files a/hex-ornament/hex-ornament-win32.zip and /dev/null differ diff --git a/hex-ornament/hex-ornament.scm b/hex-ornament/hex-ornament.scm index 7e67f58..9e97ad0 100644 --- a/hex-ornament/hex-ornament.scm +++ b/hex-ornament/hex-ornament.scm @@ -1,5 +1,22 @@ +;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +; hex groworld game : fluxus version + (require scheme/class) +;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +; tweakables + +(define num-insects 20) +(define pickup-drop-probability 10) + +(define (bg-colour) (vector 0.5 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))) +(define (absorb-colour) (hsv->rgb (vector 0.1 (rndf) 1))) + +(define texpath "textures/") + ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ; odds and sods @@ -23,6 +40,9 @@ (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) @@ -63,20 +83,30 @@ ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ; logic +; messages passed between the 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 comb-cell% (class object% (field + (pos '()) (neighbours '(#f #f #f #f #f #f)) - (contents '()) + (pickup #f) (connections '(#f #f #f #f #f #f)) (visible #f) - (update-me #f)) + (update-me #f) + (upstream #f)) ; the cell we are connected to (if we are) (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)) @@ -84,6 +114,12 @@ (define/public (visible?) visible) + (define/public (get-pos) + pos) + + (define/public (set-pos! s) + (set! pos s)) + (define/public (get-neighbours) neighbours) @@ -93,8 +129,12 @@ (define/public (set-neighbour! d n) (set! neighbours (insert neighbours d n 0))) - (define/public (get-contents) - contents) + (define/public (get-pickup) + pickup) + + (define/public (set-pickup! s) + (when visible (set! update-me #t)) + (set! pickup s)) (define/public (get-connections) connections) @@ -119,22 +159,61 @@ (bool-list->num connections 0 0)) ; returns the first attachable neighbour found, and sets it's connection - (define (search/attach-to-neighbour l) + (define (search/attach-to-neighbour l dirs) (cond - ((null? l) #f) + ((null? l) dirs) ((not (send (get-neighbour (car l)) no-connections?)) (send (get-neighbour (car l)) set-connection! (rdirection (car l)) #t) + (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))))) + (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 - ; 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))))) + (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) + (t (+ 0.5 (rndf)))) + + (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 t)) + (set! cell (cadr m)) + (make-insect-update id (send cell get-pos) (car m) t))) + (else #f))) (super-new))) @@ -145,7 +224,8 @@ (field (cells '()) (width 0) - (height 0)) + (height 0) + (insects '())) (define/public (get-cell x y) (list-ref cells (+ (* y height) x))) @@ -157,6 +237,9 @@ ; 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 @@ -167,6 +250,7 @@ (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)) @@ -182,32 +266,38 @@ (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))) + (send (get-cell x (+ y 1)) set-connection! NW #t)) - (define/public (get-update-list) - (let ((i -1)) + (define/public (get-update-list time delta) + + (append + + ; 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) - (set! i (+ i 1)) (if (send cell update-me?) - (cons (list - (list (modulo i width) (quotient i height)) - (send cell get-connection-num)) r) + (let ((upstream (send cell get-upstream))) + (cons (make-cell-update (send cell get-pos) + (send cell get-connection-num) + (send cell get-pickup) + (if upstream (send upstream get-pos) #f)) r)) r)) '() cells))) @@ -217,6 +307,13 @@ ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ; graphics and interaction +; more odds and sods... + +(define (direction-normal d) + (let ((a (* 2 1.141 60))) + (vector (sin (* a d)) (cos (* a d)) 0))) + + (define (build-ngon n) (let ((p (build-polygons n 'polygon))) (with-primitive p @@ -236,14 +333,81 @@ (pdata-map! (lambda (n) (vector 0 0 1)) "n")) p)) +(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)) + +; 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)))) + +;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + (define cell-view% (class object% (field (root 0) (root2 0) + (pickup-root 0) (t 0) (pos '(0 0)) - (owner 0)) + (owner 0) + (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)) @@ -263,7 +427,7 @@ (parent owner) (hint-depth-sort) (opacity 0) - (colour (vector 0.9 1 0.5)) + (colour (root-colour)) (hint-unlit) (when (odd? (cadr pos)) (translate (vector 0.5 0 0))) @@ -280,7 +444,7 @@ (set! root2 (build-prim code))) (define (update-texture code) - (texture (load-texture "textures/roots-ornate.png")) + (texture (load-texture (append texpath "roots-ornate.png"))) (pdata-map! (lambda (t tref) (let ((size (/ 1 8))) @@ -295,15 +459,33 @@ (set! root2 (build-prim code)) (set! t 0)) - (define/public (update) - (set! t (+ t 0.04)) - + (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 owner) + (translate (with-primitive root (vtransform (vector 0 0 0) (get-transform)))) + (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 root (opacity (- 1 t))) (with-primitive root2 (opacity t))) - + (when (> t 1) (with-primitive root (opacity 1)) @@ -316,14 +498,193 @@ (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)) + + (define/override (build) + (set! root (build-ribbon 50)) + (with-primitive root + (hide 1) + (translate (vector 0 0 -0.1)) + (hint-unlit) + (set! hidden #t) + (colour (worm-colour)) + (texture (load-texture (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-map! + (lambda (c) + (vector 1 1 1)) + "c"))) + + (define/override (update time delta) + (cond ((or (zero? d) (> t d) (equal? from (vector 0 0 0))) + (set! hidden #t) + (with-primitive root (hide 1))) + (else + (with-primitive root + (when hidden + (set! hidden #f) + (pdata-map! + (lambda (p) + from) + "p")) + (hide 0) + ;(identity) + (let ((h (hermite-tangent (/ t d) from to (vmul from-dir 2) (vmul to-dir 2)))) + ;(translate (car h)) + (pdata-set! "p" (- (pdata-size) 1) (car h)) + + + (for ((i (in-range 0 (- (pdata-size) 1)))) + (pdata-set! "p" i (pdata-ref "p" (+ i 1)))))))) + (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 (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 + (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.75 (+ 1 (rndf))))) + (vector s s 1 0.3))) + "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 honey-comb-view% (class object% (field (root 0) - (cells '())) ; an associative array mapping position to cell-view obs + (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 (define/public (init) - (set! root (build-locator))) + (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 p l) (cond @@ -331,30 +692,71 @@ ((eq? (send (cadr (car l)) get-root) p) (caar l)) (else (get-pos-from-prim p (cdr l))))) + (define/public (get-cell-from-pos pos) + (cadr (assoc pos cells))) + (define/public (deal-with-input) (if (mouse-button 1) (get-pos-from-prim (mouse-over) cells) #f)) - (define/public (update update-list) + (define/public (add-absorb! s) + (set! absorb-list (cons s absorb-list))) + + (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)) + (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) - (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))))))) + (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))) + (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))))))) + ((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))))) update-list)) (super-new))) @@ -362,28 +764,34 @@ ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ (clear) -(clear-colour (vector 0.5 0.2 0.1)) +(clear-colour (bg-colour)) (clear-texture-cache) (show-axis 0) -(set-camera-transform (mtranslate (vector 0 0 -8))) +(set-camera-transform (mtranslate (vector -10 -6 -8))) (define hc (make-object honey-comb%)) (define hcv (make-object honey-comb-view%)) -(send hc init 100 100) +(send hc init 20 20) (with-state - (translate (vector -50 -42.5 0)) + ; (translate (vector -50 -42.5 0)) + ; (translate (vector -10 -8.5 0)) (send hcv init)) -(send hc seed 50 50) +(send hc seed 10 10) ;(send (send hc get-cell 50 52) grow) ;(send (send hc get-cell 49 53) grow) +(define t 0) +(define d 0.04) + (define (animate) +; (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))) + (send hcv update (send hc get-update-list t d) t d)) (every-frame (animate))