stones, sky, schematic roots

hex-ornament/hex-ornament.scm

@@ -1,21 +1,29 @@
-;#lang scheme/base
+#lang scheme/base
 ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 ; hex ornament/groworld game : fluxus version
 
-;(require fluxus-016/drflux)
+(require fluxus-016/drflux)
 (require scheme/class)
 
 ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 ; tweakables
 
-(define num-insects 20)
+(define hex-width 40)
+(define hex-height 40)
+
+(define num-insects 50)
 (define pickup-drop-probability 10)
 
+(define surface-start 34)
+(define surface-upper 39)
+(define surface-lower 30)
+
 (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 (bg-colour) (vmul (vector 0.9 0.8 0.7) 0.2))
+(define (sky-colour) (vector 0.7 0.8 1))
+(define (worm-colour) (hsv->rgb (vector 0.1 (rndf) 1)))
 (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))
@@ -23,7 +31,9 @@
 (define (type->colour type)
   (cond 
     ((string=? type "knobbly") (vector 1 0.6 0.6))
-    ((string=? type "lollypop") (vector 0.6 0.6 1))))
+    ((string=? type "lollypop") (vector 0.6 0.6 1))    
+    ((string=? type "nik") (vector 0.6 1 0.6))
+    (else (vector 1 1 1))))
 
 ;(define texpath "")
 (define texpath "textures/")
@@ -115,9 +125,9 @@
 ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 ; how this works
 ;
-;     logic side                    view side
-;     ----------                    ---------
-;   * no fluxus code        |     * no game code
+;     logic side                    rendering side
+;     ----------                    --------------
+; (no fluxus code allowed)  |    (no game code allowed)
 ;                           |
 ;     comb-cell             |       comb-cell-view
 ;          \                |          /
@@ -126,8 +136,8 @@
 ;         honey-comb  ===========> honey-comb-view
 ;           /               |           \
 ;     garden                |         garden-view
-;
-;   
+;      /                    |               \
+;   plant                   |               plant-view
 ;
 ;
 
@@ -135,10 +145,12 @@
 ; logic
 
 ; messages passed between the honey-comb logic and the view
+(define-struct init-update (surface-pos-list))
 (define-struct cell-update (pos code pickup upstream type))
 (define-struct insect-update (id pos dir t))
 (define-struct absorb-event (cell-pos type))
 (define-struct plant-update (id desc pos type))
+(define-struct controller-update (grow-pos))
 
 (define comb-cell%
   (class object%
@@ -348,7 +360,9 @@
             (width 0)
             (height 0)
             (insects '())
-            (garden (make-object garden%)))
+            (garden (make-object garden%))
+            (surface-cells '())
+            (first-time #t))
         
         (define/public (get-cell x y)
             (list-ref cells (+ (* y height) x)))
@@ -386,31 +400,52 @@
                         (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))))))))            
+                            (send cell set-neighbour! SW (get-cell (if (odd? y) x (- x 1)) (+ y 1)))))))
+          (set! surface-cells (calc-surface-cells 0 surface-start surface-upper surface-lower '())))
+          
+        ; we need to calculate the surface cells here, as we have the information
+        ; to calculate an unbroken line of hexes
+      (define/public (calc-surface-cells x y upper lower l)
+        ; calculate the surface hexes
+        (let* ((direction (choose (cond 
+                                    ((> y (- upper 1)) (list E NE))
+                                    ((< y lower) (list E SE))
+                                    (else (list SE E NE)))))
+               (next-cell (send (get-cell x y) get-neighbour direction)))
+          (cond ((not next-cell) l)
+                (else
+                 (let ((pos (send next-cell get-pos)))
+                   (calc-surface-cells (car pos) (cadr pos) upper lower 
+                                       (cons (list (list x y) direction) l)))))))
         
-        
-      (define/public (seed id type x y)
-        (let ((plant (make-object plant% id type (list x y))))
+      (define/public (seed id type i)
+        (let* ((x (car (car (list-ref surface-cells i))))
+              (y (cadr (car (list-ref surface-cells i))))
+              (plant (make-object plant% id type (list x y))))
           (send garden add-plant plant)
-          (send (get-cell x y) set-plant! plant)
-          (send (get-cell x y) set-connection! SE #t)
-          (send (get-cell x (+ y 1)) set-plant! plant)
-          (send (get-cell x (+ y 1)) set-connection! NW #t)))
+          (send (get-cell x (- y 1)) set-plant! plant)
+          (send (get-cell x (- y 1)) set-connection! SE #t)
+          #;(send (get-cell x (- y 1)) set-plant! plant)
+          #;(send (get-cell x (- y 1)) set-connection! NW #t)))
         
         (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)
+             
+             ; first frame, send the cells that represent the surface, so they can be drawn
+             (cond (first-time (set! first-time #f) (list (make-init-update surface-cells)))
+                   (else '()))
+                           
+             ; 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)
@@ -447,26 +482,6 @@
     (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
@@ -486,6 +501,18 @@
             (pdata-map! (lambda (n) (vector 0 0 1)) "n"))
         p))
 
+(define (build-hex x y root)
+  (with-state    
+   ;(hint-wire)
+   (parent root)
+   (hint-unlit)
+   (when (odd? y)
+     (translate (vector 0.5 0 0)))
+   (translate (vector x (* 0.85 y) (* 0.001 (rndf))))
+   (scale (vector 0.58 0.57 1))
+   (rotate (vector 0 0 90))
+   (build-ngon 6)))
+
 ; slow implementation of hermite curves for animation
 (define (hermite s p1 p2 t1 t2)
     ; the bernstein polynomials
@@ -612,44 +639,42 @@
 (define-struct component (root (col #:mutable) children))
 
 (define (build-component id type col children)
-    (cond 
-        ((null? children) 
-            (let ((root (with-state
-                            (translate (vector 0 0.5 (* 0.01 (rndf))))
-                            (colour col)
-                            (hint-none)
-                            (hint-solid)
-                            (hint-unlit)
-                            (hint-depth-sort)
-                            (texture (load-texture (string-append "plants/" type "/leaves/comp-" id ".png")))
-                            (build-plane))))
-                (make-component root col '())))
-        (else
-            (let ((connection-list (get-connection-list id type))
-                    (root (with-state
-                            (colour col)
-                            (hint-depth-sort)
-                            (translate (vector 0 0.5 (* 0.01 (rndf))))
-                            ;                            (rotate (vector 0 0 90))
-                            (texture (load-texture (string-append "plants/" type "/branches/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
+  (cond 
+    ((null? children) 
+     (let ((root (with-state
+                  (colour col)
+                  (hint-unlit)
+                  (hint-depth-sort)
+                  (translate (vector 0 0.5 0))
+                  (texture (load-texture (string-append "plants/" type "/leaves/comp-" id ".png")))
+                  (build-plane))))
+       (make-component root col '())))
+    (else
+     (let ((connection-list (get-connection-list id type))
+           (root (with-state
+                  (colour col)
+                  (hint-unlit)
+                  (hint-depth-sort)
+                  (translate (vector 0 0.5 0))
+                  (texture (load-texture (string-append "plants/" type "/branches/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) type col (cadr child))))
+                                      (with-state                                        
+                                       (parent root)
+                                       (translate (vadd connection (vector 0 0 (* 0.001 (rndf)))))
+                                       (rotate (vector 0 0 (2dvec->angle 
+                                                            (vx connection) (- (vy connection) 0.5))))
+                                       ;(scale 0.9)
+                                       (build-component (car child) type col (cadr child))))
                                     children
                                     connection-list))))
-                    (with-primitive root (apply-transform))
-                    comp)))))
+         (with-primitive root (apply-transform))
+         comp)))))
 
 (define (random-leaf component)
     (cond
@@ -677,6 +702,7 @@
             (root 0)
             (tile1 0)
             (tile2 0)
+            (bgtile 0)
             (pickup-root 0)
             (t 0)
             (pos '(0 0))
@@ -709,19 +735,12 @@
             (set! type 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))))
+            (let ((p (build-hex 0 0 root)))
                 (with-primitive p
-                    (update-texture code))
+                                (hint-depth-sort)
+                                (colour (root-colour))           
+                                (opacity 0)
+                                (update-texture code))
                 p))
         
         (define/public (build code)            
@@ -731,6 +750,22 @@
                         (translate (vector 0.5 0 0)))
                     (translate (vector (car pos) (* 0.85 (cadr pos)) 0))
                     (build-locator)))
+          
+          (when (zero? bgtile)
+            (set! bgtile (build-hex 0 0 root))
+            (with-primitive bgtile
+                            (hint-depth-sort)
+                            (texture (load-texture (string-append texpath "stones.png")))
+                            (translate (vector 0 0 -0.1))
+                            (rotate (vector 0 0 (* (random 6) 60))))
+            (let ((code (random 4)))
+              (with-primitive bgtile
+                            (pdata-map!
+                             (lambda (t)
+                               (let ((size (/ 1 2)))
+                                 (vadd (vmul t size) (vector (* 1 size (+ 1 (modulo code 2)))
+                                                             (* size 1 (+ 1 (quotient code 2))) 0))))
+                             "t"))))
             
             (set! tile1 (build-prim code))
             (set! tile2 (build-prim code)))
@@ -993,7 +1028,7 @@
             (with-state
                 (parent root)
                 (hint-depth-sort)
-                (translate (vector 0.2 0.3 0.3))
+                (translate (vector 0.2 0.3 0.1))
                 (build-component "1-0" type (type->colour type) (list desc))))
         
         
@@ -1036,22 +1071,21 @@
                 (for-each 
                     (lambda (insect)
                         (send (cadr insect) build))
-                    insects))
-            (build-surface))
+                    insects)))
         
-        (define (get-pos-from-prim p l)
+        (define (get-pos-from-prim-impl p l)
             (cond 
                 ((null? l) #f)
                 ((eq? (send (cadr (car l)) get-tile) p) (caar l))
-                (else (get-pos-from-prim p (cdr l)))))
+                (else (get-pos-from-prim-impl p (cdr l)))))
         
+      (define/public (get-pos-from-prim p)
+        (get-pos-from-prim-impl p cells))
+      
         (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)))
@@ -1063,47 +1097,41 @@
                         (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 10 11 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)))))))))
-        
+            (texture (load-texture (string-append texpath "surface3.png"))))
         
+      (define (surface-contains? pos l)
+        (cond 
+          ((null? l) #f)
+          ((equal? (car (car l)) pos) #t)
+          (else (surface-contains? pos (cdr l)))))
+      
+        (define/public (build-surface l)
+          (let ((s (reverse l)))
+            (for ((i (in-range 1 (- (length s) 1))))
+                 (let ((x (caar (list-ref s i)))
+                       (y (cadr (car (list-ref s i))))
+                       (d (car (cdr (list-ref s i))))
+                       (ld (car (cdr (list-ref s (- i 1))))))
+                   (let ((p (with-state 
+                             (colour (sky-colour)) 
+                             (build-hex x y root))))
+                     (with-primitive p
+                                     (surface-texture 
+                                      (cond 
+                                        ((eq? ld NE) 0)
+                                        ((eq? ld E) 1)
+                                        ((eq? ld SE) 2))
+                                      (cond 
+                                        ((eq? d NE) 2)
+                                        ((eq? d E) 1)
+                                        ((eq? d SE) 0)))))
+                   (for ((i (in-range (+ y 1) (+ surface-upper 1))))
+                        (when (not (surface-contains? (list x i) s))
+                          (with-state 
+                           (colour (sky-colour)) 
+                           (build-hex x i root))))))))
+                         
         (define/public (update update-list time delta)
-            
             ; do the per-frame update on all the things
             (set! absorb-list
                 (filter
@@ -1144,6 +1172,7 @@
                                             (send cell set-type! (cell-update-type item))
                                             (send cell build code)
                                             (set! cells (cons (list pos cell) cells)))))))
+                        
                         ((insect-update? item)
                             (let* ((pos (insect-update-pos item))
                                     (c (assoc pos cells))
@@ -1153,57 +1182,91 @@
                                         (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))
-                                (plant-update-type item)))))
+                                (plant-update-type item)))
+                        
+                        ((init-update? item)
+                         (build-surface (init-update-surface-pos-list item)))))
+                         
+                         
+                         
                 update-list))
         
         (super-new)))
 
 ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
+(define controller%
+  (class object%
+    (field
+     (camera-pos (vector -13 -27 -5)))
+    
+    (define/public (update)
+      (when (key-pressed "a") 
+        (set! camera-pos (vadd camera-pos (vector 0.1 0 0))))
+      (when (key-pressed "d") 
+        (set! camera-pos (vadd camera-pos (vector -0.1 0 0))))
+      (when (key-pressed "s") 
+        (set! camera-pos (vadd camera-pos (vector 0 0.1 0))))
+      (when (key-pressed "w") 
+        (set! camera-pos (vadd camera-pos (vector 0 -0.1 0))))
+      (when (key-pressed "z") 
+        (set! camera-pos (vadd camera-pos (vector 0 0 0.1))))
+      (when (key-pressed "x") 
+        (set! camera-pos (vadd camera-pos (vector 0 0 -0.1))))
+      (set-camera-transform (mtranslate camera-pos))
+      (if (mouse-button 1)
+          (mouse-over)
+          0))
+    
+   (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%))
+(define con (make-object controller%))
 
-(send hc init 20 20)
+(send hc init hex-width hex-height)
+(send hcv init)
+
+(send hc seed "dave@fo.am" "knobbly" 45)
+(send hc seed "plant00002@fo.am" "lollypop" 30)
+(send hc seed "plant00003@fo.am" "nik" 15)
 
 (with-state
-    ;    (translate (vector -50 -42.5 0))
-    ;    (translate (vector -10 -8.5 0))
-    (send hcv init))
-
-(send hc seed "dave@fo.am" "knobbly" 13 10)
-(send hc seed "plant00002@fo.am" "lollypop" 6 10)
-
-;(send (send hc get-cell 50 52) grow)
-;(send (send hc get-cell 49 53) grow)
+ (colour (sky-colour))
+ (hint-unlit)
+ (translate (vector 0 (- surface-upper 0.6) 0))
+ (scale (vector 100 10 1))
+ (build-plane))
 
 (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))
+  ;    (set! d (delta))
+  (set! t (+ t d))
+  (let ((clicked (send con update)))
+    (when (not (zero? clicked))
+      (let ((pos (send hcv get-pos-from-prim clicked)))
+        (when pos 
+          (send (send hc get-cell (car pos) (cadr pos)) grow)))))
+  (send hcv update (send hc update t d) t d))
 
 
 ;(for ((i (in-range 0 10))) (animate))