Merge branch 'master' of ssh://nik@fo.am/var/git/groworld

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)

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)

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

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

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

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

treetris/treetris.scm

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