FoAM/groworld
12
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

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

Browse source 
Conflicts:
	plant-eyes/plant-eyes.scm
This commit is contained in:
foam 2009-07-24 21:00:06 +01:00
commit a3086e5141
12 changed files with 236 additions and 82 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
plant-eyes/client.ss
View file

@ -18,6 +18,9 @@
"plant0000001@fo.am" "plant0000001@fo.am"
"plant0000002@fo.am" "plant0000002@fo.am"
"plant0000003@fo.am" "plant0000003@fo.am"
"plant0000004@fo.am"
"plant0000005@fo.am"
"dave@fo.am"
)) ))
(plants-present '()) (plants-present '())
(msg-filter (list 'new-pickup 'pick-up-pickup)) ; messages we don't want to send across the network (msg-filter (list 'new-pickup 'pick-up-pickup)) ; messages we don't want to send across the network

3
plant-eyes/jabberer.ss
View file

@ -53,8 +53,9 @@
(let loop () (let loop ()
(when debug-netloop (printf ".~n")) (when debug-netloop (printf ".~n"))
(when (not (null? outgoing)) (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)))) (xmpp:send (xmpp:message (car (car outgoing)) (cadr (car outgoing))))
(set! outgoing (cdr outgoing))) (set! outgoing (cdr outgoing)))
(sleep 0.5) (sleep 0.1)
(loop)))) (loop))))
(super-new))) (super-new)))

8
plant-eyes/list-utils.ss
View file

@ -41,4 +41,10 @@
(cond (cond
((null? a) '()) ((null? a) '())
((not (list-contains (car a) b)) (cons (car a) (list-remainder (cdr a) b))) ((not (list-contains (car a) b)) (cons (car a) (list-remainder (cdr a) b)))
(else (list-remainder (cdr a) b)))) (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)))))

18
plant-eyes/logic.ss
View file

@ -294,7 +294,9 @@
(class game-logic-object% (class game-logic-object%
(init-field (init-field
(id #f) (id #f)
(pos (vector 0 0 0))) (pos (vector 0 0 0))
(col (vector 1 1 1))
(tex "fff"))
(field (field
(twigs '()) ; a assoc list map of ages to twigs (twigs '()) ; a assoc list map of ages to twigs
@ -316,6 +318,12 @@
(define/public (get-size) (define/public (get-size)
size) size)
(define/public (get-col)
col)
(define/public (get-tex)
tex)
(define/public (grow dir) (define/public (grow dir)
(for-each (for-each
@ -453,7 +461,9 @@
(send-message 'player-plant (list (send-message 'player-plant (list
(list 'plant-id (send plant get-id)) (list 'plant-id (send plant get-id))
(list 'pos (send plant get-pos)) (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! player plant)
(set! plants (cons plant plants))) (set! plants (cons plant plants)))
@ -461,7 +471,9 @@
(send-message 'new-plant (list (send-message 'new-plant (list
(list 'plant-id (send plant get-id)) (list 'plant-id (send plant get-id))
(list 'pos (send plant get-pos)) (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))) (set! plants (cons plant plants)))
(define/public (add-pickup pickup) (define/public (add-pickup pickup)

160
plant-eyes/plant-eyes.scm
View file

@ -1,10 +1,6 @@
;#lang scheme/base #lang scheme/base
;(require fluxus-016/drflux) (require fluxus-016/drflux)
(require scheme/class "logic.ss" "view.ss" "controller.ss" "client.ss" "jabberer.ss") (require scheme/class "logic.ss" "view.ss" "controller.ss" "client.ss" "jabberer.ss" "list-utils.ss")
(define jid "plant0000002@fo.am")
(define pass "plant0000002")
(define pos (vector -50 0 0))
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; p l a n t e y e s ; 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 ; * 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) ; 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) (clear)
(define gl (make-object game-logic%)) (define mode 'gui)
(define gv (make-object game-view%)) (define gui (make-object gui-game-mode%))
(define c (make-object controller% gv)) (define game (make-object main-game-mode%))
(define cl (make-object client% jid pass)) (send gui setup)
(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 (animate) (define (animate)
(when (< tick-time (pe-time)) (cond
(send player grow (vmul (send c get-fwd) -1)) ((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)) (every-frame (animate))

BIN
plant-eyes/textures/plant0000001.png Normal file
View file

Binary file not shown.
Side by side

After

Width:  |  Height:  |  Size: 44 KiB

BIN
plant-eyes/textures/plant0000002.png Normal file
View file

Binary file not shown.
Side by side

After

Width:  |  Height:  |  Size: 29 KiB

BIN
plant-eyes/textures/plant0000003.png Normal file
View file

Binary file not shown.
Side by side

After

Width:  |  Height:  |  Size: 27 KiB

BIN
plant-eyes/textures/plant0000004.png Normal file
View file

Binary file not shown.
Side by side

After

Width:  |  Height:  |  Size: 16 KiB

BIN
plant-eyes/textures/plant0000005.png Normal file
View file

Binary file not shown.
Side by side

After

Width:  |  Height:  |  Size: 25 KiB

BIN
plant-eyes/textures/star.png Normal file
View file

Binary file not shown.
Side by side

After

Width:  |  Height:  |  Size: 33 KiB

126
plant-eyes/view.ss
View file

@ -121,7 +121,9 @@
(index 0) (index 0)
(parent-twig-id -1) (parent-twig-id -1)
(child-twig-ids '()) (child-twig-ids '())
(ornaments '())) (ornaments '())
(col (vector 1 1 1))
(tex ""))
(define/public (get-id) (define/public (get-id)
id) id)
@ -129,8 +131,17 @@
(define/public (get-dir) (define/public (get-dir)
dir) dir)
(define/public (set-col! s)
(set! col s))
(define/public (set-tex! s)
(set! tex s))
(define/public (build) (define/public (build)
0) 0)
(define/public (get-num-points)
index)
(define/public (set-pos! s) (define/public (set-pos! s)
(set! pos s)) (set! pos s))
@ -185,7 +196,7 @@
(define ribbon-twig-view% (define ribbon-twig-view%
(class twig-view% (class twig-view%
(inherit-field pos radius num-points index) (inherit-field pos radius num-points index col tex)
(field (field
(root 0)) (root 0))
@ -193,8 +204,8 @@
(define/override (build) (define/override (build)
(set! root (let ((p (with-state (set! root (let ((p (with-state
(translate pos) (translate pos)
(colour (vector 0.8 1 0.6)) (colour col)
(texture (load-texture "textures/root.png")) (texture (load-texture tex))
(build-ribbon num-points)))) (build-ribbon num-points))))
(with-primitive p (with-primitive p
(pdata-map! (pdata-map!
@ -238,7 +249,7 @@
(define extruded-twig-view% (define extruded-twig-view%
(class twig-view% (class twig-view%
(inherit-field index radius num-points pos dir) (inherit-field index radius num-points pos dir col tex)
(field (field
(profile '()) (profile '())
@ -257,9 +268,9 @@
(when wire-mode (when wire-mode
(hint-none) (hint-none)
(hint-wire)) (hint-wire))
(texture (load-texture "textures/root2.png")) (texture (load-texture tex))
;(opacity 0.6) ;(opacity 0.6)
(colour (vmul (vector 0.8 1 0.6) 2)) (colour (vmul col 2))
#;(colour (vector 1 1 1)) #;(colour (vector 1 1 1))
#;(texture (load-texture "textures/root.png")) #;(texture (load-texture "textures/root.png"))
(build-partial-extrusion profile path 3)))) (build-partial-extrusion profile path 3))))
@ -302,7 +313,9 @@
(init-field (init-field
(id "none") (id "none")
(pos (vector 0 0 0)) (pos (vector 0 0 0))
(size 0)) (size 0)
(col (vector 1 1 1))
(tex "ooo"))
(field (field
(twigs '()) ; a assoc list map between ids and twigs stored flat here, (twigs '()) ; a assoc list map between ids and twigs stored flat here,
@ -312,10 +325,10 @@
(build-locator))) (build-locator)))
(seed (with-state (seed (with-state
(parent root) (parent root)
(texture (load-texture "textures/root2.png")) (texture (load-texture tex))
(backfacecull 0) (backfacecull 0)
(opacity 0.6) (opacity 0.6)
(colour (vector 0.8 1 0.6)) (colour col)
(hint-depth-sort) (hint-depth-sort)
(printf "size=~a~n" size) (printf "size=~a~n" size)
(scale (* 0.12 size)) (scale (* 0.12 size))
@ -323,11 +336,40 @@
(hint-none) (hint-none)
(hint-wire)) (hint-wire))
;(hint-unlit) ;(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) (define/public (get-id)
id) id)
(define/public (get-col)
col)
(define/public (get-twig twig-id) (define/public (get-twig twig-id)
(let ((l (assq twig-id twigs))) (let ((l (assq twig-id twigs)))
(if l (if l
@ -338,7 +380,9 @@
; attach to seed ; attach to seed
(with-primitive (send twig get-root) (with-primitive (send twig get-root)
(parent 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))) (set! twigs (cons (list (send twig get-id) twig) twigs)))
(define/public (destroy-branch-twig twig-id) (define/public (destroy-branch-twig twig-id)
@ -353,10 +397,11 @@
(let ((ptwig (get-twig parent-twig-id))) (let ((ptwig (get-twig parent-twig-id)))
; attach to parent twig ; attach to parent twig
(send twig set-pos! (send ptwig get-point point-index)) (send twig set-pos! (send ptwig get-point point-index))
(send twig set-col! col)
(send twig set-tex! tex)
(send twig build) (send twig build)
(with-primitive (send twig get-root) (with-primitive (send twig get-root)
(parent (send ptwig get-root))) (parent (send ptwig get-root)))
; tell the twigs about this relationship (might turn out to be overkill) ; tell the twigs about this relationship (might turn out to be overkill)
(send ptwig add-child-twig-id (send twig get-id)) (send ptwig add-child-twig-id (send twig get-id))
@ -372,9 +417,36 @@
(define/public (add-ornament twig-id point-index property) (define/public (add-ornament twig-id point-index property)
(send (get-twig twig-id) add-ornament 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) (define/public (update t d)
(update-nutrients t d)
(with-primitive seed (with-primitive seed
(scale (+ 1 (* 0.001 (sin (* 2 t)))))) (scale (+ 1 (* 0.001 (sin (* 2 t))))))
@ -479,21 +551,7 @@
(translate (vector 0 -0.22001 0)) (translate (vector 0 -0.22001 0))
(build-env-box "textures/floor.png" "textures/earth-bottom.png" (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"
"textures/earth-side.png" "textures/earth-side.png" #t))) "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)))
(define/public (setup) (define/public (setup)
(let ((l (make-light 'point 'free))) (let ((l (make-light 'point 'free)))
@ -562,14 +620,18 @@
(add-plant (make-object plant-view% (add-plant (make-object plant-view%
(send msg get-data 'plant-id) (send msg get-data 'plant-id)
(send msg get-data 'pos) (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) ((eq? (send msg get-name) 'new-plant)
(printf "adding new plant to view ~a~n" (send msg get-data 'plant-id)) (printf "adding new plant to view ~a~n" (send msg get-data 'plant-id))
(add-plant (make-object plant-view% (add-plant (make-object plant-view%
(send msg get-data 'plant-id) (send msg get-data 'plant-id)
(send msg get-data 'pos) (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) ((eq? (send msg get-name) 'grow-seed)
(grow-seed (send msg get-data 'plant-id) (grow-seed (send msg get-data 'plant-id)