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

sending unintelligable messages over jabber

Browse source
This commit is contained in:
Dave Griffiths 2009-04-20 17:21:38 +01:00
parent 0982c85c2e
commit f047d8ebec
3 changed files with 216 additions and 136 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
comm/examples.scm
View file

@ -2,7 +2,7 @@
;; exmaple chat client ;; exmaple chat client
(require "xmpp.scm") (require "xmpp.ss")
(require openssl) (require openssl)
(define (read-input prompt) (define (read-input prompt)

14
comm/xmpp.ss
View file

@ -297,8 +297,8 @@
(define xmpp-in-port (make-parameter (current-input-port))) (define xmpp-in-port (make-parameter (current-input-port)))
(define xmpp-out-port (make-parameter (current-output-port))) (define xmpp-out-port (make-parameter (current-output-port)))
(define (send str) (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))) (fprintf (xmpp-out-port) "~A~%" str) (flush-output (xmpp-out-port)))
(defmacro with-xmpp-session (jid pass . body) (defmacro with-xmpp-session (jid pass . body)
@ -312,13 +312,13 @@
(xmpp-out-port out)) (xmpp-out-port out))
(file-stream-buffer-mode out 'line) (file-stream-buffer-mode out 'line)
(xmpp-response-handler in) (xmpp-response-handler in)
(send (xmpp-stream host)) (xmpp-send (xmpp-stream host))
(send (xmpp-session host)) (xmpp-send (xmpp-session host))
;(starttls in out) ;(starttls in out)
(send (xmpp-auth user ,pass resource)) (xmpp-send (xmpp-auth user ,pass resource))
(send (presence)) (xmpp-send (presence))
(send (presence #:status "Available")) (xmpp-send (presence #:status "Available"))
,@body ,@body
(close-output-port out) (close-output-port out)
(close-input-port in))))) (close-input-port in)))))

336
hayfever/hayfever2.scm
View file

@ -2,9 +2,9 @@
(require scheme/class) (require scheme/class)
(require mzlib/string) (require mzlib/string)
(require openssl)
(osc-destination "osc.udp://127.0.0.255:4001") (require "xmpp-dave.ss")
(osc-source "4002")
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; pixel primitive things for getting connection points ; pixel primitive things for getting connection points
@ -190,7 +190,7 @@
(with-primitive pollen (with-primitive pollen
(pdata-map! (pdata-map!
(lambda (p) (lambda (p)
(vmul (vector (crndf) (crndf) (+ 0.2 (* (rndf) 0.01))) 10)) (vmul (srndvec) 5))
"p") "p")
(pdata-map! (pdata-map!
(lambda (c) (lambda (c)
@ -200,31 +200,7 @@
(lambda (c) (lambda (c)
(let ((s (* 0.2 (grndf)))) (let ((s (* 0.2 (grndf))))
(vector s s 1))) (vector s s 1)))
"s")) "s")))
#;(set! root (with-state
(rotate (vector 90 0 0))
(scale 100)
(build-plane)))
#;(with-state
; (parent root)
(with-state
(colour (vector 0.5 1 0.5))
(scale (vector 20 13 1))
(translate (vector 0 0.2 0))
(rotate (vector 0 0 180))
; (texture (load-texture "textures/hills.png"))
(hint-unlit)
(build-plane))
#;(with-state
(scale (vector 14 15 1))
(translate (vector 0 0.3 4.5))
(rotate (vector 0 0 180))
(texture (load-texture "textures/fg.png"))
(hint-unlit)
(build-plane))))
(define/public (get-entity-list) (define/public (get-entity-list)
entity-list) entity-list)
@ -289,11 +265,16 @@
(define (animate-pollen) (define (animate-pollen)
(pdata-map! (pdata-map!
(lambda (p) (lambda (p)
(let* ((pp (vmul p 0.5)) (let* ((pp (vadd (vmul p 1) (vector 0 (- (time)) 0)))
(v (vector (- (noise (vx pp) (vy pp) (time)) 0.5) (v (cond
(- (noise (vx pp) (+ (vy pp) 112.3) (time)) 0.5) 0))) ((< (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))))))
(vadd (vadd p (vmul v 0.2)) (vadd (vadd p (vmul v 0.2))
(vmul (vector (crndf) (crndf) 0) 0.01)))) (vmul (srndvec) 0.01))))
"p")) "p"))
(define (cirndvec) (define (cirndvec)
@ -447,104 +428,204 @@
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; things changed in xmpp
; * removed printf
; * 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)
(printf "~a ~a~n" to msg)
(set! outgoing (cons (list to msg) outgoing)))
(define (message-handler 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)
(printf "running xmpp~n")
(with-xmpp-session "plant0000001@fo.am" "plant0000001"
(printf "xmpp sesh~n")
(set-xmpp-handler 'message message-handler)
(printf "xmpp sesh~n")
(let loop ()
(when (not (null? outgoing))
(for-each
(lambda (msg)
(printf "---- ~a~n" (cadr msg))
(xmpp-send (message (car msg) (cadr msg))))
outgoing)
(set! outgoing '()))
(sleep 2)
(loop))))
(super-new)))
(define network-dispatch% (define network-dispatch%
(class object% (class object%
(field
(waiting #f)
(wait-till 0)
(jab (make-object jabberer%))
(send-to "dave@fo.am"))
(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 (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))
(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 (list-ref args 7))))))
((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))))
(field (send jab send-msg send-to (string-append "plant " (number->string (send world get-my-id))
(waiting #f) (number->string (vx pos))
(wait-till 0)) (number->string (vy pos))
(number->string (vz pos))
(define (stringify l) (number->string (vx col))
(cond (number->string (vy col))
((null? l) l) (number->string (vz col))
((symbol? (car l)) desc-str))))
(cons (symbol->string (car l))
(stringify (cdr l)))) (define/public (destroy-plant world id)
((number? (car l)) (send jab send-msg send-to (string-append "destroy-plant " (number->string id)))
(cons (number->string (car l)) (send world destroy-entity id))
(stringify (cdr l))))
((vector? (car l)) (define/public (spray world id flower type)
(cons (car l) (send jab send-msg send-to (string-append "spray "
(stringify (cdr l)))) (number->string id)
((list? (car l)) (number->string flower)
(cons (stringify (car l)) (stringify (cdr l)))) (number->string type)))
(else (error "oops")))) (send (send world get-entity id) spray world flower type))
(define/public (flower-update world id flower col)
(define (dispatch world) (send jab send-msg send-to (string-append "flower "
(cond (number->string id)
((osc-msg "/join-game") (number->string flower)
(printf "a new plant has joined the game~n") (number->string (vx col))
; send a plant update for the new player (number->string (vy col))
(update-plant world) ) (number->string (vz col))))
(send (send world get-entity id) flower-update flower col))
((osc-msg "/plant")
(printf "add plant message recieved : ~a~n" (osc 0))
(send world set-entity (osc 0) (make-object plant% (define/public (update world)
(vector (osc 1) (osc 2) (osc 3)) ; wait for all other players to register their plants
(vector (osc 4) (osc 5) (osc 6)) (when (and waiting (< wait-till (time)))
(stringify (eval-string (osc 7)))))) (set! waiting #f)
(send world make-my-plant)
(update-plant world))
(dispatch world))
(super-new)))
((osc-msg "/flower")
;(printf "flower change msg recieved~n")
(send (send world get-entity (osc 0)) flower-update
(osc 1) (vector (osc 2) (osc 3) (osc 4))))
((osc-msg "/destroy-plant")
(printf "destroy plant message recieved...~n")
(send world destroy-entity (osc 0)))
((osc-msg "/spray")
; (printf "destroy plant message recieved...~n")
(let ((e (send world get-entity (osc 0))))
; it's possible to get spray events before the
; plant has been created...
(when e
(send e spray world (osc 1) (osc 2)))))))
(define/public (join-game world)
(printf "sending join-game~n")
(osc-send "/join-game" "" (list))
(set! wait-till (+ (time) 2))
(set! waiting #t))
(define/public (update-plant world)
(printf "sending /plant...~n")
(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))))
(osc-send "/plant" "iffffffs" (list (send world get-my-id)
(vx pos) (vy pos) (vz pos)
(vx col) (vy col) (vz col)
desc-str))))
(define/public (destroy-plant world id)
(printf "sending destroy plant...~n")
(osc-send "/destroy-plant" "i" (list id))
(send world destroy-entity id))
(define/public (spray world id flower type)
(osc-send "/spray" "iii" (list id flower type))
(send (send world get-entity id) spray world flower type))
(define/public (flower-update world id flower col)
(osc-send "/flower" "iifff" (list id flower (vx col) (vy col) (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)))
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; things needed for the set ; things needed for the set
@ -716,8 +797,7 @@
;---------------------------------------- ;----------------------------------------
(rotate (vector 0 0 0))
(scale 0.5)
(hint-depth-sort) (hint-depth-sort)
(define w (make-object world% 1)) (define w (make-object world% 1))