Merge branch 'master' of ssh://dave@fo.am/git/groworld
Conflicts: plant-eyes/plant-eyes.scm
This commit is contained in:
foam
commit
a3086e5141
12 changed files with 236 additions and 82 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -42,3 +42,9 @@
|
|||
((null? a) '())
|
||||
((not (list-contains (car a) b)) (cons (car a) (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)))))
|
||||
|
|
@ -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
|
||||
|
|
@ -317,6 +319,12 @@
|
|||
(define/public (get-size)
|
||||
size)
|
||||
|
||||
(define/public (get-col)
|
||||
col)
|
||||
|
||||
(define/public (get-tex)
|
||||
tex)
|
||||
|
||||
(define/public (grow dir)
|
||||
(for-each
|
||||
(lambda (twig)
|
||||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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 "plant0000002@fo.am")
|
||||
(define pass "plant0000002")
|
||||
(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))
|
||||
|
||||
(clear)
|
||||
(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 gl (make-object game-logic%))
|
||||
(define gv (make-object game-view%))
|
||||
(define c (make-object controller% gv))
|
||||
(define cl (make-object client% jid pass))
|
||||
(define/public (get-player-info)
|
||||
(list-ref players clicked))
|
||||
|
||||
(send c setup)
|
||||
(send gv setup)
|
||||
(send gl setup)
|
||||
(send cl setup)
|
||||
(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 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/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)))
|
||||
|
||||
(define player (make-object plant-logic% jid pos))
|
||||
(send c set-player-plant player)
|
||||
(send gl add-player player)
|
||||
(super-new)))
|
||||
|
||||
(define (animate)
|
||||
(when (< tick-time (pe-time))
|
||||
|
||||
(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 (pe-time) (pe-delta) (send cl update messages gl))) ; and the game view
|
||||
(send gv update t d (send cl update messages gl))) ; and the game view
|
||||
|
||||
(set! tick-time (+ (pe-time) logic-tick)))
|
||||
(set! tick-time (+ t logic-tick)))
|
||||
|
||||
(send gv update (pe-time) (pe-delta) '())
|
||||
(send c update)
|
||||
(pt-update)
|
||||
(sleep 0.01))
|
||||
(send gv update t d '())
|
||||
(send c update))
|
||||
|
||||
#;(for ((i (in-range 0 100000)))
|
||||
; (sleep 0.4)
|
||||
(animate))
|
||||
(super-new)))
|
||||
|
||||
(clear)
|
||||
|
||||
(define mode 'gui)
|
||||
(define gui (make-object gui-game-mode%))
|
||||
(define game (make-object main-game-mode%))
|
||||
(send gui setup)
|
||||
|
||||
(define (animate)
|
||||
(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)))))
|
||||
|
||||
(every-frame (animate))
|
||||
|
|
|
|||
BIN
plant-eyes/textures/plant0000001.png
Normal file
BIN
plant-eyes/textures/plant0000001.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 44 KiB |
BIN
plant-eyes/textures/plant0000002.png
Normal file
BIN
plant-eyes/textures/plant0000002.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 29 KiB |
BIN
plant-eyes/textures/plant0000003.png
Normal file
BIN
plant-eyes/textures/plant0000003.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 27 KiB |
BIN
plant-eyes/textures/plant0000004.png
Normal file
BIN
plant-eyes/textures/plant0000004.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 16 KiB |
BIN
plant-eyes/textures/plant0000005.png
Normal file
BIN
plant-eyes/textures/plant0000005.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 25 KiB |
BIN
plant-eyes/textures/star.png
Normal file
BIN
plant-eyes/textures/star.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 33 KiB |
|
|
@ -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,9 +131,18 @@
|
|||
(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,6 +380,8 @@
|
|||
; attach to seed
|
||||
(with-primitive (send twig get-root)
|
||||
(parent root))
|
||||
(send twig set-col! col)
|
||||
(send twig set-tex! tex)
|
||||
(send twig build)
|
||||
(set! twigs (cons (list (send twig get-id) twig) twigs)))
|
||||
|
||||
|
|
@ -353,11 +397,12 @@
|
|||
(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))
|
||||
(send twig set-parent-twig-id parent-twig-id)
|
||||
|
|
@ -373,8 +418,35 @@
|
|||
(define/public (add-ornament twig-id point-index property)
|
||||
(send (get-twig twig-id) add-ornament point-index property))
|
||||
|
||||
(define/public (update t d)
|
||||
(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)
|
||||
|
|
|
|||
Loading…
Reference in a new issue