70 lines
2.4 KiB
Scheme
70 lines
2.4 KiB
Scheme
#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)
|
|
(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))
|
|
|