diff --git a/plant-eyes/jabberer.ss b/plant-eyes/jabberer.ss index 64146f8..becf28a 100644 --- a/plant-eyes/jabberer.ss +++ b/plant-eyes/jabberer.ss @@ -6,7 +6,6 @@ ; and sent by the game (define debug-netloop #f) -(define debug-jab #f) (define jabberer% (class object% @@ -35,15 +34,14 @@ msg)) (define/public (send-msg to msg) - (set! outgoing (cons (list to msg) outgoing))) + (set! outgoing (append outgoing (list (list to msg)))) + #;(printf "~a~n" outgoing)) (define (message-handler sz) (when debug-jab (printf "rx <---- ~a ~a~n" (xmpp:message-from sz) (xmpp:message-body sz))) (set! incoming (cons (list (xmpp:message-from sz) (xmpp:message-body sz)) incoming))) (define/public (start) - (xmpp:add-to-roster jid "plant0000003@fo.am" "plant0000003" "plants@fo.am") - (xmpp:add-to-roster jid "plant0000001@fo.am" "plant0000001" "plants@fo.am") (set! thr (thread run))) (define/public (stop) diff --git a/plant-eyes/list-utils.ss b/plant-eyes/list-utils.ss index 59bd821..27b755c 100644 --- a/plant-eyes/list-utils.ss +++ b/plant-eyes/list-utils.ss @@ -20,3 +20,18 @@ ((eq? (car l) k) #t) (else (list-contains k (cdr l))))) +(define (string-split s c) + (define (_ sl tl cl) + (cond + ((null? sl) (if (null? cl) tl (append tl (list (list->string cl))))) + ((eq? (car sl) c) + (_ (cdr sl) (append tl (list (list->string cl))) '())) + (else + (_ (cdr sl) tl (append cl (list (car sl))))))) + (_ (string->list s) '() '())) + +(define (list-string-concat l t) + (cond + ((null? l) "") + (else + (string-append (car l) t (list-string-concat (cdr l) t))))) \ No newline at end of file diff --git a/plant-eyes/message.ss b/plant-eyes/message.ss index b1a9f25..3d27586 100644 --- a/plant-eyes/message.ss +++ b/plant-eyes/message.ss @@ -1,23 +1,69 @@ #lang scheme/base -(require scheme/class) +(require scheme/class "list-utils.ss") (provide (all-defined-out)) ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ; a message for sending betwixt logic and view side (define-serializable-class* message% object% () - (init-field - (name 'none) ; a symbol denoting the type of the message - (data '())) ; should be an assoc list map of name to values, eg: - ; '((name "archibold") (age 53)) - ; shouldn't put logic objects in here - 'raw' data only - - (define/public (get-name) - name) + (init-field + (name 'none) ; a symbol denoting the type of the message + (data '())) ; should be an assoc list map of name to values, eg: + ; '((name "archibold") (age 53)) + ; shouldn't put logic objects in here - 'raw' data only - (define/public (get-data arg-name) - (cadr (assoc arg-name data))) - - (define/public (print) - (printf "msg: ~a ~a~n" name data)) - - (super-new)) + (define/public (get-name) + name) + + (define/public (get-data arg-name) + (cadr (assoc arg-name data))) + + (define/public (print) + (printf "msg: ~a ~a~n" name data)) + + (define/public (to-string) + (string-append (symbol->string name) " " (nvpairs->string data ""))) + + (define/public (from-string str) + (let ((tokens (string-split str #\ ))) + (set! name (string->symbol (car tokens))) + (set! data (string->nvpairs (list-string-concat (cdr tokens) " ") '())))) + + (define (value->string a) + (cond + ((number? a) (string-append "n:" (number->string a))) + ((string? a) (string-append "s:" a)) + ((vector? a) (string-append "v:" (number->string (vector-ref a 0)) "," + (number->string (vector-ref a 1)) "," + (number->string (vector-ref a 2)))) + ((symbol? a) (string-append "y:" (symbol->string a))) + (else (error "unsupported arg type for " a)))) + + (define (nvpairs->string l s) + (cond + ((null? l) s) + (else + (nvpairs->string (cdr l) (string-append s (symbol->string (caar l)) "=" + (value->string (cadr (car l))) " "))))) + + (define (string->value a) + (cond + ((string=? (car a) "n") (string->number (cadr a))) + ((string=? (car a) "s") (cadr a)) + ((string=? (car a) "v") + (let ((v (string-split (cadr a) #\,))) + (vector (string->number (list-ref v 0)) + (string->number (list-ref v 1)) + (string->number (list-ref v 2))))) + ((string=? (car a) "y") (string->symbol (cadr a))) + (else (error "unsupported value type for " a)))) + + (define (string->nvpairs s l) + (map + (lambda (pair) + (let ((nv (string-split pair #\=))) + (list (string->symbol (car nv)) + (string->value (string-split (cadr nv) #\:))))) + (string-split s #\ ))) + + (super-new)) + diff --git a/plant-eyes/plant-eyes.scm b/plant-eyes/plant-eyes.scm index 1d43d60..78a6acf 100644 --- a/plant-eyes/plant-eyes.scm +++ b/plant-eyes/plant-eyes.scm @@ -1,8 +1,11 @@ -;#lang scheme/base -;(require fluxus-016/drflux) +#lang scheme/base +(require fluxus-016/drflux) (require scheme/class "logic.ss" "view.ss" "controller.ss" "client.ss") (require "jabberer.ss") +(define jid "plant0000001@fo.am") +(define pass "plant0000001") + ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ; p l a n t e y e s ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -36,9 +39,6 @@ ; * in the same way, the line segments can be created in any way by the logic ; side - eg. lsystem, or different methods per plant (or per twig even) -(define jid "plant0000002@fo.am") -(define pass "plant0000002") - (define logic-tick 0.5) ; time between logic updates (clear) @@ -80,7 +80,8 @@ (pt-update) (sleep 0.01)) -#;(for ((i (in-range 0 10000))) +#;(for ((i (in-range 0 100000))) + ; (sleep 0.4) (animate)) (every-frame (animate)) diff --git a/plant-eyes/view.ss b/plant-eyes/view.ss index c1cf534..7738bfc 100644 --- a/plant-eyes/view.ss +++ b/plant-eyes/view.ss @@ -317,6 +317,7 @@ (opacity 0.6) (colour (vector 0.8 1 0.6)) (hint-depth-sort) + (printf "size=~a~n" size) (scale (* 0.12 size)) (when wire-mode (hint-none) @@ -508,7 +509,9 @@ (set! plants (cons (list (send plant get-id) plant) plants))) (define/public (get-plant plant-id) - (cadr (assq plant-id plants))) + (let ((p (assoc plant-id plants))) + (when (not p) (error "plant id does not exist " plant-id)) + (cadr p))) (define/public (add-branch-twig plant-id twig) (send (get-plant plant-id) add-branch-twig twig)) @@ -562,9 +565,11 @@ (send msg get-data 'size)))) ((eq? (send msg get-name) 'new-plant) + (printf "adding new plant to view ~a~n" (send msg get-data 'plant-id)) (add-plant (make-object plant-view% (send msg get-data 'plant-id) - (send msg get-data 'pos)))) + (send msg get-data 'pos) + (send msg get-data 'size)))) ((eq? (send msg get-name) 'grow-seed) (grow-seed (send msg get-data 'plant-id)