2 player working, sorted out plant types

hex-ornament/hex-ornament.scm

@@ -1,18 +1,18 @@
-;#lang scheme
+;#lang scheme/base
 ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 ; hex ornament/groworld game : fluxus version
 
-;(require fluxus-016/drflux.ss)
+;(require fluxus-016/drflux)
 (require scheme/class)
 
 ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 ; tweakables
 
-(define num-insects 50)
+(define num-insects 20)
 (define pickup-drop-probability 10)
 
 (define (vec3->vec4 v a)
-    (vector (vx v) (vy v) (vz 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)))
@@ -20,6 +20,11 @@
 (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 (type->colour type)
+  (cond 
+    ((string=? type "knobbly") (vector 1 0.6 0.6))
+    ((string=? type "lollypop") (vector 0.6 0.6 1))))
+
 ;(define texpath "")
 (define texpath "textures/")
 
@@ -29,34 +34,34 @@
 ; 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 
+  (cond 
-        ((null? l) l)
+    ((null? l) l)
-        ((eq? c n) (cons v (insert (cdr l) n v (+ c 1))))
+    ((eq? c n) (cons v (insert (cdr l) n v (+ c 1))))
-        (else (cons (car l) (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)
+  (if (zero? i)
-        (cdr l)
+      (cdr l)
-        (cons (car l) (list-remove (cdr l) (- i 1)))))
+      (cons (car l) (list-remove (cdr l) (- i 1)))))
 
 (define (shuffle l)
-    (if (null? l)
+  (if (null? l)
-        '()
+      '()
-        (let ((i (random (length l))))
+      (let ((i (random (length l))))
-            (cons (list-ref l i)
+        (cons (list-ref l i)
-                (shuffle (list-remove l i))))))
+              (shuffle (list-remove l i))))))
 
 (define (choose l)
-    (list-ref l (random (length 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 
+  (cond 
-        ((null? l) n)
+    ((null? l) n)
-        ((car l) (bitwise-ior (arithmetic-shift 1 c)
+    ((car l) (bitwise-ior (arithmetic-shift 1 c)
-                (bool-list->num (cdr l) n (+ c 1))))
+                          (bool-list->num (cdr l) n (+ c 1))))
-        (else (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
 ;           .
@@ -78,34 +83,34 @@
 (define directions (list NE E SE SW W NW))
 
 (define (rdirection d) 
-    (cond
+  (cond
-        ((eq? d NE) SW)
+    ((eq? d NE) SW)
-        ((eq? d E) W) 
+    ((eq? d E) W) 
-        ((eq? d SE) NW)
+    ((eq? d SE) NW)
-        ((eq? d SW) NE)
+    ((eq? d SW) NE)
-        ((eq? d W) E)
+    ((eq? d W) E)
-        ((eq? d NW) SE)))
+    ((eq? d NW) SE)))
 
 ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 ; util for building random plants
 
 (define (make-random-plant depth)        
-    (let ((num-children (cond ((> depth 2) 0)
+  (let ((num-children (cond ((> depth 2) 0)
-                    ((< depth 1) (choose (list 2 3)))
+                            ((< depth 1) (choose (list 2 3)))
-                    (else (choose (list 0 1 2 3))))))
+                            (else (choose (list 0 1 2 3))))))
-        (cond 
+    (cond 
-            ((eq? num-children 0) (list (choose (list "11")) (list)))
+      ((eq? num-children 0) (list (choose (list "0" "1")) (list)))
-            ((eq? num-children 1) (list "1-1" (list (make-random-plant (+ depth 1)))))
+      ((eq? num-children 1) (list "1-0" (list (make-random-plant (+ depth 1)))))
-            ((eq? num-children 2) (list "2-1" (list (make-random-plant (+ depth 1))
+      ((eq? num-children 2) (list "2-0" (list (make-random-plant (+ depth 1))
-                        (make-random-plant (+ depth 1)))))
+                                              (make-random-plant (+ depth 1)))))
-            ((eq? num-children 3) (list "3-1" (list (make-random-plant (+ depth 1))
+      ((eq? num-children 3) (list "3-0" (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)))))
-            ((eq? num-children 4) (list "4-1" (list (make-random-plant (+ depth 1))
+      ((eq? num-children 4) (list "4-0" (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)) 
-                        (make-random-plant (+ depth 1)))))
+                                              (make-random-plant (+ depth 1)))))
-            ((eq? num-children 5) (list "5-1" (list (make-random-plant (+ depth 1))
+      ((eq? num-children 5) (list "5-0" (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))
-                        (make-random-plant (+ depth 1)) (make-random-plant (+ depth 1))))))))
+                                              (make-random-plant (+ depth 1)) (make-random-plant (+ depth 1))))))))
 
 ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 ; how this works
@@ -130,95 +135,97 @@
 ; logic
 
 ; messages passed between the honey-comb logic and the view
-(define-struct cell-update (pos code pickup upstream))
+(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))
+(define-struct plant-update (id desc pos type))
 
 (define comb-cell%
-    (class object%
+  (class object%
-        (field
+    (field
-            (id #f)   ; id of the owner plant
+     (plant #f)   ; the owner plant
-            (pos '())
+     (pos '())
-            (neighbours '(#f #f #f #f #f #f))
+     (neighbours '(#f #f #f #f #f #f))
-            (pickup #f)
+     (pickup #f)
-            (connections '(#f #f #f #f #f #f))
+     (connections '(#f #f #f #f #f #f))
-            (visible #f)
+     (visible #f)
-            (update-me #f)
+     (update-me #f)
-            (upstream #f)) ; the cell we are connected to (if we are)
+     (upstream #f)) ; the cell we are connected to (if we are)
     
-        (define/public (get-id)
+    (define/public (get-plant)
-            id)
+      plant)
     
-        (define/public (set-id! s)
+    (define/public (set-plant! s)
-            (set! id s))
+      (set! plant s))
     
-        (define/public (update-me?)
+    (define/public (update-me?)
-            (let ((r update-me))
+      (let ((r update-me))
-                (set! update-me #f)
+        (set! update-me #f)
-                r))
+        r))
     
-        (define/public (get-upstream)
+    (define/public (get-upstream)
-            upstream)
+      upstream)
     
-        (define/public (set-visible! s)
+    (define/public (set-visible! s)
-            (set! update-me #t)
+      (set! update-me #t)
-            (set! visible s))
+      (set! visible s))
     
-        (define/public (visible?)
+    (define/public (visible?)
-            visible)
+      visible)
     
-        (define/public (get-pos)
+    (define/public (get-pos)
-            pos)
+      pos)
     
-        (define/public (set-pos! s)
+    (define/public (set-pos! s)
-            (set! pos s))
+      (set! pos s))
     
-        (define/public (get-neighbours)
+    (define/public (get-neighbours)
-            neighbours)
+      neighbours)
     
-        (define/public (get-neighbour d)
+    (define/public (get-neighbour d)
-            (list-ref neighbours d))
+      (list-ref neighbours d))
     
-        (define/public (set-neighbour! d n)
+    (define/public (set-neighbour! d n)
-            (set! neighbours (insert neighbours d n 0)))
+      (set! neighbours (insert neighbours d n 0)))
     
-        (define/public (get-pickup)
+    (define/public (get-pickup)
-            pickup)
+      pickup)
     
-        (define/public (set-pickup! s)
+    (define/public (set-pickup! s)
-            (when visible (set! update-me #t))
+      (when visible (set! update-me #t))
-            (set! pickup s))
+      (set! pickup s))
     
-        (define/public (get-connections)
+    (define/public (get-connections)
-            connections)
+      connections)
     
-        (define/public (no-connections?)
+    (define/public (no-connections?)
-            (equal? connections (list #f #f #f #f #f #f)))
+      (equal? connections (list #f #f #f #f #f #f)))
     
-        (define/public (set-connection! d n)
+    (define/public (set-connection! d n)
-            (set! update-me #t)
+      (set! update-me #t)
-            (set! visible #t)
+      (set! visible #t)
-            (set! connections (insert connections d n 0))
+      (set! connections (insert connections d n 0))
-            ; tell all our neighbours to become visible
+      ; tell all our neighbours to become visible
-            (for-each
+      (for-each
-                (lambda (n)
+       (lambda (n)
-                    (when n (send n set-visible! #t)))
+         (when n 
-                neighbours))
+           (send n set-visible! #t)
+           (send n set-plant! plant)))
+       neighbours))
     
-        (define/public (get-connection d)
+    (define/public (get-connection d)
-            (list-ref connections d))
+      (list-ref connections d))
     
-        (define/public (get-connection-num)
+    (define/public (get-connection-num)
-            (bool-list->num connections 0 0))
+      (bool-list->num connections 0 0))
     
-        ; returns the first attachable neighbour found, and sets it's connection
+    ; returns the first attachable neighbour found, and sets it's connection
-        (define (search/attach-to-neighbour l dirs)
+    (define (search/attach-to-neighbour l dirs)
-            (cond 
+      (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! plant (send (get-neighbour (car l)) get-plant))
                     (set! upstream (get-neighbour (car l)))
                     #;(search/attach-to-neighbour (cdr l) (cons (car l) dirs))
                     (car l))
@@ -277,7 +284,8 @@
 (define plant%
     (class object%
         (init-field
-            (id "default")
+            (id "none")
+            (type "none")
             (pos '())) ; the seed position
         
         (field
@@ -287,6 +295,9 @@
         (define/public (get-id)
             id)
         
+        (define/public (get-type)
+            type)
+        
         (define/public (update-me?)
             (let ((r update-me))
                 (set! update-me #f)
@@ -320,7 +331,8 @@
                     (if (send (cadr plant) update-me?)
                         (cons (make-plant-update (car plant) 
                                 (send (cadr plant) get-desc)
-                                (send (cadr plant) get-pos)) r)
+                                (send (cadr plant) get-pos)
+                                (send (cadr plant) get-type)) r)
                         r))
                 '()
                 plants))
@@ -377,12 +389,13 @@
                             (send cell set-neighbour! SW (get-cell (if (odd? y) x (- x 1)) (+ y 1))))))))            
         
         
-        (define/public (seed id x y)
+      (define/public (seed id type x y)
-            (send garden add-plant (make-object plant% id (list x y)))
+        (let ((plant (make-object plant% id type (list x y))))
-            (send (get-cell x y) set-connection! SE #t)
+          (send garden add-plant plant)
-            (send (get-cell x y) set-id! id)
+          (send (get-cell x y) set-plant! plant)
-            (send (get-cell x (+ y 1)) set-connection! NW #t)
+          (send (get-cell x y) set-connection! SE #t)
-            (send (get-cell x (+ y 1)) set-id! id))
+          (send (get-cell x (+ y 1)) set-plant! plant)
+          (send (get-cell x (+ y 1)) set-connection! NW #t)))
         
         (define/public (update time delta)
             
@@ -405,14 +418,17 @@
                             (if l (cons l r) r)))
                     '()
                     insects)
+                
                 (foldl
-                    (lambda (cell r)
+                 (lambda (cell r)
-                        (if (send cell update-me?)
+                   (if (send cell update-me?)
-                            (let ((upstream (send cell get-upstream)))
+                       (let ((upstream (send cell get-upstream))
-                                (cons (make-cell-update (send cell get-pos)
+                             (plant (send cell get-plant)))
-                                        (send cell get-connection-num)
+                         (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))
+                                        (if upstream (send upstream get-pos) #f)
+                                        (if plant (send plant get-type) #f)) r))
                             r))
                     '()
                     cells)
@@ -432,7 +448,7 @@
         (vmul (vector (sin (* a d)) (cos (* a d)) 0) -1)))
 
 
-(define (build-ngon n)
+#;(define (build-ngon n)
     (let ((p (build-polygons n 'polygon)))
         (with-primitive p
             (pdata-index-map!
@@ -577,14 +593,14 @@
 
 (define connection-cache '())
 
-(define (get-connection-list id)
+(define (get-connection-list id type)
-    (let ((ret (assoc id connection-cache)))
+    (let ((ret (assoc (list id type) connection-cache)))
         (cond 
             (ret (cdr ret))
             (else
-                (let* ((tex (load-primitive (string-append "textures/comp-cp-" id ".png")))
+                (let* ((tex (load-primitive (string-append "plants/" type "/branches/comp-cp-" id ".png")))
                         (connections (with-primitive tex (convert-to-pos (find-centroids 0 '())))))
-                    (set! connection-cache (cons (cons id connections) connection-cache))
+                    (set! connection-cache (cons (cons (list id type) connections) connection-cache))
                     ;(printf "~a:~a~n" id (length connections))
                     (destroy tex)
                     connections)))))
@@ -595,25 +611,27 @@
 
 (define-struct component (root (col #:mutable) children))
 
-(define (build-component id col 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 "textures/comp-" id ".png")))
+                            (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))
+            (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 "textures/comp-" id ".png")))
+                            (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) ))
@@ -627,7 +645,7 @@
                                             (rotate (vector 0 0 (2dvec->angle 
                                                         (vx connection) (- (vy connection) 0.5))))
                                             (rotate (vector 0 0 0))
-                                            (build-component (car child) col (cadr child))))
+                                            (build-component (car child) type col (cadr child))))
                                     children
                                     connection-list))))
                     (with-primitive root (apply-transform))
@@ -663,6 +681,7 @@
             (t 0)
             (pos '(0 0))
             (owner 0)
+            (type #f) ; the plant type of the owner of the roots, if any
             (upstream-pos '()))
         
         (define/public (get-upstream-pos)
@@ -686,6 +705,9 @@
         (define/public (set-pos! s)
             (set! pos s))
 
+        (define/public (set-type! s)
+            (set! type s))
+        
         (define (build-prim code)                        
             (let ((p (with-state    
                             ;(hint-wire)
@@ -714,13 +736,16 @@
             (set! tile2 (build-prim code)))
         
         (define (update-texture code)
-            (texture (load-texture (string-append texpath "roots-ornate.png")))
+          ; todo: variations
-            (pdata-map!
+          (when type
-                (lambda (t tref)
+            (texture (load-texture (string-append "plants/" type "/roots/roots.png")))
-                    (let ((size (/ 1 8)))
+            (colour (type->colour type)))
-                        (vadd (vmul tref size) (vector (* 1 size (+ 1 (modulo code 8)))
+          (pdata-map!
-                                (* size 1 (+ 1 (quotient code 8))) 0))))
+           (lambda (t tref)
-                "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)) 
@@ -956,7 +981,7 @@
             (root 0)
             (desc '()))
         
-        (define/public (build s)
+        (define/public (build s type)
             (set! desc s)
             
             (when (not (zero? root))
@@ -969,7 +994,7 @@
                 (parent root)
                 (hint-depth-sort)
                 (translate (vector 0.2 0.3 0.3))
-                (build-component "1-1" (vector 1 1 1) (list desc))))
+                (build-component "1-0" type (type->colour type) (list desc))))
         
         
         (super-new)))
@@ -981,11 +1006,11 @@
         (field 
             (plants '()))
         
-        (define/public (add-plant! id desc hex)
+        (define/public (add-plant! id desc hex type)
             (let ((plant (make-object plant-view%)))
                 (with-state
                     (parent (send hex get-root))                
-                    (send plant build desc)
+                    (send plant build desc type)
                     (set! plants (cons (list id plant) plants)))))
         
         (super-new)))
@@ -1050,7 +1075,7 @@
                         top (- len 1) (cons lev l)))))
         
         (define/public (build-surface)
-            (let ((s (make-surface 12 13 20 '())))
+            (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))) 
@@ -1110,11 +1135,13 @@
                                     (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)))
+                                        (send (cadr s) set-upstream-pos! (cell-update-upstream item))
+                                        (send (cadr s) set-type! (cell-update-type item)))
                                     (else
                                         (let ((cell (make-object cell-view%)))
                                             (send cell set-pos! pos)
                                             (send cell set-owner! root)
+                                            (send cell set-type! (cell-update-type item))
                                             (send cell build code)
                                             (set! cells (cons (list pos cell) cells)))))))
                         ((insect-update? item)
@@ -1135,7 +1162,8 @@
                             (send garden add-plant!
                                 (plant-update-id item)
                                 (plant-update-desc item)
-                                (get-cell-from-pos (plant-update-pos item))))))
+                                (get-cell-from-pos (plant-update-pos item))
+                                (plant-update-type item)))))
                 update-list))
         
         (super-new)))
@@ -1160,7 +1188,9 @@
     ;    (translate (vector -10 -8.5 0))
     (send hcv init))
 
-(send hc seed "dave@fo.am" 10 10)
+(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)
 
@@ -1175,4 +1205,6 @@
             (send (send hc get-cell (car clicked) (cadr clicked)) grow)))
     (send hcv update (send hc update t d) t d))
 
+
+;(for ((i (in-range 0 10))) (animate))
 (every-frame (animate))