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

more networking, join game stuff works with preset jid. also fixed the camera and root points coordinate system bugs shown up by having plants with different positions

Browse source
This commit is contained in:
Dave Griffiths 2009-07-22 16:35:15 +01:00
parent 61ca4a0e6e
commit 74280d9200
5 changed files with 83 additions and 72 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

87
plant-eyes/controller.ss
View file

@ -8,7 +8,7 @@
(class object% (class object%
(init-field (init-field
(game-view #f)) (game-view #f))
(field (field
(fwd (vector 0 0 1)) (fwd (vector 0 0 1))
(up (vector 0 1 0)) (up (vector 0 1 0))
@ -20,9 +20,12 @@
(current-point 0) (current-point 0)
(tilt 0) (tilt 0)
(yaw 0) (yaw 0)
(player-plant #f)) (player-plant #f)
(player-pos (vector 0 0 0)))
(define/public (set-player-plant s) (define/public (set-player-plant s)
(set! pos (send s get-pos))
(set! player-pos (send s get-pos))
(set! player-plant s)) (set! player-plant s))
(define/public (get-cam-obj) (define/public (get-cam-obj)
@ -46,80 +49,80 @@
(define/public (update) (define/public (update)
(when (key-pressed-this-frame " ") (when (key-pressed-this-frame " ")
(cond ((and current-twig (not current-twig-growing)) (cond ((and current-twig (not current-twig-growing))
(let ((new-twig (send current-twig add-twig current-point (let ((new-twig (send current-twig add-twig current-point
(vector 0 1 0) #;(vsub (send current-twig get-point current-point) (vector 0 1 0) #;(vsub (send current-twig get-point current-point)
(send current-twig get-point (- current-point 1)))))) (send current-twig get-point (- current-point 1))))))
(set! current-twig-growing #t) (set! current-twig-growing #t)
(set! current-twig new-twig))) (set! current-twig new-twig)))
(else (else
(set! current-twig (make-object twig-logic% (vector 0 0 0) 0 player-plant 'root (set! current-twig (make-object twig-logic% (vector 0 0 0) 0 player-plant 'root
(vmul fwd -1) (vmul fwd -1)
start-twig-width max-twig-points 'extruded)) start-twig-width max-twig-points 'extruded))
(send player-plant add-twig current-twig) (send player-plant add-twig current-twig)
(set! current-twig-growing #t)))) (set! current-twig-growing #t))))
(when (or (key-pressed "a") (key-special-pressed 100)) (set! yaw (+ yaw 2))) (when (or (key-pressed "a") (key-special-pressed 100)) (set! yaw (+ yaw 2)))
(when (or (key-pressed "d") (key-special-pressed 102)) (set! yaw (- yaw 2))) (when (or (key-pressed "d") (key-special-pressed 102)) (set! yaw (- yaw 2)))
(when (or (key-pressed "w") (key-special-pressed 101)) (set! tilt (+ tilt 2))) (when (or (key-pressed "w") (key-special-pressed 101)) (set! tilt (- tilt 2)))
(when (or (key-pressed "s") (key-special-pressed 103)) (set! tilt (- tilt 2))) (when (or (key-pressed "s") (key-special-pressed 103)) (set! tilt (+ tilt 2)))
; clamp tilt to prevent gimbal lock ; clamp tilt to prevent gimbal lock
(when (> tilt 88) (set! tilt 88)) (when (> tilt 88) (set! tilt 88))
(when (< tilt -88) (set! tilt -88)) (when (< tilt -88) (set! tilt -88))
(when (not current-twig-growing) (when (not current-twig-growing)
(when (key-pressed-this-frame "q") (when (key-pressed-this-frame "q")
(cond ((not current-twig) (cond ((not current-twig)
(set! current-twig (send player-plant get-twig-from-dir (vmul fwd -1))) (set! current-twig (send player-plant get-twig-from-dir (vmul fwd -1)))
(set! current-point 2)) (set! current-point 2))
(else (else
(when (< current-point (- (send current-twig get-num-points) 1)) (when (< current-point (- (send current-twig get-num-points) 1))
(set! current-point (+ current-point 1)))))) (set! current-point (+ current-point 1))))))
(when (key-pressed-this-frame "z")
(cond (current-twig
(set! current-point (- current-point 1))
(when (< current-point 2)
(set! current-twig #f)
(set! pos player-pos)
#;(set-camera-transform (mtranslate (vector 0 0 -1))))))))
; get camera fwd vector from key-presses
(set! fwd (vtransform (vector 0 0 1)
(mmul
(mrotate (vector 0 yaw 0))
(mrotate (vector tilt 0 0)))))
(when (key-pressed-this-frame "z")
(cond (current-twig
(set! current-point (- current-point 1))
(when (< current-point 2)
(set! current-twig #f)
(set! pos (vector 0 0 0))
#;(set-camera-transform (mtranslate (vector 0 0 -1))))))))
; get camera fwd vector from key-presses
(set! fwd (vtransform (vector 0 0 1)
(mmul
(mrotate (vector 0 yaw 0))
(mrotate (vector tilt 0 0)))))
; if we are on a twig not growing ; if we are on a twig not growing
(cond ((and current-twig (not current-twig-growing)) (cond ((and current-twig (not current-twig-growing))
(set! pos (send current-twig get-point current-point)) (set! pos (vadd player-pos (send current-twig get-point current-point)))
#;(when (> current-point 0) #;(when (> current-point 0)
(set! fwd (vmix fwd (vnormalise (vsub (send current-twig get-point (set! fwd (vmix fwd (vnormalise (vsub (send current-twig get-point
(- current-point 1)) (- current-point 1))
pos)) 0.5)))) pos)) 0.5))))
(else (else
(when current-twig-growing (when current-twig-growing
(let ((twig-view (send (send game-view get-plant (send player-plant get-id)) (let ((twig-view (send (send game-view get-plant (send player-plant get-id))
get-twig (send current-twig get-id)))) get-twig (send current-twig get-id))))
(when twig-view (when twig-view
(set! pos (vsub (send twig-view get-end-pos) (set! pos (vadd player-pos (vsub (send twig-view get-end-pos)
(vmul (send current-twig get-dir) 1))))) (vmul (send current-twig get-dir) 1))))))
(when (eq? (send current-twig get-num-points) (when (eq? (send current-twig get-num-points)
(send current-twig get-length)) (send current-twig get-length))
(set! current-twig-growing #f) (set! current-twig-growing #f)
(set! current-point (- (send current-twig get-num-points) 1)))))) (set! current-point (- (send current-twig get-num-points) 1))))))
(let* ((side (vnormalise (vcross up fwd))) (let* ((side (vnormalise (vcross up fwd)))
(up (vnormalise (vcross fwd side)))) (up (vnormalise (vcross fwd side))))
(with-primitive cam (with-primitive cam
(identity) (identity)
(concat (vector (vx side) (vy side) (vz side) 0 (concat (vector (vx side) (vy side) (vz side) 0
(vx up) (vy up) (vz up) 0 (vx up) (vy up) (vz up) 0
(vx fwd) (vy fwd) (vz fwd) 0 (vx fwd) (vy fwd) (vz fwd) 0
(vx pos) (vy pos) (vz pos) 1))))) (vx pos) (vy pos) (vz pos) 1)))))
(super-new))) (super-new)))

8
plant-eyes/jabberer.ss
View file

@ -53,12 +53,8 @@
(let loop () (let loop ()
(when debug-netloop (printf ".~n")) (when debug-netloop (printf ".~n"))
(when (not (null? outgoing)) (when (not (null? outgoing))
(for-each (xmpp:send (xmpp:message (car (car outgoing)) (cadr (car outgoing))))
(lambda (msg) (set! outgoing (cdr outgoing)))
(when debug-jab (printf "tx ----> ~a ~a~n" (car msg) (cadr msg)))
(xmpp:send (xmpp:message (car msg) (cadr msg))))
outgoing)
(set! outgoing '()))
(sleep 0.5) (sleep 0.5)
(loop)))) (loop))))
(super-new))) (super-new)))

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

@ -34,4 +34,11 @@
(cond (cond
((null? l) "") ((null? l) "")
(else (else
(string-append (car l) t (list-string-concat (cdr l) t))))) (string-append (car l) t (list-string-concat (cdr l) t)))))
; returns a list of items in a but not in b
(define (list-remainder a b)
(cond
((null? a) '())
((not (list-contains (car a) b)) (cons (car a) (list-remainder (cdr a) b)))
(else (list-remainder (cdr a) b))))

24
plant-eyes/logic.ss
View file

@ -74,9 +74,6 @@
(curl (vmul (crndvec) curl-amount))) ; the angles to turn each point, if curly (curl (vmul (crndvec) curl-amount))) ; the angles to turn each point, if curly
(inherit send-message) (inherit send-message)
(define/public (set-pos s)
(set! last-point s))
(define/public (get-id) (define/public (get-id)
id) id)
@ -127,7 +124,7 @@
(set! dir ndir) (set! dir ndir)
(set! w (* width (- 1 (/ (length points) num-points)))) (set! w (* width (- 1 (/ (length points) num-points))))
(set! last-point new-point) (set! last-point new-point)
(set! points (append points (list new-point))) (set! points (append points (list new-point)))
(set! widths (append widths (list w))) (set! widths (append widths (list w)))
@ -371,7 +368,6 @@
(set! size (* size grow-amount)) (set! size (* size grow-amount))
(send twig scale size) (send twig scale size)
(send twig set-branch! #t) (send twig set-branch! #t)
(send twig set-pos pos)
(send-message 'grow-seed (list (send-message 'grow-seed (list
(list 'plant-id id) (list 'plant-id id)
@ -442,7 +438,8 @@
(class game-logic-object% (class game-logic-object%
(field (field
(plants '()) (plants '())
(pickups '())) (pickups '())
(player #f))
(inherit send-message) (inherit send-message)
@ -452,13 +449,15 @@
(vmul (srndvec) pickup-dist-radius))))) (vmul (srndvec) pickup-dist-radius)))))
(define/public (add-player plant) (define/public (add-player plant)
(printf "new player plant added~n")
(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))
(set! plants (cons plant plants))) (list 'size (send plant get-size))))
(set! player plant)
(set! plants (cons plant plants)))
(define/public (add-plant plant) (define/public (add-plant plant)
(printf "new-plant added~n")
(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))
@ -473,6 +472,13 @@
(list 'pos (send pickup get-pos)))) (list 'pos (send pickup get-pos))))
(set! pickups (cons pickup pickups))) (set! pickups (cons pickup pickups)))
(define/public (get-player-plant-desc)
(list (make-object message% 'new-plant (list
(list 'plant-id (send player get-id))
(list 'pos (send player get-pos))
(list 'size (send player get-size))))))
; todo - distribute the checking of stuff like ; todo - distribute the checking of stuff like
; this to a random selection of pickups/plants ; this to a random selection of pickups/plants

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

@ -1,10 +1,10 @@
#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") (require scheme/class "logic.ss" "view.ss" "controller.ss" "client.ss" "jabberer.ss")
(require "jabberer.ss")
(define jid "plant0000001@fo.am") (define jid "plant0000001@fo.am")
(define pass "plant0000001") (define pass "plant0000001")
(define pos (vector 50 0 0))
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; p l a n t e y e s ; p l a n t e y e s
@ -53,27 +53,26 @@
(send gl setup) (send gl setup)
(send cl setup) (send cl setup)
(define plant1 (make-object plant-logic% jid (vector 0 0 0)))
(send c set-player-plant plant1)
(send gl add-plant plant1)
(define tick-time 0) (define tick-time 0)
(define pt 0) (define pt 0)
(define pd 0.02) (define pd 0.02)
(define (pe-time) pt) (define (pe-time) pt)
(define (pe-delta) pd) (define (pe-delta) pd)
(define (pt-update) (set! pt (+ pt pd))) (define (pt-update) (set! pt (+ pt pd)))
(define (animate) (define player (make-object plant-logic% jid pos))
(send c set-player-plant player)
(send gl add-player player)
(define (animate)
(when (< tick-time (pe-time))
(send player grow (vmul (send c get-fwd) -1))
(when (< tick-time (pe-time))
(set! tick-time (+ (pe-time) logic-tick))
(send plant1 grow (vmul (send c get-fwd) -1))
(let ((messages (send gl update))) (let ((messages (send gl update)))
; pass the messages to the network client ; 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 (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 gv update (pe-time) (pe-delta) '())
(send c update) (send c update)