added stuff

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))))

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))