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

first pass network working - for twig growth, duplicates the view changes ok

Browse source
This commit is contained in:
Dave Griffiths 2009-07-21 17:33:26 +01:00
parent e1c55a2457
commit 61ca4a0e6e
5 changed files with 93 additions and 28 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

6
plant-eyes/jabberer.ss
View file

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

15
plant-eyes/list-utils.ss
View file

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

78
plant-eyes/message.ss
View file

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

13
plant-eyes/plant-eyes.scm
View file

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

9
plant-eyes/view.ss
View file

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