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

more jabber

Browse source
This commit is contained in:
Dave Griffiths 2009-04-21 09:59:14 +01:00
parent a78e99c2ae
commit 9cc1c0e204
3 changed files with 57 additions and 37 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

14
comm/xmpp.ss
View file

@ -217,7 +217,7 @@
(define (run-xmpp-handler type sz) (define (run-xmpp-handler type sz)
(let ((fcn (dict-ref xmpp-handlers type #f))) (let ((fcn (dict-ref xmpp-handlers type #f)))
(when fcn (begin (when fcn (begin
(display (format "attempting to run handler ~a.~%" fcn)) ;(display (format "attempting to run handler ~a.~%" fcn))
(fcn sz))))) (fcn sz)))))
;; no real parsing yet. dispatches any received xml stanzas as sxml ;; no real parsing yet. dispatches any received xml stanzas as sxml
@ -297,7 +297,7 @@
(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 (xmpp-send str) (define (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)))
@ -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)
(xmpp-send (xmpp-stream host)) (send (xmpp-stream host))
(xmpp-send (xmpp-session host)) (send (xmpp-session host))
;(starttls in out) ;(starttls in out)
(xmpp-send (xmpp-auth user ,pass resource)) (send (xmpp-auth user ,pass resource))
(xmpp-send (presence)) (send (presence))
(xmpp-send (presence #:status "Available")) (send (presence #:status "Available"))
,@body ,@body
(close-output-port out) (close-output-port out)
(close-input-port in))))) (close-input-port in)))))

78
hayfever/hayfever2.scm
View file

@ -5,6 +5,21 @@
(require openssl) (require openssl)
(require "xmpp-dave.ss") (require "xmpp-dave.ss")
;(require (prefix-in xmpp: (planet zzkt/xmpp)))
(define plant2 #f)
;(set! plant2 #t)
(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"))
(printf "I am ~a~n" jid)
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; pixel primitive things for getting connection points ; pixel primitive things for getting connection points
@ -185,7 +200,7 @@
(set! pollen (with-state (set! pollen (with-state
(translate (vector 0 0 0.2)) (translate (vector 0 0 0.2))
(texture (load-texture "textures/pollen.png")) (texture (load-texture "textures/pollen.png"))
(build-particles 1000))) (build-particles 100)))
(with-primitive pollen (with-primitive pollen
(pdata-map! (pdata-map!
@ -454,10 +469,10 @@
msg)) msg))
(define/public (send-msg to msg) (define/public (send-msg to msg)
(printf "~a ~a~n" to msg)
(set! outgoing (cons (list to msg) outgoing))) (set! outgoing (cons (list to msg) outgoing)))
(define (message-handler sz) (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))) (set! incoming (cons (list (message-from sz) (message-body sz)) incoming)))
(define/public (start) (define/public (start)
@ -467,22 +482,17 @@
(kill-thread thr)) (kill-thread thr))
(define (run) (define (run)
(printf "running xmpp~n") (with-xmpp-session jid pass
(with-xmpp-session "plant0000001@fo.am" "plant0000001"
(printf "xmpp sesh~n")
(set-xmpp-handler 'message message-handler) (set-xmpp-handler 'message message-handler)
(printf "xmpp sesh~n")
(let loop () (let loop ()
(when (not (null? outgoing)) (when (not (null? outgoing))
(for-each (for-each
(lambda (msg) (lambda (msg)
(printf "---- ~a~n" (cadr msg)) (printf "----> ~a ~a~n" (car msg) (cadr msg))
(xmpp-send (message (car msg) (cadr msg)))) (xmpp-send (message (car msg) (cadr msg))))
outgoing) outgoing)
(set! outgoing '())) (set! outgoing '()))
(sleep 2) (sleep 0.5)
(loop)))) (loop))))
(super-new))) (super-new)))
@ -493,7 +503,7 @@
(waiting #f) (waiting #f)
(wait-till 0) (wait-till 0)
(jab (make-object jabberer%)) (jab (make-object jabberer%))
(send-to "dave@fo.am")) (send-to jto))
(define (stringify l) (define (stringify l)
(cond (cond
@ -530,8 +540,15 @@
(append r (list cur)) (append r (list cur))
r))) 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) (define (dispatch world)
(for-each (for-each
(lambda (msg) (lambda (msg)
(let ((command (list-ref (cadr msg) 0)) (let ((command (list-ref (cadr msg) 0))
(args (cdr (cadr msg)))) (args (cdr (cadr msg))))
@ -543,6 +560,7 @@
((string=? command "plant") ((string=? command "plant")
(printf "add plant message recieved : ~a~n" (list-ref args 0)) (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% (send world set-entity (string->number (list-ref args 0)) (make-object plant%
(vector (string->number (list-ref args 1)) (vector (string->number (list-ref args 1))
(string->number (list-ref args 2)) (string->number (list-ref args 2))
@ -550,7 +568,7 @@
(vector (string->number (list-ref args 4)) (vector (string->number (list-ref args 4))
(string->number (list-ref args 5)) (string->number (list-ref args 5))
(string->number (list-ref args 6))) (string->number (list-ref args 6)))
(stringify (eval-string (list-ref args 7)))))) (stringify (eval-string (join-end 7 args ""))))))
((string=? command "flower") ((string=? command "flower")
;(printf "flower change msg recieved~n") ;(printf "flower change msg recieved~n")
@ -586,13 +604,13 @@
(col (send my-plant get-col)) (col (send my-plant get-col))
(desc-str (format "'~a" (send my-plant get-desc)))) (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)) (send jab send-msg send-to (string-append "plant " (number->string (send world get-my-id)) " "
(number->string (vx pos)) (number->string (vx pos)) " "
(number->string (vy pos)) (number->string (vy pos)) " "
(number->string (vz pos)) (number->string (vz pos)) " "
(number->string (vx col)) (number->string (vx col)) " "
(number->string (vy col)) (number->string (vy col)) " "
(number->string (vz col)) (number->string (vz col)) " "
desc-str)))) desc-str))))
(define/public (destroy-plant world id) (define/public (destroy-plant world id)
@ -601,18 +619,18 @@
(define/public (spray world id flower type) (define/public (spray world id flower type)
(send jab send-msg send-to (string-append "spray " (send jab send-msg send-to (string-append "spray "
(number->string id) (number->string id) " "
(number->string flower) (number->string flower) " "
(number->string type))) (number->string type))) " "
(send (send world get-entity id) spray world flower type)) (send (send world get-entity id) spray world flower type))
(define/public (flower-update world id flower col) (define/public (flower-update world id flower col)
(send jab send-msg send-to (string-append "flower " (send jab send-msg send-to (string-append "flower "
(number->string id) (number->string id) " "
(number->string flower) (number->string flower) " "
(number->string (vx col)) (number->string (vx col)) " "
(number->string (vy col)) (number->string (vy col)) " "
(number->string (vz col)))) (number->string (vz col))))
(send (send world get-entity id) flower-update flower col)) (send (send world get-entity id) flower-update flower col))
@ -623,6 +641,7 @@
(send world make-my-plant) (send world make-my-plant)
(update-plant world)) (update-plant world))
(dispatch world)) (dispatch world))
(super-new))) (super-new)))
@ -695,6 +714,7 @@
(clear-colour (vmul (vector 0.4 0.5 0.9) 0.2)) (clear-colour (vmul (vector 0.4 0.5 0.9) 0.2))
(fog (vector 0.4 0.5 0.9) 0.01 1 100) (fog (vector 0.4 0.5 0.9) 0.01 1 100)
#;(
(define l (make-light 'spot 'free)) (define l (make-light 'spot 'free))
(light-diffuse 0 (vector 0 0 0)) (light-diffuse 0 (vector 0 0 0))
(light-diffuse l (vector 1 1 1)) (light-diffuse l (vector 1 1 1))
@ -794,7 +814,7 @@
(multitexture 0 (load-texture "textures/shell.png")) (multitexture 0 (load-texture "textures/shell.png"))
; (multitexture 1 (load-texture "textures/ground-grassmap.png")) ; (multitexture 1 (load-texture "textures/ground-grassmap.png"))
(build-shells shell0 4 0.05 (vector 1 0.5 1))) (build-shells shell0 4 0.05 (vector 1 0.5 1)))
)
;---------------------------------------- ;----------------------------------------

2
hayfever/xmpp-dave.ss
View file

@ -298,7 +298,7 @@
(define xmpp-out-port (make-parameter (current-output-port))) (define xmpp-out-port (make-parameter (current-output-port)))
(define (xmpp-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)