diff --git a/danceplant/gro.scm b/danceplant/gro.scm index e5922ca..4b0db4d 100644 --- a/danceplant/gro.scm +++ b/danceplant/gro.scm @@ -303,7 +303,7 @@ (clear) (clear-colour (vector 0 0.3 0.2)) (set-camera-transform (mmul (mtranslate (vector 0 -5 -10)) - (mrotate (vector 90 90 180)))) + (mrotate (vector 90 -90 180)))) (with-state (hint-unlit) diff --git a/danceplant/gro2.scm b/danceplant/gro2.scm index 86fbc88..d862ac5 100644 --- a/danceplant/gro2.scm +++ b/danceplant/gro2.scm @@ -305,7 +305,7 @@ (clear) ;(clear-colour (vector 0 0.5 0.4)) (set-camera-transform (mmul (mtranslate (vector 0 -5 -10)) - (mrotate (vector 90 90 180)))) + (mrotate (vector 90 -90 180)))) #;(with-state (hint-unlit) diff --git a/flatgarden/flatgarden.scm b/flatgarden/flatgarden.scm index 040cb4b..5e53430 100644 --- a/flatgarden/flatgarden.scm +++ b/flatgarden/flatgarden.scm @@ -107,14 +107,17 @@ (string->list string)) obj-list)) +(define t 0) + (define (animate obj-list) + (set! t (+ t 0.05)) (let ((c 0)) (for-each (lambda (objs) (for-each (lambda (obj) (with-primitive obj - (rotate (vector 0 0 (* 0.1 (sin (+ c (time))))))) + (rotate (vector 0 0 (* 0.05 (sin (+ (* c 0.2) (* 4 t))))))) (set! c (+ c 20))) objs)) obj-list))) @@ -132,12 +135,12 @@ (colour 1) -(for ((i (in-range 0 5))) +(for ((i (in-range 0 10))) (let ((t2 (with-state (translate (vector 0 (* 20 (crndf)) (rndf))) (build-locator)))) (set! trees (cons (ls-build t2 (ls-generate 3 "F" '(("F" "G-[-F+G+FB]+F[+F-G-FL]-F"))) (+ 10 (random 20)) 0.9) trees)))) - +(start-framedump "wind" "jpg") (every-frame (animate trees)) diff --git a/hayfever/hayfever2.scm b/hayfever/hayfever2.scm index 00eacff..db610ff 100644 --- a/hayfever/hayfever2.scm +++ b/hayfever/hayfever2.scm @@ -17,7 +17,7 @@ (define pollen-particles 300) (define max-pollen-radius 12) (define suck-pollen-radius 8) -(define deterministic #f) +(define deterministic #t) (define minimal-mode #f) (define jid "plant0000003@fo.am") (define pass "plant0000003") @@ -241,15 +241,21 @@ (when deterministic (flxseed 3) - (random-seed 11) ; 2 5 + (random-seed 1) ; 2 5 ) - (let* ((pos (vector (* (crndf) 5) 0 0.1)) + (let* ((pos (vector -4 #;(* (crndf) 5) 0 0.1)) (col (hsv->rgb (vector (rndf) 0.8 1))) (desc (list (make-random-plant 0)))) (set! my-id jid) - (set-entity my-id (make-object plant% pos col desc)))) + (set-entity my-id (make-object plant% pos col desc))) + + + (let* ((pos (vector 4 #;(* (crndf) 5) 0 0.1)) + (col (hsv->rgb (vector (rndf) 0.8 1))) + (desc (list (make-random-plant 0)))) + (set-entity "other" (make-object plant% pos col desc)))) (define/public (get-entity id) (foldl diff --git a/hex-ornament/hex-debug.scm b/hex-ornament/hex-debug.scm new file mode 100644 index 0000000..3497d17 --- /dev/null +++ b/hex-ornament/hex-debug.scm @@ -0,0 +1,31 @@ +(define (direction-normal d) + (let ((a (* 60 0.017453292))) + (vector (sin (* a d)) (cos (* a d)) 0))) + + +(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)) + +(clear) +(build-ngon 6) +(for ((i (in-range 0 6))) + (with-primitive (build-ribbon 2) + (hint-wire) + (pdata-set "p" 0 (vector 0 0 0)) + (pdata-set "p" 1 (vmul (direction-normal i) 2)))) \ No newline at end of file diff --git a/hex-ornament/hex-ornament-before-insects.scm b/hex-ornament/hex-ornament-before-insects.scm new file mode 100644 index 0000000..b8cb402 --- /dev/null +++ b/hex-ornament/hex-ornament-before-insects.scm @@ -0,0 +1,392 @@ +(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 dirs) + (cond + ((null? l) dirs) + ((not (send (get-neighbour (car l)) no-connections?)) + (send (get-neighbour (car l)) set-connection! (rdirection (car l)) #t) + #;(search/attach-to-neighbour (cdr l) (cons (car l) dirs)) + (car 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 + (set-connection! dir #t)) + #;(for-each + (lambda (d) + (set-connection! d #t)) + dir)))) + + (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)) diff --git a/hex-ornament/hex-ornament.scm b/hex-ornament/hex-ornament.scm new file mode 100644 index 0000000..06af8b8 --- /dev/null +++ b/hex-ornament/hex-ornament.scm @@ -0,0 +1,1178 @@ +;#lang scheme +;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +; hex ornament/groworld game : fluxus version + +;(require fluxus-016/drflux.ss) +(require scheme/class) + +;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +; tweakables + +(define num-insects 50) +(define pickup-drop-probability 10) + +(define (vec3->vec4 v a) + (vector (vx v) (vy v) (vz v) a)) + +(define (bg-colour) (vector 0.9 0.8 0.7)) +(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) (vec3->vec4 (hsv->rgb (vector (rndf) 0.2 (+ 0.6 (rndf)))) 0.2)) + +;(define texpath "") +(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)))))) + +(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) + (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 "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 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 pos)) + +(define comb-cell% + (class object% + (field + (id #f) ; id of 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-id) + id) + + (define/public (set-id! s) + (set! id 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))) + 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 + ((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)) + (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 + (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))))) + + (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 d)) + (set! cell (cadr m)) + (make-insect-update id (send cell get-pos) (car m) d))) + (else #f))) + + (super-new))) + +;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +(define plant% + (class object% + (init-field + (id "default") + (pos '())) ; the seed position + + (field + (update-me #t) + (desc (make-random-plant 0))) + + (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) + (send (cadr plant) get-pos)) r) + r)) + '() + plants)) + + (super-new))) + +;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +(define honey-comb% + (class object% + (field + (cells '()) + (width 0) + (height 0) + (insects '()) + (garden (make-object garden%))) + + (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%)))) + + ; 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))) + (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))) + (send cell set-neighbour! SW (get-cell (if (odd? y) x (- x 1)) (+ y 1)))))))) + + + (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) set-id! id) + (send (get-cell x (+ y 1)) set-connection! NW #t) + (send (get-cell x (+ y 1)) set-id! id)) + + (define/public (update 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) + (if (send cell update-me?) + (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) + + ; get updates from the garden + (send garden update))) + + (super-new))) + +;====================================================================== +; graphics and interaction + +; more odds and sods... + +(define (direction-normal d) + (let ((a (* 2 1.141 60))) + (vmul (vector (sin (* a d)) (cos (* a d)) 0) -1))) + + +(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 (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)))) + +;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +; 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)) + ;(printf "~a:~a~n" id (length connections)) + (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)))) + (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 + (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% + (class object% + (field + (root 0) + (tile1 0) + (tile2 0) + (pickup-root 0) + (t 0) + (pos '(0 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)) + + (define/public (get-root) + root) + + (define/public (get-tile) + tile1) + + (define/public (get-pos) + pos) + + (define/public (set-pos! s) + (set! pos s)) + + (define (build-prim code) + (let ((p (with-state + ;(hint-wire) + (parent root) + (hint-depth-sort) + (opacity 0) + (colour (root-colour)) + (hint-unlit) + (translate (vector 0 0 (* 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 (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))) + + (set! tile1 (build-prim code)) + (set! tile2 (build-prim code))) + + (define (update-texture code) + (texture (load-texture (string-append texpath "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? tile2)) + (destroy tile2) + (with-primitive tile1 (opacity 1))) + (set! tile2 (build-prim code)) + (set! t 0)) + + (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 root) + (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 tile1 + (opacity (- 1 t))) + (with-primitive tile2 + (opacity t))) + + (when (> t 1) + (with-primitive tile1 + (opacity 1)) + + (when (not (zero? tile2)) + (destroy tile1) + (set! tile1 tile2) + (set! tile2 0)))) + + (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) + (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)) + + (define/override (build) + (set! root (build-ribbon 20)) + (with-primitive root + (hide 1) + (translate (vector 0 0 -0.1)) + (hint-unlit) + (set! hidden #t) + (colour (worm-colour)) + (texture (load-texture (string-append texpath "worm.png"))) + (let ((width (+ 0.05 (* 0.05 (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? from2 (vector 0 0 0))) + (set! hidden #t) + (with-primitive root (hide 1))) + (else + (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))) + +;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +(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 (string-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 + (translate (vector 0 0 0.2)) + (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.2 (+ 0.1 (rndf))))) + (vector s s 1))) + "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) + (set! desc s) + + (when (not (zero? root)) + (destroy root)) + + (set! root (build-locator)) + + ; build the plant + (with-state + (parent root) + (hint-depth-sort) + (translate (vector 0.2 0.3 0.3)) + (build-component "1-1" (vector 1 1 1) (list desc)))) + + + (super-new))) + +;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +(define garden-view% + (class object% + (field + (plants '())) + + (define/public (add-plant! id desc hex) + (let ((plant (make-object plant-view%))) + (with-state + (parent (send hex get-root)) + (send plant build desc) + (set! plants (cons (list id plant) plants))))) + + (super-new))) + +;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +(define honey-comb-view% + (class object% + (field + (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 + (garden (make-object garden-view%))) + + (define/public (init) + (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)) + (build-surface)) + + (define (get-pos-from-prim p l) + (cond + ((null? l) #f) + ((eq? (send (cadr (car l)) get-tile) 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 (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 + (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 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) + (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))) + ((plant-update? item) + (send garden add-plant! + (plant-update-id item) + (plant-update-desc item) + (get-cell-from-pos (plant-update-pos item)))))) + update-list)) + + (super-new))) + +;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + +(clear) +(clear-colour (bg-colour)) +(clear-texture-cache) +(show-axis 0) +(set-camera-transform (mtranslate (vector -10 -7 -8))) + +(define hc (make-object honey-comb%)) +(define hcv (make-object honey-comb-view%)) +(define g (make-object garden%)) + +(send hc init 20 20) + +(with-state + ; (translate (vector -50 -42.5 0)) + ; (translate (vector -10 -8.5 0)) + (send hcv init)) + +(send hc seed "dave@fo.am" 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 update t d) t d)) + +(every-frame (animate)) diff --git a/hex-ornament/hex.scm b/hex-ornament/hex.scm new file mode 100644 index 0000000..e6b9f83 --- /dev/null +++ b/hex-ornament/hex.scm @@ -0,0 +1,39 @@ +(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) + (vsub (vmul p 0.5) (vector 0.5 0.5 0))) + "t" "p")) + p)) + +(define (binarify n) + (pdata-index-map! + (lambda (i p) + (let ((c (arithmetic-shift 1 (inexact->exact i)))) + (when (not (zero? (bitwise-and (inexact->exact n) c))) + (let ((pos (vtransform (vmul (vadd p (pdata-ref "p" (+ i 1))) 0.5) (get-transform)))) + (with-state + (hint-none) + (hint-wire) + (translate pos) + (scale 0.1) + (build-ngon 10)))) + p)) + "p")) + +(clear) + +(for ((i (in-range 0 64))) + (with-primitive (with-state + (translate (vmul (vector (modulo i 8) (quotient i 8) 0) 2)) + (hint-none) + (hint-wire) + (hint-unlit) + (build-ngon 6)) + (binarify i))) diff --git a/hex-ornament/textures/comp-0.png b/hex-ornament/textures/comp-0.png new file mode 100644 index 0000000..4884f2e Binary files /dev/null and b/hex-ornament/textures/comp-0.png differ diff --git a/hex-ornament/textures/comp-1-0.png b/hex-ornament/textures/comp-1-0.png new file mode 100644 index 0000000..e707cb3 Binary files /dev/null and b/hex-ornament/textures/comp-1-0.png differ diff --git a/hex-ornament/textures/comp-1-1.png b/hex-ornament/textures/comp-1-1.png new file mode 100644 index 0000000..427fbb7 Binary files /dev/null and b/hex-ornament/textures/comp-1-1.png differ diff --git a/hex-ornament/textures/comp-1.png b/hex-ornament/textures/comp-1.png new file mode 100644 index 0000000..5418075 Binary files /dev/null and b/hex-ornament/textures/comp-1.png differ diff --git a/hex-ornament/textures/comp-10.png b/hex-ornament/textures/comp-10.png new file mode 100644 index 0000000..e4c2be7 Binary files /dev/null and b/hex-ornament/textures/comp-10.png differ diff --git a/hex-ornament/textures/comp-11.png b/hex-ornament/textures/comp-11.png new file mode 100644 index 0000000..837a4f7 Binary files /dev/null and b/hex-ornament/textures/comp-11.png differ diff --git a/hex-ornament/textures/comp-2-0.png b/hex-ornament/textures/comp-2-0.png new file mode 100644 index 0000000..315d931 Binary files /dev/null and b/hex-ornament/textures/comp-2-0.png differ diff --git a/hex-ornament/textures/comp-2-1.png b/hex-ornament/textures/comp-2-1.png new file mode 100644 index 0000000..44a889e Binary files /dev/null and b/hex-ornament/textures/comp-2-1.png differ diff --git a/hex-ornament/textures/comp-2.png b/hex-ornament/textures/comp-2.png new file mode 100644 index 0000000..28d635c Binary files /dev/null and b/hex-ornament/textures/comp-2.png differ diff --git a/hex-ornament/textures/comp-3-0.png b/hex-ornament/textures/comp-3-0.png new file mode 100644 index 0000000..453b630 Binary files /dev/null and b/hex-ornament/textures/comp-3-0.png differ diff --git a/hex-ornament/textures/comp-3-1.png b/hex-ornament/textures/comp-3-1.png new file mode 100644 index 0000000..ca6b0dd Binary files /dev/null and b/hex-ornament/textures/comp-3-1.png differ diff --git a/hex-ornament/textures/comp-3-2.png b/hex-ornament/textures/comp-3-2.png new file mode 100644 index 0000000..26a63ba Binary files /dev/null and b/hex-ornament/textures/comp-3-2.png differ diff --git a/hex-ornament/textures/comp-3.png b/hex-ornament/textures/comp-3.png new file mode 100644 index 0000000..30e6680 Binary files /dev/null and b/hex-ornament/textures/comp-3.png differ diff --git a/hex-ornament/textures/comp-4-0.png b/hex-ornament/textures/comp-4-0.png new file mode 100644 index 0000000..ae8d18f Binary files /dev/null and b/hex-ornament/textures/comp-4-0.png differ diff --git a/hex-ornament/textures/comp-4.png b/hex-ornament/textures/comp-4.png new file mode 100644 index 0000000..9d0e243 Binary files /dev/null and b/hex-ornament/textures/comp-4.png differ diff --git a/hex-ornament/textures/comp-5-0.png b/hex-ornament/textures/comp-5-0.png new file mode 100644 index 0000000..e4038d2 Binary files /dev/null and b/hex-ornament/textures/comp-5-0.png differ diff --git a/hex-ornament/textures/comp-5.png b/hex-ornament/textures/comp-5.png new file mode 100644 index 0000000..c9dc309 Binary files /dev/null and b/hex-ornament/textures/comp-5.png differ diff --git a/hex-ornament/textures/comp-6.png b/hex-ornament/textures/comp-6.png new file mode 100644 index 0000000..950d75f Binary files /dev/null and b/hex-ornament/textures/comp-6.png differ diff --git a/hex-ornament/textures/comp-7.png b/hex-ornament/textures/comp-7.png new file mode 100644 index 0000000..4a2dec4 Binary files /dev/null and b/hex-ornament/textures/comp-7.png differ diff --git a/hex-ornament/textures/comp-8.png b/hex-ornament/textures/comp-8.png new file mode 100644 index 0000000..dac8002 Binary files /dev/null and b/hex-ornament/textures/comp-8.png differ diff --git a/hex-ornament/textures/comp-9.png b/hex-ornament/textures/comp-9.png new file mode 100644 index 0000000..4feb191 Binary files /dev/null and b/hex-ornament/textures/comp-9.png differ diff --git a/hex-ornament/textures/comp-cp-1-0.png b/hex-ornament/textures/comp-cp-1-0.png new file mode 100644 index 0000000..bf452ba Binary files /dev/null and b/hex-ornament/textures/comp-cp-1-0.png differ diff --git a/hex-ornament/textures/comp-cp-1-1.png b/hex-ornament/textures/comp-cp-1-1.png new file mode 100644 index 0000000..95e80ef Binary files /dev/null and b/hex-ornament/textures/comp-cp-1-1.png differ diff --git a/hex-ornament/textures/comp-cp-2-0.png b/hex-ornament/textures/comp-cp-2-0.png new file mode 100644 index 0000000..be3f7e9 Binary files /dev/null and b/hex-ornament/textures/comp-cp-2-0.png differ diff --git a/hex-ornament/textures/comp-cp-2-1.png b/hex-ornament/textures/comp-cp-2-1.png new file mode 100644 index 0000000..3d94013 Binary files /dev/null and b/hex-ornament/textures/comp-cp-2-1.png differ diff --git a/hex-ornament/textures/comp-cp-3-0.png b/hex-ornament/textures/comp-cp-3-0.png new file mode 100644 index 0000000..6374eca Binary files /dev/null and b/hex-ornament/textures/comp-cp-3-0.png differ diff --git a/hex-ornament/textures/comp-cp-3-1.png b/hex-ornament/textures/comp-cp-3-1.png new file mode 100644 index 0000000..7d0fa1c Binary files /dev/null and b/hex-ornament/textures/comp-cp-3-1.png differ diff --git a/hex-ornament/textures/comp-cp-3-2.png b/hex-ornament/textures/comp-cp-3-2.png new file mode 100644 index 0000000..b92bc5f Binary files /dev/null and b/hex-ornament/textures/comp-cp-3-2.png differ diff --git a/hex-ornament/textures/comp-cp-4-0.png b/hex-ornament/textures/comp-cp-4-0.png new file mode 100644 index 0000000..fe7a2b8 Binary files /dev/null and b/hex-ornament/textures/comp-cp-4-0.png differ diff --git a/hex-ornament/textures/comp-cp-5-0.png b/hex-ornament/textures/comp-cp-5-0.png new file mode 100644 index 0000000..8b57102 Binary files /dev/null and b/hex-ornament/textures/comp-cp-5-0.png differ diff --git a/hex-ornament/textures/particle.png b/hex-ornament/textures/particle.png new file mode 100644 index 0000000..8758f69 Binary files /dev/null and b/hex-ornament/textures/particle.png differ diff --git a/hex-ornament/textures/roots-ornate.png b/hex-ornament/textures/roots-ornate.png new file mode 100644 index 0000000..592f237 Binary files /dev/null and b/hex-ornament/textures/roots-ornate.png differ diff --git a/hex-ornament/textures/roots.png b/hex-ornament/textures/roots.png new file mode 100644 index 0000000..76d79ec Binary files /dev/null and b/hex-ornament/textures/roots.png differ diff --git a/hex-ornament/textures/surface.png b/hex-ornament/textures/surface.png new file mode 100644 index 0000000..da236d7 Binary files /dev/null and b/hex-ornament/textures/surface.png differ diff --git a/hex-ornament/textures/surface2.png b/hex-ornament/textures/surface2.png new file mode 100644 index 0000000..b9750a0 Binary files /dev/null and b/hex-ornament/textures/surface2.png differ diff --git a/hex-ornament/textures/worm.png b/hex-ornament/textures/worm.png new file mode 100644 index 0000000..b0f69ae Binary files /dev/null and b/hex-ornament/textures/worm.png differ diff --git a/treetris/treetris.scm b/treetris/treetris.scm index db67583..335b2da 100644 --- a/treetris/treetris.scm +++ b/treetris/treetris.scm @@ -265,57 +265,57 @@ ; builds objects from a string (define (ls-build string angle branch-scale branch-col leaf-col) (with-state - (rotate (vector 0 180 0)) - (hint-depth-sort) - (for-each - (lambda (char) - (cond - ((char=? #\F char) - (with-state - (translate (vmul (crndvec) 0.01)) - (scale (vector 1.2 1 1)) - (rotate (vector 0 90 0)) - (colour branch-col) - - (with-primitive (build-ribbon 2) - ; (texture (load-texture "../textures/fade4.png")) - ; (hint-unlit) - (pdata-set! "w" 0 0.1) - (pdata-set! "w" 1 0.07) - (pdata-set! "p" 0 (vector 0 0 0.9)) - (pdata-set! "p" 1 (vector 0 0 0)))) - (translate (vector 1 0 0))) - ((char=? #\L char) - (for ((i (in-range 1 2))) + (rotate (vector 0 180 0)) + (hint-depth-sort) + (for-each + (lambda (char) + (cond + ((char=? #\F char) (with-state - (translate (vmul (srndvec) 0.3)) - (scale (* (rndf) 0.5)) - (colour leaf-col) - ; (texture (load-texture "../textures/leaf.png")) - (build-sphere 3 3))) - #;(translate (vector 1 0 0))) - ((char=? #\f char) - (translate (vector 1 0 0))) - ((char=? #\/ char) - (rotate (vector angle 0 0))) - ((char=? #\\ char) - (rotate (vector (- angle) 0 0))) - ((char=? #\+ char) - (rotate (vector 0 angle 0))) - ((char=? #\- char) - (rotate (vector 0 (- angle) 0))) - ((char=? #\^ char) - (rotate (vector 0 0 (- angle)))) - ((char=? #\& char) - (rotate (vector 0 0 angle))) - ((char=? #\| char) - (rotate (vector 0 0 180))) - ((char=? #\[ char) - (push) - (scale (vector branch-scale branch-scale branch-scale))) - ((char=? #\] char) - (pop)))) - (string->list string)))) + (translate (vmul (crndvec) 0.01)) + (scale (vector 1.2 1 1)) + (rotate (vector 0 90 0)) + (colour branch-col) + + (with-primitive (build-ribbon 2) + ; (texture (load-texture "../textures/fade4.png")) + ; (hint-unlit) + (pdata-set! "w" 0 0.1) + (pdata-set! "w" 1 0.07) + (pdata-set! "p" 0 (vector 0 0 0.9)) + (pdata-set! "p" 1 (vector 0 0 0)))) + (translate (vector 1 0 0))) + ((char=? #\L char) + (for ((i (in-range 1 2))) + (with-state + (translate (vmul (srndvec) 0.3)) + (scale (* (rndf) 0.5)) + (colour leaf-col) + ; (texture (load-texture "../textures/leaf.png")) + (build-sphere 3 3))) + #;(translate (vector 1 0 0))) + ((char=? #\f char) + (translate (vector 1 0 0))) + ((char=? #\/ char) + (rotate (vector angle 0 0))) + ((char=? #\\ char) + (rotate (vector (- angle) 0 0))) + ((char=? #\+ char) + (rotate (vector 0 angle 0))) + ((char=? #\- char) + (rotate (vector 0 (- angle) 0))) + ((char=? #\^ char) + (rotate (vector 0 0 (- angle)))) + ((char=? #\& char) + (rotate (vector 0 0 angle))) + ((char=? #\| char) + (rotate (vector 0 0 180))) + ((char=? #\[ char) + (push) + (scale (vector branch-scale branch-scale branch-scale))) + ((char=? #\] char) + (pop)))) + (string->list string)))) (define (make-plant p n) (let ((root (build-locator))) @@ -406,15 +406,14 @@ ; (hint-origin) (build-locator))) (lock-camera camera) -(set-camera-transform (mrotate (vector -90 0 0))) -;(camera-lag 0.5) +(camera-lag 0.5) (light-diffuse 0 (vector 0 0 0)) (define l (make-light 'point 'free)) (light-diffuse l (vector 1 1 1)) (light-position l (vector 10 50 20)) -(for ((i (in-range 1 100))) +(for ((i (in-range 1 30))) (with-state (rotate (vector 0 0 (random 360))) (translate (vector (+ 20 (random 5)) 0 0)) @@ -467,4 +466,62 @@ (set! tree (build-tree tree-size)) (particles-explode particles))))) -(every-frame (update)) +(define running #f) + +(define start-time (time)) + +(define intro-root (build-locator)) + +(define splash2 + (with-state + (texture (load-texture "textures/gw.png")) + (hint-unlit) +; (colour 0) + (scale (vmul (vector 3 2.25 1) 12.5)) + (translate (vector 0 0 0.9)) + ; (rotate (vector 90 0 0)) + (build-plane))) + +(define splash + (with-state + (texture (load-texture "textures/foam.png")) + (hint-unlit) +; (colour 0) + (scale (vmul (vector 3 2 1) 14)) + (translate (vector 0 0 1)) + ; (rotate (vector 90 0 0)) + (build-plane))) + + +(set-camera-transform (mtranslate (vector 0 0 -30))) + +(define splash-time 8) + +(define (animate) + (when (not running) + + (when (< (time) (+ start-time (/ splash-time 2))) + (with-primitive splash + (scale 1.001) + (colour (- 1 (/ (- (+ start-time (/ splash-time 2)) (time)) (/ splash-time 2)))))) + + (when (> (time) (+ start-time (/ splash-time 2))) + (with-primitive splash + (scale 1.001) + (opacity (- 1 (/ (- (time) (+ start-time (/ splash-time 2))) 2))))) + + (when (> (time) (+ start-time splash-time)) + (with-primitive splash (hide 1))) + + (when (or (not (zero? (length (keys-down)))) (not (zero? (length (keys-special-down))))) + (set-camera-transform (mrotate (vector -90 0 0))) + (set! running #t) + (set! next-time (flxtime)) + (with-primitive intro-root (hide 1)) + (with-primitive splash (hide 1)) + (with-primitive splash2 (hide 1)))) + + (when running (update))) + + +(every-frame (animate))