started dealing with plant serialisation for network play
This commit is contained in:
parent
78255b9b86
commit
d1330587ae
4 changed files with 88 additions and 94 deletions
|
@ -37,6 +37,15 @@
|
|||
(send jab send-msg plant (send msg to-string))))
|
||||
recipients))
|
||||
|
||||
(define (heir-send from l)
|
||||
(for-each
|
||||
(lambda (msg)
|
||||
(cond ((not (list? msg))
|
||||
(send-msg (list from) msg))
|
||||
(else
|
||||
(heir-send msg))))
|
||||
l))
|
||||
|
||||
(define (fetch-messages l game-logic)
|
||||
(cond ((not (send jab msg-waiting?)) l)
|
||||
(else
|
||||
|
@ -56,11 +65,7 @@
|
|||
(set! plants-present (cons (send msg get-data 'plant-id) plants-present))
|
||||
(send-msg (list from) (make-object message% 'i-am-here (list (list 'plant-id jid))))
|
||||
; send out our plant description messages
|
||||
(for-each
|
||||
(lambda (msg)
|
||||
(printf "sending plant info to ~a ~n" from)
|
||||
(send-msg (list from) msg))
|
||||
(send game-logic get-player-plant-desc))
|
||||
(heir-send from (send game-logic serialise))
|
||||
(fetch-messages l game-logic))
|
||||
((eq? name 'i-am-here)
|
||||
(set! plants-present (cons (send msg get-data 'plant-id) plants-present))
|
||||
|
|
|
@ -64,8 +64,8 @@
|
|||
(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 "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))
|
||||
|
|
|
@ -62,14 +62,15 @@
|
|||
(width 0) ; the width of this root
|
||||
(num-points max-twig-points) ; number of points in this twig
|
||||
(render-type 'extruded) ; the way to tell the view to render this twig
|
||||
(dist start-twig-dist)) ; distance between points
|
||||
(dist start-twig-dist) ; distance between points
|
||||
(parent-twig-id -1)
|
||||
(parent-twig-point-index -1))
|
||||
|
||||
(field
|
||||
(points '()) ; the 3d points for this twig
|
||||
(widths '())
|
||||
(twigs '()) ; children are stored with the point number they are connected to.
|
||||
(ornaments '()) ; the things attached to this twig, an assoc list with point index
|
||||
(branch #f) ; are we a main branch twig?
|
||||
(w 0) ; the width of this segment
|
||||
(curl (vmul (crndvec) curl-amount))) ; the angles to turn each point, if curly
|
||||
|
||||
|
@ -96,9 +97,6 @@
|
|||
(define/public (get-render-type)
|
||||
render-type)
|
||||
|
||||
(define/public (set-branch! s)
|
||||
(set! branch s))
|
||||
|
||||
(define/public (get-point point-index)
|
||||
(list-ref points point-index))
|
||||
|
||||
|
@ -118,7 +116,7 @@
|
|||
(when (< (length points) num-points)
|
||||
(let ((new-point (if (zero? (length points))
|
||||
; first point should be at edge of the seed if we are a branch
|
||||
(if branch (vadd last-point (vmul dir dist))
|
||||
(if (eq? parent-twig-id -1) (vadd last-point (vmul dir dist))
|
||||
last-point)
|
||||
(vadd last-point (vmul dir dist)))))
|
||||
|
||||
|
@ -141,6 +139,18 @@
|
|||
(send (cadr twig) grow ndir))
|
||||
twigs))
|
||||
|
||||
(define/public (get-desc-list)
|
||||
(list
|
||||
(list 'plant-id (send plant get-id))
|
||||
(list 'parent-twig-id parent-twig-id)
|
||||
(list 'point-index parent-twig-point-index)
|
||||
(list 'twig-id id)
|
||||
(list 'type type)
|
||||
(list 'dir dir)
|
||||
(list 'width width)
|
||||
(list 'num-points num-points)
|
||||
(list 'render-type render-type)))
|
||||
|
||||
(define/public (add-twig point-index dir)
|
||||
(let ((twig (make-object twig-logic%
|
||||
(get-point point-index)
|
||||
|
@ -151,22 +161,32 @@
|
|||
(list-ref widths point-index)
|
||||
(quotient num-points 2)
|
||||
render-type
|
||||
dist)))
|
||||
dist
|
||||
id
|
||||
point-index
|
||||
)))
|
||||
|
||||
(send-message 'new-twig (list
|
||||
(list 'plant-id (send plant get-id))
|
||||
(list 'parent-twig-id id)
|
||||
(list 'point-index point-index)
|
||||
(list 'twig-id (send twig get-id))
|
||||
(list 'type (send twig get-type))
|
||||
(list 'dir (send twig get-dir))
|
||||
(list 'width (send twig get-width))
|
||||
(list 'num-points (send twig get-num-points))
|
||||
(list 'render-type (send twig get-render-type))
|
||||
))
|
||||
(send-message 'new-twig (send twig get-desc-list))
|
||||
(set! twigs (cons (list point-index twig) twigs))
|
||||
twig))
|
||||
|
||||
(define/public (serialise)
|
||||
(append
|
||||
(list (make-object message% 'new-twig (get-desc-list)))
|
||||
(append (map
|
||||
(lambda (point width)
|
||||
(make-object message% 'twig-grow (list
|
||||
(list 'plant-id (send plant get-id))
|
||||
(list 'twig-id id)
|
||||
(list 'point point)
|
||||
(list 'width width))))
|
||||
points widths))
|
||||
(append
|
||||
(map
|
||||
(lambda (twig)
|
||||
(send (cadr twig) serialise))
|
||||
twigs))))
|
||||
|
||||
(define/public (get-twig point-index)
|
||||
(cadr (assq point-index twigs)))
|
||||
|
||||
|
@ -375,21 +395,10 @@
|
|||
(send twig set-id! (get-next-twig-id))
|
||||
(set! size (* size grow-amount))
|
||||
(send twig scale size)
|
||||
(send twig set-branch! #t)
|
||||
|
||||
(send-message 'grow-seed (list
|
||||
(list 'plant-id id)
|
||||
(list 'amount grow-amount)))
|
||||
(send-message 'new-branch-twig (list
|
||||
(list 'plant-id id)
|
||||
(list 'twig-id (send twig get-id))
|
||||
(list 'type (send twig get-type))
|
||||
(list 'dir (send twig get-dir))
|
||||
(list 'width (send twig get-width))
|
||||
(list 'num-points (send twig get-num-points))
|
||||
(list 'render-type (send twig get-render-type))
|
||||
))
|
||||
|
||||
(send-message 'new-twig (send twig get-desc-list))
|
||||
(set! twigs (cons-twig twig twigs max-twigs '())))
|
||||
|
||||
|
||||
|
@ -409,6 +418,16 @@
|
|||
(list -99 #f)
|
||||
twigs))))
|
||||
|
||||
(define/public (serialise)
|
||||
(append (list (make-object message% 'new-plant (list
|
||||
(list 'plant-id id)
|
||||
(list 'pos pos)
|
||||
(list 'size size))))
|
||||
(append
|
||||
(map
|
||||
(lambda (twig)
|
||||
(send twig serialise))
|
||||
twigs))))
|
||||
|
||||
(define/augment (update)
|
||||
; grow a new ornament?
|
||||
|
@ -484,13 +503,8 @@
|
|||
(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))))))
|
||||
|
||||
|
||||
(define/public (serialise)
|
||||
(send player serialise))
|
||||
|
||||
; todo - distribute the checking of stuff like
|
||||
; this to a random selection of pickups/plants
|
||||
|
|
|
@ -375,15 +375,6 @@
|
|||
(if l
|
||||
(cadr (assq twig-id twigs))
|
||||
#f)))
|
||||
|
||||
(define/public (add-branch-twig twig)
|
||||
; 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)))
|
||||
|
||||
(define/public (destroy-branch-twig twig-id)
|
||||
(for-each
|
||||
|
@ -393,21 +384,29 @@
|
|||
(send (get-twig twig-id) destroy-twig)
|
||||
(set! twigs (assoc-remove twig-id twigs)))
|
||||
|
||||
(define/public (add-twig parent-twig-id point-index twig)
|
||||
(define/public (destroy-plant)
|
||||
(destroy root)
|
||||
(for-each
|
||||
(lambda (twig)
|
||||
(destroy-branch-twig (car twig)))
|
||||
twigs))
|
||||
|
||||
(define/public (add-twig parent-twig-id point-index twig)
|
||||
(let ((ptwig (get-twig parent-twig-id)))
|
||||
; attach to parent twig
|
||||
(send twig set-pos! (send ptwig get-point point-index))
|
||||
(when ptwig
|
||||
(send twig set-pos! (send ptwig get-point point-index)) ; attach to parent twig
|
||||
; 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))
|
||||
|
||||
(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)
|
||||
|
||||
(set! twigs (cons (list (send twig get-id) twig) twigs))))
|
||||
(parent root))
|
||||
|
||||
(set! twigs (cons (list (send twig get-id) twig) twigs))))
|
||||
|
||||
(define/public (grow-twig twig-id point width)
|
||||
(send (get-twig twig-id) grow point width))
|
||||
|
@ -419,11 +418,6 @@
|
|||
(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!
|
||||
|
@ -564,15 +558,17 @@
|
|||
(fog fog-col fog-strength 1 100))
|
||||
|
||||
(define/public (add-plant plant)
|
||||
(destroy-plant (send plant get-id)) ; just in case
|
||||
(set! plants (cons (list (send plant get-id) plant) plants)))
|
||||
|
||||
(define/public (get-plant plant-id)
|
||||
(let ((p (assoc plant-id plants)))
|
||||
(when (not p) (error "plant id does not exist " plant-id))
|
||||
(cadr p)))
|
||||
(if (not p) #f (cadr p))))
|
||||
|
||||
(define/public (add-branch-twig plant-id twig)
|
||||
(send (get-plant plant-id) add-branch-twig twig))
|
||||
(define/public (destroy-plant plant-id)
|
||||
(let ((p (get-plant plant-id)))
|
||||
(when p (send p destroy-plant)
|
||||
(set! plants (assoc-remove plant-id plants)))))
|
||||
|
||||
(define/public (destroy-branch-twig plant-id twig-id)
|
||||
(send (get-plant plant-id) destroy-branch-twig twig-id))
|
||||
|
@ -638,28 +634,7 @@
|
|||
(send msg get-data 'amount)))
|
||||
|
||||
((eq? (send msg get-name) 'destroy-branch-twig)
|
||||
(destroy-branch-twig (send msg get-data 'plant-id) (send msg get-data 'twig-id)))
|
||||
|
||||
((eq? (send msg get-name) 'new-branch-twig)
|
||||
(add-branch-twig (send msg get-data 'plant-id)
|
||||
(cond
|
||||
((eq? (send msg get-data 'render-type) 'ribbon)
|
||||
(make-object ribbon-twig-view%
|
||||
(send msg get-data 'twig-id)
|
||||
(vector 0 0 0)
|
||||
(send msg get-data 'type)
|
||||
(send msg get-data 'dir)
|
||||
(send msg get-data 'width)
|
||||
(send msg get-data 'num-points)))
|
||||
|
||||
((eq? (send msg get-data 'render-type) 'extruded)
|
||||
(make-object extruded-twig-view%
|
||||
(send msg get-data 'twig-id)
|
||||
(vector 0 0 0)
|
||||
(send msg get-data 'type)
|
||||
(send msg get-data 'dir)
|
||||
(send msg get-data 'width)
|
||||
(send msg get-data 'num-points))))))
|
||||
(destroy-branch-twig (send msg get-data 'plant-id) (send msg get-data 'twig-id)))
|
||||
|
||||
((eq? (send msg get-name) 'new-twig)
|
||||
(add-twig (send msg get-data 'plant-id)
|
||||
|
|
Loading…
Reference in a new issue