xmpp works, tidied up visually and internally
This commit is contained in:
Dave Griffiths
parent
9cc1c0e204
commit
09bfbe366c
|
|
@ -1,26 +1,38 @@
|
|||
;#lang scheme
|
||||
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||||
; h a y f e v e r
|
||||
|
||||
;(require fluxus-016/drflux)
|
||||
(require scheme/class)
|
||||
(require mzlib/string)
|
||||
(require openssl)
|
||||
|
||||
(require "xmpp-dave.ss")
|
||||
;(require (prefix-in xmpp: (planet zzkt/xmpp)))
|
||||
|
||||
(define plant2 #f)
|
||||
;(set! plant2 #t)
|
||||
|
||||
(define debug-jab #t)
|
||||
(define pollen-particles 300)
|
||||
(define max-pollen-radius 12)
|
||||
(define deterministic #f)
|
||||
(define minimal-mode #f)
|
||||
(define jid "plant0000003@fo.am")
|
||||
(define pass "plant0000003")
|
||||
(define jto "plant0000002@fo.am")
|
||||
|
||||
(when plant2
|
||||
(set! jid "plant0000002@fo.am")
|
||||
(set! pass "plant0000002")
|
||||
(set! jto "plant0000003@fo.am"))
|
||||
(set! jid "plant0000002@fo.am")
|
||||
(set! pass "plant0000002")
|
||||
(set! jto "plant0000003@fo.am"))
|
||||
|
||||
(printf "I am ~a~n" jid)
|
||||
|
||||
(when deterministic
|
||||
(flxseed 1)
|
||||
(random-seed 2))
|
||||
|
||||
|
||||
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||||
; pixel primitive things for getting connection points
|
||||
|
||||
|
|
@ -109,7 +121,10 @@
|
|||
(cond
|
||||
((null? children)
|
||||
(let ((root (with-state
|
||||
(translate (vector 0 0.5 (* 0.1 (rndf))))
|
||||
(translate (vector 0 0.5 (* 0.01 (rndf))))
|
||||
(hint-none)
|
||||
(hint-solid)
|
||||
(hint-unlit)
|
||||
(hint-depth-sort)
|
||||
(texture (load-texture (string-append "textures/comp-" id ".png")))
|
||||
(build-plane))))
|
||||
|
|
@ -119,7 +134,7 @@
|
|||
(root (with-state
|
||||
(hint-depth-sort)
|
||||
(translate (vector 0 0.5 (* 0.01 (rndf))))
|
||||
; (rotate (vector 0 0 90))
|
||||
; (rotate (vector 0 0 90))
|
||||
(texture (load-texture (string-append "textures/comp-" id ".png")))
|
||||
(build-plane)))
|
||||
(comp (make-component root col
|
||||
|
|
@ -158,13 +173,10 @@
|
|||
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||||
; utils for building random plants
|
||||
|
||||
(define (choose l)
|
||||
(list-ref l (random (length l))))
|
||||
|
||||
(define (make-random-plant depth)
|
||||
(let ((num-children (cond ((> depth 2) 0)
|
||||
((< depth 1) (choose (list 2 3)))
|
||||
(else (choose (list 0 1 2 3))))))
|
||||
((< depth 1) (choose (list 2 3)))
|
||||
(else (choose (list 0 1 2 3))))))
|
||||
(cond
|
||||
((eq? num-children 0) (list (choose (list "11")) (list)))
|
||||
((eq? num-children 1) (list "1-1" (list (make-random-plant (+ depth 1)))))
|
||||
|
|
@ -193,19 +205,19 @@
|
|||
(entity-list '())
|
||||
(id 0)
|
||||
(pollen 0)
|
||||
(my-id 0))
|
||||
(my-id ""))
|
||||
|
||||
(define/public (init)
|
||||
|
||||
(set! pollen (with-state
|
||||
(translate (vector 0 0 0.2))
|
||||
(texture (load-texture "textures/pollen.png"))
|
||||
(build-particles 100)))
|
||||
(build-particles pollen-particles)))
|
||||
|
||||
(with-primitive pollen
|
||||
(pdata-map!
|
||||
(lambda (p)
|
||||
(vmul (srndvec) 5))
|
||||
(vmul (vector (crndf) (crndf) 0) 5))
|
||||
"p")
|
||||
(pdata-map!
|
||||
(lambda (c)
|
||||
|
|
@ -224,16 +236,23 @@
|
|||
my-id)
|
||||
|
||||
(define/public (make-my-plant)
|
||||
|
||||
(when deterministic
|
||||
(flxseed 3)
|
||||
(random-seed 10) ; 2 5
|
||||
)
|
||||
|
||||
|
||||
(let* ((pos (vector (* (crndf) 5) 0 0.1))
|
||||
(col (hsv->rgb (vector (rndf) 0.8 1)))
|
||||
(desc (list (make-random-plant 0))))
|
||||
(set! my-id (length entity-list))
|
||||
(set! my-id jid)
|
||||
(set-entity my-id (make-object plant% pos col desc))))
|
||||
|
||||
(define/public (get-entity id)
|
||||
(foldl
|
||||
(lambda (entity ret)
|
||||
(if (eq? (send entity get-id) id)
|
||||
(if (string=? (send entity get-id) id)
|
||||
entity
|
||||
ret))
|
||||
#f
|
||||
|
|
@ -252,11 +271,22 @@
|
|||
(send entity set-id! id)
|
||||
(set! entity-list (cons entity entity-list)))
|
||||
|
||||
|
||||
(define/public (destroy-all-but-me)
|
||||
(set! entity-list
|
||||
(filter
|
||||
(lambda (entity)
|
||||
(cond ((not (string=? (send entity get-id) my-id))
|
||||
(send entity destroy-me)
|
||||
#f)
|
||||
(else #t)))
|
||||
entity-list)))
|
||||
|
||||
(define/public (destroy-entity id)
|
||||
(set! entity-list
|
||||
(filter
|
||||
(lambda (entity)
|
||||
(cond ((eq? (send entity get-id) id)
|
||||
(cond ((string=? (send entity get-id) id)
|
||||
(send entity destroy-me)
|
||||
#f)
|
||||
(else #t)))
|
||||
|
|
@ -280,14 +310,14 @@
|
|||
(define (animate-pollen)
|
||||
(pdata-map!
|
||||
(lambda (p)
|
||||
(let* ((pp (vadd (vmul p 1) (vector 0 (- (time)) 0)))
|
||||
(let* ((pp (vadd (vmul p 1) (vector 0 (- (flxtime)) 0)))
|
||||
(v (cond
|
||||
((< (vy p) 0) (vmul (vector (crndf) 1 (crndf)) 0.1))
|
||||
((> (vmag p) 8) (vmul p -0.1))
|
||||
(else
|
||||
(vector (- (noise (vx pp) (vy pp) (vz pp)) 0.5)
|
||||
(- (noise (vx pp) (+ (vy pp) 112.3) (vz pp)) 0.5)
|
||||
(- (noise (+ (vx pp) 393.2) (vy pp) (vz pp)) 0.5))))))
|
||||
((< (vy p) 0) (vmul (vector (crndf) 1 (crndf)) 0.1))
|
||||
((> (vmag p) max-pollen-radius) (vmul p -0.1))
|
||||
(else
|
||||
(vector (- (noise (vx pp) (vy pp) (vz pp)) 0.5)
|
||||
(- (noise (vx pp) (+ (vy pp) 112.3) (vz pp)) 0.5)
|
||||
0 #;(- (noise (+ (vx pp) 393.2) (vy pp) (vz pp)) 0.5))))))
|
||||
(vadd (vadd p (vmul v 0.2))
|
||||
(vmul (srndvec) 0.01))))
|
||||
"p"))
|
||||
|
|
@ -302,7 +332,8 @@
|
|||
(let ((c (random (pdata-size)))
|
||||
(cc (vmul col 1)))
|
||||
(pdata-set! "p" c (vadd (vmul (cirndvec) size)
|
||||
(vadd pos (vector 0 0 (+ 0.2 (* (rndf) 0.01))))))
|
||||
(vadd (vector (vx pos) (vy pos) 0)
|
||||
(vector 0 0 (+ 0.2 (* (rndf) 0.01))))))
|
||||
(pdata-set! "c" c (vector (vx cc) (vy cc) (vz cc) 0.5))))))
|
||||
|
||||
(define/public (suck-pollen pos size)
|
||||
|
|
@ -369,7 +400,7 @@
|
|||
(colour col)
|
||||
(hint-unlit)
|
||||
(translate pos)
|
||||
(printf "building from:~a~n" plant-desc)
|
||||
;(printf "building from:~a~n" plant-desc)
|
||||
(set! root-component (build-component "1-1" col plant-desc))
|
||||
(set! flower-list (component-leaves root-component))))
|
||||
|
||||
|
|
@ -378,28 +409,28 @@
|
|||
|
||||
|
||||
(define/public (player-update world network)
|
||||
(when (key-special-pressed 100)
|
||||
(when (key-special-pressed-this-frame 100)
|
||||
(set! current-flower (modulo (+ current-flower 1) (length flower-list))))
|
||||
|
||||
(when (key-special-pressed 102)
|
||||
(when (key-special-pressed-this-frame 102)
|
||||
(set! current-flower (modulo (- current-flower 1) (length flower-list))))
|
||||
|
||||
|
||||
; bit odd, have to go through network to tell other clients to
|
||||
; spray, and need to get the id of the player plant from the world...
|
||||
(when (key-special-pressed 101)
|
||||
(when (key-special-pressed-this-frame 101)
|
||||
(send network spray world (send world get-my-id) current-flower 0))
|
||||
|
||||
(let ((flower (list-ref flower-list current-flower)))
|
||||
|
||||
(with-primitive (component-root flower)
|
||||
(when (key-special-pressed 103)
|
||||
(when (key-special-pressed-this-frame 103)
|
||||
(rotate (vector 0 0 20))
|
||||
(let ((colours (suck world current-flower)))
|
||||
(when (not (zero? (length colours)))
|
||||
(let
|
||||
((av-col (vdiv (foldl (lambda (c1 c2)
|
||||
(vadd c1 c2)) (vector 0 0 0) colours) (length colours))))
|
||||
(vadd c1 c2)) (vector 0 0 0) colours) (length colours))))
|
||||
|
||||
(set-component-col! flower
|
||||
(vadd (vmul (component-col flower) 0.9)
|
||||
|
|
@ -416,7 +447,7 @@
|
|||
(set-component-col! flower col)
|
||||
(with-primitive (component-root flower)
|
||||
(colour (component-col flower)))))
|
||||
|
||||
|
||||
(define/public (update world)
|
||||
0
|
||||
#;(with-primitive root
|
||||
|
|
@ -430,7 +461,7 @@
|
|||
(with-primitive (component-root (list-ref flower-list flower))
|
||||
(get-global-transform)))))
|
||||
(send world puff-pollen pos (component-col (list-ref flower-list flower))
|
||||
0.2 1)))
|
||||
0.2 10)))
|
||||
|
||||
(define/public (suck world flower)
|
||||
(let ((pos (vtransform (vector 0 0 0)
|
||||
|
|
@ -448,201 +479,212 @@
|
|||
; * renamed send to xmpp-send
|
||||
|
||||
(define jabberer%
|
||||
(class object%
|
||||
(field
|
||||
(incoming '())
|
||||
(outgoing '())
|
||||
(thr 0))
|
||||
|
||||
(define/public (get-incoming)
|
||||
incoming)
|
||||
|
||||
(define/public (clear-incoming)
|
||||
(set! incoming '()))
|
||||
|
||||
(define/public (msg-waiting?)
|
||||
(not (null? incoming)))
|
||||
|
||||
(define/public (get-msg)
|
||||
(let ((msg (car incoming)))
|
||||
(set! incoming (cdr incoming))
|
||||
msg))
|
||||
|
||||
(define/public (send-msg to msg)
|
||||
(set! outgoing (cons (list to msg) outgoing)))
|
||||
|
||||
(define (message-handler sz)
|
||||
(printf "<---- ~a ~a~n" (message-from sz) (message-body sz))
|
||||
(set! incoming (cons (list (message-from sz) (message-body sz)) incoming)))
|
||||
|
||||
(define/public (start)
|
||||
(set! thr (thread run)))
|
||||
|
||||
(define/public (stop)
|
||||
(kill-thread thr))
|
||||
|
||||
(define (run)
|
||||
(with-xmpp-session jid pass
|
||||
(set-xmpp-handler 'message message-handler)
|
||||
(let loop ()
|
||||
(when (not (null? outgoing))
|
||||
(for-each
|
||||
(lambda (msg)
|
||||
(printf "----> ~a ~a~n" (car msg) (cadr msg))
|
||||
(class object%
|
||||
(field
|
||||
(incoming '())
|
||||
(outgoing '())
|
||||
(thr 0))
|
||||
|
||||
(define/public (get-incoming)
|
||||
incoming)
|
||||
|
||||
(define/public (clear-incoming)
|
||||
(set! incoming '()))
|
||||
|
||||
(define/public (msg-waiting?)
|
||||
(not (null? incoming)))
|
||||
|
||||
(define/public (get-msg)
|
||||
(let ((msg (car incoming)))
|
||||
(set! incoming (cdr incoming))
|
||||
msg))
|
||||
|
||||
(define/public (send-msg to msg)
|
||||
(set! outgoing (cons (list to msg) outgoing)))
|
||||
|
||||
(define (message-handler sz)
|
||||
(when debug-jab (printf "rx <---- ~a ~a~n" (message-from sz) (message-body sz)))
|
||||
(set! incoming (cons (list (message-from sz) (message-body sz)) incoming)))
|
||||
|
||||
(define/public (start)
|
||||
(set! thr (thread run)))
|
||||
|
||||
(define/public (stop)
|
||||
(kill-thread thr))
|
||||
|
||||
(define (run)
|
||||
(with-xmpp-session jid pass
|
||||
(set-xmpp-handler 'message message-handler)
|
||||
(let loop ()
|
||||
(when (not (null? outgoing))
|
||||
(for-each
|
||||
(lambda (msg)
|
||||
(when debug-jab (printf "tx ----> ~a ~a~n" (car msg) (cadr msg)))
|
||||
(xmpp-send (message (car msg) (cadr msg))))
|
||||
outgoing)
|
||||
(set! outgoing '()))
|
||||
(sleep 0.5)
|
||||
(loop))))
|
||||
(super-new)))
|
||||
outgoing)
|
||||
(set! outgoing '()))
|
||||
(sleep 0.5)
|
||||
(loop))))
|
||||
(super-new)))
|
||||
|
||||
(define network-dispatch%
|
||||
(class object%
|
||||
|
||||
(field
|
||||
(waiting #f)
|
||||
(wait-till 0)
|
||||
(jab (make-object jabberer%))
|
||||
(send-to jto))
|
||||
|
||||
(define (stringify l)
|
||||
(cond
|
||||
((null? l) l)
|
||||
((symbol? (car l))
|
||||
(cons (symbol->string (car l))
|
||||
(stringify (cdr l))))
|
||||
((number? (car l))
|
||||
(cons (number->string (car l))
|
||||
(stringify (cdr l))))
|
||||
((vector? (car l))
|
||||
(cons (car l)
|
||||
(stringify (cdr l))))
|
||||
((list? (car l))
|
||||
(cons (stringify (car l)) (stringify (cdr l))))
|
||||
(else (error "oops"))))
|
||||
|
||||
(define (split-string str)
|
||||
(let* ((l (string->list str))
|
||||
(cur "")
|
||||
(r (reverse (foldl
|
||||
(lambda (c l)
|
||||
(cond
|
||||
((char=? #\ c)
|
||||
(let ((r (cons cur l)))
|
||||
(set! cur "")
|
||||
r))
|
||||
(else
|
||||
(set! cur (string-append cur (string c)))
|
||||
l)))
|
||||
'()
|
||||
l))))
|
||||
(if (not (string=? cur ""))
|
||||
(append r (list cur))
|
||||
r)))
|
||||
|
||||
(define (join-end n l s)
|
||||
(cond
|
||||
((null? l) s)
|
||||
((not (zero? n)) (join-end (- n 1) (cdr l) s))
|
||||
(else
|
||||
(join-end n (cdr l) (string-append s " " (car l))))))
|
||||
|
||||
(define (dispatch world)
|
||||
(for-each
|
||||
(lambda (msg)
|
||||
(let ((command (list-ref (cadr msg) 0))
|
||||
(args (cdr (cadr msg))))
|
||||
(cond
|
||||
((string=? command "join-game")
|
||||
(printf "a new plant has joined the game~n")
|
||||
; send a plant update for the new player
|
||||
(update-plant world) )
|
||||
|
||||
((string=? command "plant")
|
||||
(printf "add plant message recieved : ~a~n" (list-ref args 0))
|
||||
(printf "~a~n" (join-end 7 args ""))
|
||||
(send world set-entity (string->number (list-ref args 0)) (make-object plant%
|
||||
(vector (string->number (list-ref args 1))
|
||||
(string->number (list-ref args 2))
|
||||
(string->number (list-ref args 3)))
|
||||
(vector (string->number (list-ref args 4))
|
||||
(string->number (list-ref args 5))
|
||||
(string->number (list-ref args 6)))
|
||||
(stringify (eval-string (join-end 7 args ""))))))
|
||||
|
||||
((string=? command "flower")
|
||||
;(printf "flower change msg recieved~n")
|
||||
(send (send world get-entity (string->number (list-ref args 0))) flower-update
|
||||
(list-ref args 1) (vector (string->number (list-ref args 2))
|
||||
(string->number (list-ref args 3))
|
||||
(string->number (list-ref args 4)))))
|
||||
|
||||
((string=? command "destroy-plant")
|
||||
(printf "destroy plant message recieved...~n")
|
||||
(send world destroy-entity (string->number (list-ref args 0))))
|
||||
|
||||
((string=? command "spray")
|
||||
; (printf "destroy plant message recieved...~n")
|
||||
(let ((e (send world get-entity (string->number (list-ref args 0)))))
|
||||
; it's possible to get spray events before the
|
||||
; plant has been created...
|
||||
(when e
|
||||
(send e spray world (string->number (list-ref args 1))
|
||||
(string->number (list-ref args 2)))))))))
|
||||
(send jab get-incoming))
|
||||
(send jab clear-incoming))
|
||||
|
||||
(define/public (join-game world)
|
||||
(send jab start)
|
||||
(send jab send-msg send-to "join-game")
|
||||
(set! wait-till (+ (time) 2))
|
||||
(set! waiting #t))
|
||||
|
||||
(define/public (update-plant world)
|
||||
(let* ((my-plant (send world get-entity (send world get-my-id)))
|
||||
(pos (send my-plant get-pos))
|
||||
(col (send my-plant get-col))
|
||||
(desc-str (format "'~a" (send my-plant get-desc))))
|
||||
(class object%
|
||||
|
||||
(send jab send-msg send-to (string-append "plant " (number->string (send world get-my-id)) " "
|
||||
(number->string (vx pos)) " "
|
||||
(number->string (vy pos)) " "
|
||||
(number->string (vz pos)) " "
|
||||
(number->string (vx col)) " "
|
||||
(number->string (vy col)) " "
|
||||
(number->string (vz col)) " "
|
||||
desc-str))))
|
||||
|
||||
(define/public (destroy-plant world id)
|
||||
(send jab send-msg send-to (string-append "destroy-plant " (number->string id)))
|
||||
(send world destroy-entity id))
|
||||
|
||||
(define/public (spray world id flower type)
|
||||
(send jab send-msg send-to (string-append "spray "
|
||||
(number->string id) " "
|
||||
(number->string flower) " "
|
||||
(number->string type))) " "
|
||||
(send (send world get-entity id) spray world flower type))
|
||||
|
||||
(define/public (flower-update world id flower col)
|
||||
(send jab send-msg send-to (string-append "flower "
|
||||
(number->string id) " "
|
||||
(number->string flower) " "
|
||||
(number->string (vx col)) " "
|
||||
(number->string (vy col)) " "
|
||||
(number->string (vz col))))
|
||||
(send (send world get-entity id) flower-update flower col))
|
||||
|
||||
|
||||
(define/public (update world)
|
||||
; wait for all other players to register their plants
|
||||
(when (and waiting (< wait-till (time)))
|
||||
(set! waiting #f)
|
||||
(send world make-my-plant)
|
||||
(update-plant world))
|
||||
(dispatch world))
|
||||
|
||||
(super-new)))
|
||||
(field
|
||||
(waiting #f)
|
||||
(wait-till 0)
|
||||
(jab (make-object jabberer%))
|
||||
(send-to jto))
|
||||
|
||||
(define/public (start)
|
||||
(send jab start))
|
||||
|
||||
|
||||
(define (stringify l)
|
||||
(cond
|
||||
((null? l) l)
|
||||
((symbol? (car l))
|
||||
(cons (symbol->string (car l))
|
||||
(stringify (cdr l))))
|
||||
((number? (car l))
|
||||
(cons (number->string (car l))
|
||||
(stringify (cdr l))))
|
||||
((vector? (car l))
|
||||
(cons (car l)
|
||||
(stringify (cdr l))))
|
||||
((list? (car l))
|
||||
(cons (stringify (car l)) (stringify (cdr l))))
|
||||
(else (error "oops"))))
|
||||
|
||||
(define (split-string str)
|
||||
(let* ((l (string->list str))
|
||||
(cur "")
|
||||
(r (reverse (foldl
|
||||
(lambda (c l)
|
||||
(cond
|
||||
((char=? #\ c)
|
||||
(let ((r (cons cur l)))
|
||||
(set! cur "")
|
||||
r))
|
||||
(else
|
||||
(set! cur (string-append cur (string c)))
|
||||
l)))
|
||||
'()
|
||||
l))))
|
||||
(if (not (string=? cur ""))
|
||||
(append r (list cur))
|
||||
r)))
|
||||
|
||||
(define (join-end n l s)
|
||||
(cond
|
||||
((null? l) s)
|
||||
((not (zero? n)) (join-end (- n 1) (cdr l) s))
|
||||
(else
|
||||
(join-end n (cdr l) (string-append s " " (car l))))))
|
||||
|
||||
(define (dispatch world)
|
||||
(for-each
|
||||
(lambda (msg)
|
||||
(let* ((chopped (split-string (cadr msg)))
|
||||
(command (list-ref chopped 0))
|
||||
(args (cdr chopped)))
|
||||
(cond
|
||||
((string=? command "ping")
|
||||
(printf "pong~n"))
|
||||
|
||||
((string=? command "join-game")
|
||||
(send world destroy-all-but-me)
|
||||
(printf "a new plant has joined the game~n")
|
||||
; send a plant update for the new player
|
||||
(update-plant world) )
|
||||
|
||||
((string=? command "plant")
|
||||
(printf "add plant message recieved : ~a~n" (list-ref args 0))
|
||||
(send world set-entity (list-ref args 0) (make-object plant%
|
||||
(vector (string->number (list-ref args 1))
|
||||
(string->number (list-ref args 2))
|
||||
(string->number (list-ref args 3)))
|
||||
(vector (string->number (list-ref args 4))
|
||||
(string->number (list-ref args 5))
|
||||
(string->number (list-ref args 6)))
|
||||
(stringify (eval-string (join-end 7 args ""))))))
|
||||
|
||||
((string=? command "flower")
|
||||
;(printf "flower change msg recieved~n")
|
||||
(send (send world get-entity (list-ref args 0)) flower-update
|
||||
(string->number (list-ref args 1)) (vector (string->number (list-ref args 2))
|
||||
(string->number (list-ref args 3))
|
||||
(string->number (list-ref args 4)))))
|
||||
|
||||
((string=? command "destroy-plant")
|
||||
(printf "destroy plant message recieved...~n")
|
||||
(send world destroy-entity (list-ref args 0)))
|
||||
|
||||
((string=? command "spray")
|
||||
; (printf "destroy plant message recieved...~n")
|
||||
(let ((e (send world get-entity (list-ref args 0))))
|
||||
; it's possible to get spray events before the
|
||||
; plant has been created...
|
||||
(when e
|
||||
(send e spray world (string->number (list-ref args 1))
|
||||
(string->number (list-ref args 2))))))
|
||||
(else
|
||||
(printf "unknown command ~a ~n" command)))))
|
||||
(send jab get-incoming))
|
||||
(send jab clear-incoming))
|
||||
|
||||
(define/public (join-game world)
|
||||
(printf "ping~n")
|
||||
(send jab send-msg send-to "ping")
|
||||
(send jab send-msg send-to "join-game ")
|
||||
(set! wait-till (+ (flxtime) 5))
|
||||
(set! waiting #t))
|
||||
|
||||
(define/public (update-plant world)
|
||||
(let* ((my-plant (send world get-entity (send world get-my-id)))
|
||||
(pos (send my-plant get-pos))
|
||||
(col (send my-plant get-col))
|
||||
(desc-str (format "'~a" (send my-plant get-desc))))
|
||||
|
||||
(send jab send-msg send-to (string-append "plant " (send world get-my-id) " "
|
||||
(number->string (vx pos)) " "
|
||||
(number->string (vy pos)) " "
|
||||
(number->string (vz pos)) " "
|
||||
(number->string (vx col)) " "
|
||||
(number->string (vy col)) " "
|
||||
(number->string (vz col)) " "
|
||||
desc-str))))
|
||||
|
||||
(define/public (destroy-plant world id)
|
||||
(send jab send-msg send-to (string-append "destroy-plant " id))
|
||||
(send world destroy-entity id))
|
||||
|
||||
(define/public (spray world id flower type)
|
||||
(send jab send-msg send-to (string-append "spray "
|
||||
id " "
|
||||
(number->string flower) " "
|
||||
(number->string type))) " "
|
||||
(send (send world get-entity id) spray world flower type))
|
||||
|
||||
(define/public (flower-update world id flower col)
|
||||
(send jab send-msg send-to (string-append "flower "
|
||||
id " "
|
||||
(number->string flower) " "
|
||||
(number->string (vx col)) " "
|
||||
(number->string (vy col)) " "
|
||||
(number->string (vz col))))
|
||||
(send (send world get-entity id) flower-update flower col))
|
||||
|
||||
|
||||
(define/public (update world)
|
||||
; wait for all other players to register their plants
|
||||
(when (and waiting (< wait-till (flxtime)))
|
||||
(set! waiting #f)
|
||||
(send world make-my-plant)
|
||||
(update-plant world))
|
||||
(dispatch world))
|
||||
|
||||
(super-new)))
|
||||
|
||||
|
||||
|
||||
|
|
@ -685,144 +727,168 @@
|
|||
(with-state
|
||||
(backfacecull 0)
|
||||
(hint-depth-sort)
|
||||
; (hint-unlit)
|
||||
; (hint-unlit)
|
||||
(translate p)
|
||||
(rotate (vector 0 (random 360) 0))
|
||||
(scale (+ 1 (* (rndf) 1.5)))
|
||||
(texture (load-texture (choose (list
|
||||
"textures/bgplant-1.png"
|
||||
"textures/bgplant-2.png"
|
||||
"textures/bgplant-3.png"
|
||||
"textures/bgplant-4.png"
|
||||
"textures/bgplant-5.png"
|
||||
"textures/bgplant-6.png"
|
||||
))))
|
||||
"textures/bgplant-1.png"
|
||||
"textures/bgplant-2.png"
|
||||
;"textures/bgplant-3.png"
|
||||
"textures/bgplant-4.png"
|
||||
"textures/bgplant-5.png"
|
||||
"textures/bgplant-6.png"
|
||||
))))
|
||||
(let ((o (build-copy obj)))
|
||||
(with-primitive o (hide 0)))
|
||||
; (load-primitive "meshes/freeplant.obj")
|
||||
))
|
||||
; (load-primitive "meshes/freeplant.obj")
|
||||
))
|
||||
|
||||
(define (load-model tex obj)
|
||||
(with-state
|
||||
(texture (load-texture (string-append "textures/" tex)))
|
||||
(load-primitive (string-append "meshes/" obj))))
|
||||
|
||||
(define (build-set)
|
||||
(with-state
|
||||
(let ((l (make-light 'spot 'free)))
|
||||
(light-diffuse 0 (vector 0 0 0))
|
||||
(light-diffuse l (vector 1 1 1))
|
||||
(light-position l (vector 0 10 0))
|
||||
(light-direction l (vector 0 -1 0))
|
||||
(light-spot-angle l 55)
|
||||
(light-spot-exponent l 1))
|
||||
|
||||
(let ((l2 (make-light 'point 'free)))
|
||||
(light-position l2 (vector 0 20 0))
|
||||
(light-diffuse l2 (vector 0.4 0.9 0.5)))
|
||||
|
||||
(with-state
|
||||
(backfacecull 0)
|
||||
(hint-depth-sort)
|
||||
(hint-unlit)
|
||||
(texture-params 0 '(wrap-s repeat wrap-t repeat))
|
||||
(load-model "bgplant-1.png" "plant-0.obj")
|
||||
(load-model "bgplant-1.png" "plant-1.obj")
|
||||
(load-model "bgplant-1.png" "plant-2.obj")
|
||||
(load-model "bgplant-1.png" "plant-3.obj")
|
||||
(load-model "bgplant-1.png" "plant-4.obj")
|
||||
(load-model "bgplant-1.png" "plant-5.obj")
|
||||
(load-model "bgplant-1.png" "plant-6.obj")
|
||||
; (load-model "bgplant-2.png" "plant-7.obj")
|
||||
|
||||
)
|
||||
|
||||
(with-state
|
||||
(backfacecull 0)
|
||||
(load-model "car-base.png" "car.obj")
|
||||
(load-model "car-base.png" "car-2.obj")
|
||||
(load-model "telly-base.png" "telly-2.obj"))
|
||||
|
||||
(with-state
|
||||
(load-model "telly-base2.png" "telly-0.obj")
|
||||
(load-model "telly-base.png" "telly-1.obj")
|
||||
(load-model "telly-base.png" "telly-2.obj")
|
||||
(load-model "telly-base.png" "telly-3.obj")
|
||||
(load-model "telly-base.png" "telly-4.obj"))
|
||||
|
||||
|
||||
(with-state
|
||||
(load-model "washer-base.png" "washer-0.obj")
|
||||
(load-model "washer-base.png" "washer-1.obj")
|
||||
(load-model "washer-base.png" "washer-2.obj")
|
||||
(load-model "washer-base.png" "washer-3.obj"))
|
||||
|
||||
(let ((terrain (with-state
|
||||
(texture (load-texture "textures/ground-base.png"))
|
||||
(load-primitive "meshes/ground.obj")))
|
||||
(flower-obj (load-primitive "meshes/freeplant.obj")))
|
||||
|
||||
;(define grassmap (load-primitive "textures/set-grass.png"))
|
||||
|
||||
#;(define (tx->pi tx)
|
||||
(+ (vy tx) (* (vx tx) (pixels-width))))
|
||||
|
||||
|
||||
(with-primitive flower-obj
|
||||
(pdata-map!
|
||||
(lambda (n p)
|
||||
(vnormalise p))
|
||||
"n" "p")
|
||||
(hide 1))
|
||||
|
||||
|
||||
(with-state
|
||||
(backfacecull 0)
|
||||
(hint-depth-sort)
|
||||
(hint-unlit)
|
||||
(translate (vector -15 2 10))
|
||||
(scale 15)
|
||||
(texture (load-texture "textures/bgplant-1.png"))
|
||||
(let ((o (build-copy flower-obj)))
|
||||
(with-primitive o (hide 0))))
|
||||
|
||||
|
||||
(with-primitive terrain
|
||||
(poly-for-each-tri-sample
|
||||
(lambda (indices bary)
|
||||
(let ((tc (vadd
|
||||
(vmul (pdata-ref "t" (list-ref indices 0)) (vx bary))
|
||||
(vmul (pdata-ref "t" (list-ref indices 1)) (vy bary))
|
||||
(vmul (pdata-ref "t" (list-ref indices 2)) (vz bary)))))
|
||||
(when (zero? (random 2)) #;(> (va (with-primitive grassmap (pdata-ref "c" (tx->pi tc)))) 0.5)
|
||||
(let ((pos (vadd
|
||||
(vmul (pdata-ref "p" (list-ref indices 0)) (vx bary))
|
||||
(vmul (pdata-ref "p" (list-ref indices 1)) (vy bary))
|
||||
(vmul (pdata-ref "p" (list-ref indices 2)) (vz bary)))))
|
||||
(when (> (vmag pos) 3)
|
||||
(build-flower pos (vector 0 1 0) flower-obj))))))
|
||||
1))
|
||||
|
||||
(let ((shell0 (build-copy terrain)))
|
||||
|
||||
(with-primitive shell0
|
||||
(pdata-copy "t" "t1")
|
||||
(pdata-map!
|
||||
(lambda (t)
|
||||
(vmul t 4))
|
||||
"t"))
|
||||
|
||||
(with-state
|
||||
(multitexture 0 (load-texture "textures/shell.png"))
|
||||
; (multitexture 1 (load-texture "textures/ground-grassmap.png"))
|
||||
(build-shells shell0 4 0.05 (vector 1 0.5 1)))))))
|
||||
|
||||
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||||
|
||||
(clear)
|
||||
|
||||
(clear-colour (vmul (vector 0.4 0.5 0.9) 0.2))
|
||||
(fog (vector 0.4 0.5 0.9) 0.01 1 100)
|
||||
(clear-colour (vmul (vector 0.4 0.9 0.5) 0.2))
|
||||
(fog (vector 0.4 0.9 0.5) 0.01 1 100)
|
||||
|
||||
#;(
|
||||
(define l (make-light 'spot 'free))
|
||||
(light-diffuse 0 (vector 0 0 0))
|
||||
(light-diffuse l (vector 1 1 1))
|
||||
(light-position l (vector 0 5 0))
|
||||
(light-direction l (vector 0 -1 0))
|
||||
(light-spot-angle l 55)
|
||||
(light-spot-exponent l 1)
|
||||
(define set-root (with-state
|
||||
(scale 2)
|
||||
(rotate (vector 0 -100 0))
|
||||
(build-locator)))
|
||||
|
||||
(define l2 (make-light 'point 'free))
|
||||
(light-position l2 (vector 0 10 0))
|
||||
(light-diffuse l2 (vector 0.4 0.5 0.9))
|
||||
|
||||
(clear-texture-cache)
|
||||
(clear-geometry-cache)
|
||||
|
||||
(with-state
|
||||
(backfacecull 0)
|
||||
(hint-depth-sort)
|
||||
(hint-unlit)
|
||||
(texture-params 0 '(wrap-s repeat wrap-t repeat))
|
||||
(load-model "bgplant-1.png" "plant-0.obj")
|
||||
(load-model "bgplant-1.png" "plant-1.obj")
|
||||
(load-model "bgplant-1.png" "plant-2.obj")
|
||||
(load-model "bgplant-1.png" "plant-3.obj")
|
||||
(load-model "bgplant-1.png" "plant-4.obj")
|
||||
(load-model "bgplant-1.png" "plant-5.obj")
|
||||
(load-model "bgplant-1.png" "plant-6.obj")
|
||||
; (load-model "bgplant-2.png" "plant-7.obj")
|
||||
|
||||
)
|
||||
|
||||
|
||||
(with-state
|
||||
(backfacecull 0)
|
||||
(load-model "car-base.png" "car.obj")
|
||||
(load-model "car-base.png" "car-2.obj")
|
||||
(load-model "telly-base.png" "telly-2.obj"))
|
||||
|
||||
(with-state
|
||||
(load-model "telly-base.png" "telly-0.obj")
|
||||
(load-model "telly-base2.png" "telly-1.obj")
|
||||
(load-model "telly-base.png" "telly-2.obj")
|
||||
(load-model "telly-base.png" "telly-3.obj")
|
||||
(load-model "telly-base.png" "telly-4.obj"))
|
||||
|
||||
|
||||
(with-state
|
||||
(load-model "washer-base.png" "washer-0.obj")
|
||||
(load-model "washer-base.png" "washer-1.obj")
|
||||
(load-model "washer-base.png" "washer-2.obj")
|
||||
(load-model "washer-base.png" "washer-3.obj"))
|
||||
|
||||
(define terrain (with-state
|
||||
(texture (load-texture "textures/ground-base.png"))
|
||||
(load-primitive "meshes/ground.obj")))
|
||||
|
||||
|
||||
;(define grassmap (load-primitive "textures/set-grass.png"))
|
||||
|
||||
(define (tx->pi tx)
|
||||
(+ (vy tx) (* (vx tx) (pixels-width))))
|
||||
|
||||
(define flower-obj (load-primitive "meshes/freeplant.obj"))
|
||||
|
||||
(with-primitive flower-obj
|
||||
(pdata-map!
|
||||
(lambda (n p)
|
||||
(vnormalise p))
|
||||
"n" "p")
|
||||
(hide 1))
|
||||
|
||||
(with-primitive terrain
|
||||
(poly-for-each-tri-sample
|
||||
(lambda (indices bary)
|
||||
(let ((tc (vadd
|
||||
(vmul (pdata-ref "t" (list-ref indices 0)) (vx bary))
|
||||
(vmul (pdata-ref "t" (list-ref indices 1)) (vy bary))
|
||||
(vmul (pdata-ref "t" (list-ref indices 2)) (vz bary)))))
|
||||
(when (zero? (random 2)) #;(> (va (with-primitive grassmap (pdata-ref "c" (tx->pi tc)))) 0.5)
|
||||
(build-flower (vadd
|
||||
(vmul (pdata-ref "p" (list-ref indices 0)) (vx bary))
|
||||
(vmul (pdata-ref "p" (list-ref indices 1)) (vy bary))
|
||||
(vmul (pdata-ref "p" (list-ref indices 2)) (vz bary))) (vector 0 1 0)
|
||||
flower-obj))))
|
||||
1))
|
||||
|
||||
(define shell0 (build-copy terrain))
|
||||
|
||||
(with-primitive shell0
|
||||
(pdata-copy "t" "t1")
|
||||
(pdata-map!
|
||||
(lambda (t)
|
||||
(vmul t 4))
|
||||
"t"))
|
||||
|
||||
(with-state
|
||||
(multitexture 0 (load-texture "textures/shell.png"))
|
||||
; (multitexture 1 (load-texture "textures/ground-grassmap.png"))
|
||||
(build-shells shell0 4 0.05 (vector 1 0.5 1)))
|
||||
)
|
||||
|
||||
;----------------------------------------
|
||||
(when (not minimal-mode)
|
||||
(with-state
|
||||
(parent set-root)
|
||||
(build-set)))
|
||||
|
||||
(hint-depth-sort)
|
||||
|
||||
(define camera (build-locator))
|
||||
(with-primitive camera
|
||||
(translate (vector 0 5 0)))
|
||||
|
||||
(lock-camera camera)
|
||||
|
||||
(define w (make-object world% 1))
|
||||
(define n (make-object network-dispatch%))
|
||||
|
||||
(send n start)
|
||||
|
||||
(send n join-game w)
|
||||
|
||||
(define (animate)
|
||||
|
|
|
|||
|
|
@ -258,14 +258,14 @@
|
|||
((string-ci=? test "<pr") str)
|
||||
((string-ci=? test "<ur") str)
|
||||
(else
|
||||
(display (format "~%recieved: ~a ~%parsed as <null/>~%~%" str))
|
||||
;(display (format "~%recieved: ~a ~%parsed as <null/>~%~%" str))
|
||||
"<null/>"))))
|
||||
|
||||
|
||||
;; response handler
|
||||
(define (xmpp-response-handler in)
|
||||
(thread (lambda ()
|
||||
(let loop ()
|
||||
(let loop ()
|
||||
(parse-xmpp-response (read-async in))
|
||||
(sleep 0.1) ;; slight delay to avoid a tight loop
|
||||
(loop)))))
|
||||
|
|
@ -298,7 +298,7 @@
|
|||
(define xmpp-out-port (make-parameter (current-output-port)))
|
||||
|
||||
(define (xmpp-send str)
|
||||
(printf "sending iO: ~a ~%~%" str)
|
||||
;(printf "sending iO: ~a ~%~%" str)
|
||||
(fprintf (xmpp-out-port) "~A~%" str) (flush-output (xmpp-out-port)))
|
||||
|
||||
(defmacro with-xmpp-session (jid pass . body)
|
||||
|
|
|
|||
Loading…
Reference in a new issue