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)))))

330
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 (field
(waiting #f) (waiting #f)
(wait-till 0)) (wait-till 0)
(jab (make-object jabberer%))
(send-to "dave@fo.am"))
(define (stringify l) (define (stringify l)
(cond (cond
((null? l) l) ((null? l) l)
((symbol? (car l)) ((symbol? (car l))
(cons (symbol->string (car l)) (cons (symbol->string (car l))
(stringify (cdr l)))) (stringify (cdr l))))
((number? (car l)) ((number? (car l))
(cons (number->string (car l)) (cons (number->string (car l))
(stringify (cdr l)))) (stringify (cdr l))))
((vector? (car l)) ((vector? (car l))
(cons (car l) (cons (car l)
(stringify (cdr l)))) (stringify (cdr l))))
((list? (car l)) ((list? (car l))
(cons (stringify (car l)) (stringify (cdr l)))) (cons (stringify (car l)) (stringify (cdr l))))
(else (error "oops")))) (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))))
(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 (dispatch world) (define/public (update world)
(cond ; wait for all other players to register their plants
((osc-msg "/join-game") (when (and waiting (< wait-till (time)))
(printf "a new plant has joined the game~n") (set! waiting #f)
; send a plant update for the new player (send world make-my-plant)
(update-plant world) ) (update-plant world))
(dispatch world))
((osc-msg "/plant") (super-new)))
(printf "add plant message recieved : ~a~n" (osc 0))
(send world set-entity (osc 0) (make-object plant%
(vector (osc 1) (osc 2) (osc 3))
(vector (osc 4) (osc 5) (osc 6))
(stringify (eval-string (osc 7))))))
((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))