diff --git a/plant-eyes/client.ss b/plant-eyes/client.ss index c2d676b..c1ebf49 100644 --- a/plant-eyes/client.ss +++ b/plant-eyes/client.ss @@ -18,6 +18,9 @@ "plant0000001@fo.am" "plant0000002@fo.am" "plant0000003@fo.am" + "plant0000004@fo.am" + "plant0000005@fo.am" + "dave@fo.am" )) (plants-present '()) (msg-filter (list 'new-pickup 'pick-up-pickup)) ; messages we don't want to send across the network diff --git a/plant-eyes/jabberer.ss b/plant-eyes/jabberer.ss index a821cef..9bb0dd5 100644 --- a/plant-eyes/jabberer.ss +++ b/plant-eyes/jabberer.ss @@ -53,8 +53,9 @@ (let loop () (when debug-netloop (printf ".~n")) (when (not (null? outgoing)) + (when debug-jab (printf "tx ----> ~a ~a~n" (car (car outgoing)) (cadr (car outgoing)))) (xmpp:send (xmpp:message (car (car outgoing)) (cadr (car outgoing)))) (set! outgoing (cdr outgoing))) - (sleep 0.5) + (sleep 0.1) (loop)))) (super-new))) diff --git a/plant-eyes/list-utils.ss b/plant-eyes/list-utils.ss index 521cff9..bb7f049 100644 --- a/plant-eyes/list-utils.ss +++ b/plant-eyes/list-utils.ss @@ -41,4 +41,10 @@ (cond ((null? a) '()) ((not (list-contains (car a) b)) (cons (car a) (list-remainder (cdr a) b))) - (else (list-remainder (cdr a) b)))) \ No newline at end of file + (else (list-remainder (cdr a) b)))) + +(define (which-element k l n) + (cond + ((null? l) #f) + ((eq? (car l) k) n) + (else (which-element k (cdr l) (+ n 1))))) \ No newline at end of file diff --git a/plant-eyes/logic.ss b/plant-eyes/logic.ss index fddaaff..6dfdf24 100644 --- a/plant-eyes/logic.ss +++ b/plant-eyes/logic.ss @@ -294,7 +294,9 @@ (class game-logic-object% (init-field (id #f) - (pos (vector 0 0 0))) + (pos (vector 0 0 0)) + (col (vector 1 1 1)) + (tex "fff")) (field (twigs '()) ; a assoc list map of ages to twigs @@ -316,6 +318,12 @@ (define/public (get-size) size) + + (define/public (get-col) + col) + + (define/public (get-tex) + tex) (define/public (grow dir) (for-each @@ -453,7 +461,9 @@ (send-message 'player-plant (list (list 'plant-id (send plant get-id)) (list 'pos (send plant get-pos)) - (list 'size (send plant get-size)))) + (list 'size (send plant get-size)) + (list 'col (send plant get-col)) + (list 'tex (send plant get-tex)))) (set! player plant) (set! plants (cons plant plants))) @@ -461,7 +471,9 @@ (send-message 'new-plant (list (list 'plant-id (send plant get-id)) (list 'pos (send plant get-pos)) - (list 'size (send plant get-size)))) + (list 'size (send plant get-size)) + (list 'col (send plant get-col)) + (list 'tex (send plant get-tex)))) (set! plants (cons plant plants))) (define/public (add-pickup pickup) diff --git a/plant-eyes/plant-eyes.scm b/plant-eyes/plant-eyes.scm index 48f1d04..ef13428 100644 --- a/plant-eyes/plant-eyes.scm +++ b/plant-eyes/plant-eyes.scm @@ -1,10 +1,6 @@ -;#lang scheme/base -;(require fluxus-016/drflux) -(require scheme/class "logic.ss" "view.ss" "controller.ss" "client.ss" "jabberer.ss") - -(define jid "plant0000001@fo.am") -(define pass "plant0000001") -(define pos (vector 50 0 0)) +#lang scheme/base +(require fluxus-016/drflux) +(require scheme/class "logic.ss" "view.ss" "controller.ss" "client.ss" "jabberer.ss" "list-utils.ss") ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ; p l a n t e y e s @@ -39,48 +35,122 @@ ; * in the same way, the line segments can be created in any way by the logic ; side - eg. lsystem, or different methods per plant (or per twig even) -(define logic-tick 0.5) ; time between logic updates +(define-struct player-info (jid pass tex pos col)) + +(define gui-game-mode% + (class object% + (field + (players (list + (make-player-info "plant0000001@fo.am" "plant0000001" + "textures/plant0000001.png" (vector 0 0 0) (vector 0.5 1 0.5)) + (make-player-info "plant0000002@fo.am" "plant0000002" + "textures/plant0000002.png" (vector -100 0 0) (vector 0.5 1 0)) + (make-player-info "plant0000003@fo.am" "plant0000003" + "textures/plant0000003.png" (vector 0 0 -100) (vector 0 1 0.5)) + (make-player-info "plant0000004@fo.am" "plant0000004" + "textures/plant0000004.png" (vector 50 0 50) (vector 0.75 1 0.5)) + (make-player-info "plant0000005@fo.am" "plant0000005" + "textures/plant0000005.png" (vector 50 9 -50) (vector 0.5 1 0.75)) + )) + (seeds '()) + (clicked -1)) + + (define/public (get-player-info) + (list-ref players clicked)) + + (define/public (setup) + (let ((c 0)) + (set! seeds (map + (lambda (pi) + (with-state + (translate (vmul (vector (sin (* 2 3.141 (/ c (length players)))) + (cos (* 2 3.141 (/ c (length players)))) 0) 4)) + (texture (load-texture (player-info-tex pi))) + (colour (player-info-col pi)) + (set! c (+ c 1)) + (load-primitive "meshes/seed.obj"))) + players)))) + + (define/public (update t d) + (for-each + (lambda (seed) + (with-primitive seed + (rotate (vector 0 1 0)))) + seeds) + (cond + ((mouse-button 1) + (let ((o (mouse-over))) + (cond + (o + (set! clicked (which-element o seeds 0)) + (when clicked + (for-each + (lambda (seed) + (destroy seed)) + seeds)) + (if clicked #t #f)) + (else + #f)))) + (else + #f))) + + (super-new))) + + +(define main-game-mode% + (class object% + (field + (gl (make-object game-logic%)) + (gv (make-object game-view%)) + (c (make-object controller% gv)) + (cl #f) + (tick-time 0) + (player #f) + (logic-tick 0.5)) ; time between logic updates + + (define/public (setup pi) + (set! cl (make-object client% (player-info-jid pi) (player-info-pass pi))) + (set! player (make-object plant-logic% + (player-info-jid pi) + (player-info-pos pi) + (player-info-col pi) + (player-info-tex pi))) + (send c set-player-plant player) + (send gl add-player player) + (send c setup) + (send gv setup) + (send gl setup) + (send cl setup)) + + (define/public (update t d) + (when (< tick-time t) + (send player grow (vmul (send c get-fwd) -1)) + + (let ((messages (send gl update))) + ; pass the messages to the network client + (send gv update t d (send cl update messages gl))) ; and the game view + + (set! tick-time (+ t logic-tick))) + + (send gv update t d '()) + (send c update)) + + (super-new))) (clear) -(define gl (make-object game-logic%)) -(define gv (make-object game-view%)) -(define c (make-object controller% gv)) -(define cl (make-object client% jid pass)) - -(send c setup) -(send gv setup) -(send gl setup) -(send cl setup) - -(define tick-time 0) -(define pt 0) -(define pd 0.02) -(define (pe-time) pt) -(define (pe-delta) pd) -(define (pt-update) (set! pt (+ pt pd))) - -(define player (make-object plant-logic% jid pos)) -(send c set-player-plant player) -(send gl add-player player) +(define mode 'gui) +(define gui (make-object gui-game-mode%)) +(define game (make-object main-game-mode%)) +(send gui setup) (define (animate) - (when (< tick-time (pe-time)) - (send player grow (vmul (send c get-fwd) -1)) + (cond + ((eq? mode 'gui) + (when (send gui update (flxtime) (delta)) + (send game setup (send gui get-player-info)) + (set! mode 'game))) + ((eq? mode 'game) + (send game update (flxtime) (delta))))) - (let ((messages (send gl update))) - ; pass the messages to the network client - (send gv update (pe-time) (pe-delta) (send cl update messages gl))) ; and the game view - - (set! tick-time (+ (pe-time) logic-tick))) - - (send gv update (pe-time) (pe-delta) '()) - (send c update) - (pt-update) - (sleep 0.01)) - -#;(for ((i (in-range 0 100000))) - ; (sleep 0.4) - (animate)) - (every-frame (animate)) diff --git a/plant-eyes/textures/plant0000001.png b/plant-eyes/textures/plant0000001.png new file mode 100644 index 0000000..66b0864 Binary files /dev/null and b/plant-eyes/textures/plant0000001.png differ diff --git a/plant-eyes/textures/plant0000002.png b/plant-eyes/textures/plant0000002.png new file mode 100644 index 0000000..0824e7b Binary files /dev/null and b/plant-eyes/textures/plant0000002.png differ diff --git a/plant-eyes/textures/plant0000003.png b/plant-eyes/textures/plant0000003.png new file mode 100644 index 0000000..1abc9d6 Binary files /dev/null and b/plant-eyes/textures/plant0000003.png differ diff --git a/plant-eyes/textures/plant0000004.png b/plant-eyes/textures/plant0000004.png new file mode 100644 index 0000000..b7b7dd0 Binary files /dev/null and b/plant-eyes/textures/plant0000004.png differ diff --git a/plant-eyes/textures/plant0000005.png b/plant-eyes/textures/plant0000005.png new file mode 100644 index 0000000..db29d9b Binary files /dev/null and b/plant-eyes/textures/plant0000005.png differ diff --git a/plant-eyes/textures/star.png b/plant-eyes/textures/star.png new file mode 100644 index 0000000..ef82ba1 Binary files /dev/null and b/plant-eyes/textures/star.png differ diff --git a/plant-eyes/view.ss b/plant-eyes/view.ss index 7738bfc..c2d0c76 100644 --- a/plant-eyes/view.ss +++ b/plant-eyes/view.ss @@ -121,7 +121,9 @@ (index 0) (parent-twig-id -1) (child-twig-ids '()) - (ornaments '())) + (ornaments '()) + (col (vector 1 1 1)) + (tex "")) (define/public (get-id) id) @@ -129,8 +131,17 @@ (define/public (get-dir) dir) + (define/public (set-col! s) + (set! col s)) + + (define/public (set-tex! s) + (set! tex s)) + (define/public (build) 0) + + (define/public (get-num-points) + index) (define/public (set-pos! s) (set! pos s)) @@ -185,7 +196,7 @@ (define ribbon-twig-view% (class twig-view% - (inherit-field pos radius num-points index) + (inherit-field pos radius num-points index col tex) (field (root 0)) @@ -193,8 +204,8 @@ (define/override (build) (set! root (let ((p (with-state (translate pos) - (colour (vector 0.8 1 0.6)) - (texture (load-texture "textures/root.png")) + (colour col) + (texture (load-texture tex)) (build-ribbon num-points)))) (with-primitive p (pdata-map! @@ -238,7 +249,7 @@ (define extruded-twig-view% (class twig-view% - (inherit-field index radius num-points pos dir) + (inherit-field index radius num-points pos dir col tex) (field (profile '()) @@ -257,9 +268,9 @@ (when wire-mode (hint-none) (hint-wire)) - (texture (load-texture "textures/root2.png")) + (texture (load-texture tex)) ;(opacity 0.6) - (colour (vmul (vector 0.8 1 0.6) 2)) + (colour (vmul col 2)) #;(colour (vector 1 1 1)) #;(texture (load-texture "textures/root.png")) (build-partial-extrusion profile path 3)))) @@ -302,7 +313,9 @@ (init-field (id "none") (pos (vector 0 0 0)) - (size 0)) + (size 0) + (col (vector 1 1 1)) + (tex "ooo")) (field (twigs '()) ; a assoc list map between ids and twigs stored flat here, @@ -312,10 +325,10 @@ (build-locator))) (seed (with-state (parent root) - (texture (load-texture "textures/root2.png")) + (texture (load-texture tex)) (backfacecull 0) (opacity 0.6) - (colour (vector 0.8 1 0.6)) + (colour col) (hint-depth-sort) (printf "size=~a~n" size) (scale (* 0.12 size)) @@ -323,11 +336,40 @@ (hint-none) (hint-wire)) ;(hint-unlit) - (load-primitive "meshes/seed.obj")))) + (load-primitive "meshes/seed.obj"))) + (nutrients (let ((p (with-state + (hint-depth-sort) + (hint-unlit) + (parent root) + (texture (load-texture "textures/star.png")) + (build-particles 100)))) + (with-primitive p + (pdata-add "twig" "f") + (pdata-add "point" "f") + (pdata-map! + (lambda (point) + 0) + "point") + (pdata-map! + (lambda (c) + (rndvec)) + "c") + (pdata-map! + (lambda (p) + (vmul (vadd (crndvec) (vector 0 -1 0)) 900)) + "p") + (pdata-map! + (lambda (s) + (vmul (vector 4 4 4) (+ 0.1 (rndf)))) + "s")) + p))) (define/public (get-id) id) + (define/public (get-col) + col) + (define/public (get-twig twig-id) (let ((l (assq twig-id twigs))) (if l @@ -338,7 +380,9 @@ ; attach to seed (with-primitive (send twig get-root) (parent root)) - (send twig build) + (send twig set-col! col) + (send twig set-tex! tex) + (send twig build) (set! twigs (cons (list (send twig get-id) twig) twigs))) (define/public (destroy-branch-twig twig-id) @@ -353,10 +397,11 @@ (let ((ptwig (get-twig parent-twig-id))) ; attach to parent twig (send twig set-pos! (send ptwig get-point point-index)) + (send twig set-col! col) + (send twig set-tex! tex) (send twig build) (with-primitive (send twig get-root) (parent (send ptwig get-root))) - ; tell the twigs about this relationship (might turn out to be overkill) (send ptwig add-child-twig-id (send twig get-id)) @@ -372,9 +417,36 @@ (define/public (add-ornament twig-id point-index property) (send (get-twig twig-id) add-ornament point-index property)) - + + (define/public (update-nutrients t d) + #;(with-primitive nutrients + (pdata-map! + (lambda (p) + (rndvec)) + "p")) + (when (not (null? twigs)) + (with-primitive nutrients + (pdata-index-map! + (lambda (i p twig-id point) + (let* ((twig-id (inexact->exact twig-id)) + (twig (get-twig twig-id)) + (point (inexact->exact point))) + (cond + ((or (< point 1) (not twig)) + (let* ((new-twig (choose twigs)) + (new-point (random (send (cadr new-twig) get-num-points)))) + (pdata-set! "twig" i (car new-twig)) + (pdata-set! "point" i new-point) + (send (cadr new-twig) get-point new-point))) + ((< (vdist (send twig get-point point) p) 0.1) + (pdata-set! "point" i (- point 1)) + (vadd p (vmul (vnormalise (vsub (send twig get-point (- point 1)) p)) 0.04))) + (else + (vadd p (vmul (vnormalise (vsub (send twig get-point point) p)) 0.04)))))) + "p" "twig" "point")))) + (define/public (update t d) - + (update-nutrients t d) (with-primitive seed (scale (+ 1 (* 0.001 (sin (* 2 t)))))) @@ -479,21 +551,7 @@ (translate (vector 0 -0.22001 0)) (build-env-box "textures/floor.png" "textures/earth-bottom.png" "textures/earth-side.png" "textures/earth-side.png" - "textures/earth-side.png" "textures/earth-side.png" #t))) - (nutrients (let ((p (with-state - (hint-depth-sort) - (texture (load-texture "textures/particle.png")) - (build-particles 5000)))) - (with-primitive p - (pdata-map! - (lambda (p) - (vmul (vadd (crndvec) (vector 0 -1 0)) 900)) - "p") - (pdata-map! - (lambda (s) - (vector 1 1 1)) - "s")) - p))) + "textures/earth-side.png" "textures/earth-side.png" #t)))) (define/public (setup) (let ((l (make-light 'point 'free))) @@ -562,14 +620,18 @@ (add-plant (make-object plant-view% (send msg get-data 'plant-id) (send msg get-data 'pos) - (send msg get-data 'size)))) + (send msg get-data 'size) + (send msg get-data 'col) + (send msg get-data 'tex)))) ((eq? (send msg get-name) 'new-plant) (printf "adding new plant to view ~a~n" (send msg get-data 'plant-id)) (add-plant (make-object plant-view% (send msg get-data 'plant-id) (send msg get-data 'pos) - (send msg get-data 'size)))) + (send msg get-data 'size) + (send msg get-data 'col) + (send msg get-data 'tex)))) ((eq? (send msg get-name) 'grow-seed) (grow-seed (send msg get-data 'plant-id)