sending unintelligable messages over jabber
This commit is contained in:
Dave Griffiths
parent
0982c85c2e
commit
f047d8ebec
3 changed files with 216 additions and 136 deletions
|
|
@ -2,7 +2,7 @@
|
|||
|
||||
;; exmaple chat client
|
||||
|
||||
(require "xmpp.scm")
|
||||
(require "xmpp.ss")
|
||||
(require openssl)
|
||||
|
||||
(define (read-input prompt)
|
||||
|
|
|
|||
14
comm/xmpp.ss
14
comm/xmpp.ss
|
|
@ -297,8 +297,8 @@
|
|||
(define xmpp-in-port (make-parameter (current-input-port)))
|
||||
(define xmpp-out-port (make-parameter (current-output-port)))
|
||||
|
||||
(define (send str)
|
||||
(printf "sending iO: ~a ~%~%" str)
|
||||
(define (xmpp-send str)
|
||||
; (printf "sending iO: ~a ~%~%" str)
|
||||
(fprintf (xmpp-out-port) "~A~%" str) (flush-output (xmpp-out-port)))
|
||||
|
||||
(defmacro with-xmpp-session (jid pass . body)
|
||||
|
|
@ -312,13 +312,13 @@
|
|||
(xmpp-out-port out))
|
||||
(file-stream-buffer-mode out 'line)
|
||||
(xmpp-response-handler in)
|
||||
(send (xmpp-stream host))
|
||||
(send (xmpp-session host))
|
||||
(xmpp-send (xmpp-stream host))
|
||||
(xmpp-send (xmpp-session host))
|
||||
;(starttls in out)
|
||||
|
||||
(send (xmpp-auth user ,pass resource))
|
||||
(send (presence))
|
||||
(send (presence #:status "Available"))
|
||||
(xmpp-send (xmpp-auth user ,pass resource))
|
||||
(xmpp-send (presence))
|
||||
(xmpp-send (presence #:status "Available"))
|
||||
,@body
|
||||
(close-output-port out)
|
||||
(close-input-port in)))))
|
||||
|
|
|
|||
|
|
@ -2,9 +2,9 @@
|
|||
|
||||
(require scheme/class)
|
||||
(require mzlib/string)
|
||||
(require openssl)
|
||||
|
||||
(osc-destination "osc.udp://127.0.0.255:4001")
|
||||
(osc-source "4002")
|
||||
(require "xmpp-dave.ss")
|
||||
|
||||
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||||
; pixel primitive things for getting connection points
|
||||
|
|
@ -190,7 +190,7 @@
|
|||
(with-primitive pollen
|
||||
(pdata-map!
|
||||
(lambda (p)
|
||||
(vmul (vector (crndf) (crndf) (+ 0.2 (* (rndf) 0.01))) 10))
|
||||
(vmul (srndvec) 5))
|
||||
"p")
|
||||
(pdata-map!
|
||||
(lambda (c)
|
||||
|
|
@ -200,31 +200,7 @@
|
|||
(lambda (c)
|
||||
(let ((s (* 0.2 (grndf))))
|
||||
(vector s s 1)))
|
||||
"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))))
|
||||
"s")))
|
||||
|
||||
(define/public (get-entity-list)
|
||||
entity-list)
|
||||
|
|
@ -289,11 +265,16 @@
|
|||
(define (animate-pollen)
|
||||
(pdata-map!
|
||||
(lambda (p)
|
||||
(let* ((pp (vmul p 0.5))
|
||||
(v (vector (- (noise (vx pp) (vy pp) (time)) 0.5)
|
||||
(- (noise (vx pp) (+ (vy pp) 112.3) (time)) 0.5) 0)))
|
||||
(let* ((pp (vadd (vmul p 1) (vector 0 (- (time)) 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))))))
|
||||
(vadd (vadd p (vmul v 0.2))
|
||||
(vmul (vector (crndf) (crndf) 0) 0.01))))
|
||||
(vmul (srndvec) 0.01))))
|
||||
"p"))
|
||||
|
||||
(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%
|
||||
(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
|
||||
(waiting #f)
|
||||
(wait-till 0))
|
||||
|
||||
(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 (dispatch world)
|
||||
(cond
|
||||
((osc-msg "/join-game")
|
||||
(printf "a new plant has joined the game~n")
|
||||
; send a plant update for the new player
|
||||
(update-plant world) )
|
||||
|
||||
((osc-msg "/plant")
|
||||
(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))))))
|
||||
(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)))
|
||||
|
||||
((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
|
||||
|
|
@ -716,8 +797,7 @@
|
|||
|
||||
|
||||
;----------------------------------------
|
||||
(rotate (vector 0 0 0))
|
||||
(scale 0.5)
|
||||
|
||||
(hint-depth-sort)
|
||||
|
||||
(define w (make-object world% 1))
|
||||
|
|
|
|||
Loading…
Reference in a new issue