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

8
plant-eyes/jabberer.ss
View file

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

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

@ -34,4 +34,11 @@
(cond
((null? l) "")
(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
(inherit send-message)
(define/public (set-pos s)
(set! last-point s))
(define/public (get-id)
id)
@ -127,7 +124,7 @@
(set! dir ndir)
(set! w (* width (- 1 (/ (length points) num-points))))
(set! last-point new-point)
(set! points (append points (list new-point)))
(set! widths (append widths (list w)))
@ -371,7 +368,6 @@
(set! size (* size grow-amount))
(send twig scale size)
(send twig set-branch! #t)
(send twig set-pos pos)
(send-message 'grow-seed (list
(list 'plant-id id)
@ -442,7 +438,8 @@
(class game-logic-object%
(field
(plants '())
(pickups '()))
(pickups '())
(player #f))
(inherit send-message)
@ -452,13 +449,15 @@
(vmul (srndvec) pickup-dist-radius)))))
(define/public (add-player plant)
(printf "new player plant added~n")
(send-message 'player-plant (list
(list 'plant-id (send plant get-id))
(list 'pos (send plant get-pos))))
(set! plants (cons plant plants)))
(list 'pos (send plant get-pos))
(list 'size (send plant get-size))))
(set! player plant)
(set! plants (cons plant plants)))
(define/public (add-plant plant)
(printf "new-plant added~n")
(send-message 'new-plant (list
(list 'plant-id (send plant get-id))
(list 'pos (send plant get-pos))
@ -473,6 +472,13 @@
(list 'pos (send pickup get-pos))))
(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
; this to a random selection of pickups/plants

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

@ -1,10 +1,10 @@
#lang scheme/base
(require fluxus-016/drflux)
(require scheme/class "logic.ss" "view.ss" "controller.ss" "client.ss")
(require "jabberer.ss")
(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))
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; p l a n t e y e s
@ -53,27 +53,26 @@
(send gl 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 pt 0)
(define pd 0.02)
(define (pe-time) pt)
(define (pe-delta) 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)))
; pass the messages to the network client
(send gv update (pe-time) (pe-delta) (send cl update messages gl)))) ; and the game view
; 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)