groworld/plant-eyes/scripts/message.ss

;; p l a n t   e y e s  [ copyright (c) 2009 foam vzw : gpl v3 ]

#lang scheme/base
(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)  
  
  (define/public (get-data arg-name)
    (let ((a (assoc arg-name data)))
	  (if a (cadr a) (error "message arg not found " arg-name))))
  
  (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))