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/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/worm.png b/hex-ornament/textures/worm.png new file mode 100644 index 0000000..d7fc55c Binary files /dev/null and b/hex-ornament/textures/worm.png differ