2016-07-10 16:33:16 +00:00
|
|
|
#lang syndicate/actor
|
2016-03-01 04:35:06 +00:00
|
|
|
;; A toy spreadsheet model.
|
|
|
|
|
|
|
|
(require racket/set)
|
|
|
|
|
|
|
|
(define-namespace-anchor ns)
|
|
|
|
|
|
|
|
(struct cell (name value) #:transparent) ;; assertion
|
|
|
|
(struct set-cell (name expr) #:transparent) ;; message
|
|
|
|
|
|
|
|
(define (binding-symbol? s)
|
|
|
|
(and (symbol? s)
|
|
|
|
(let ((chars (string->list (symbol->string s))))
|
|
|
|
(and (andmap char-alphabetic? chars)
|
|
|
|
(pair? chars)
|
|
|
|
(char-upper-case? (car chars))))))
|
|
|
|
|
|
|
|
(define (extract-bindings expr)
|
|
|
|
(let walk ((expr expr))
|
|
|
|
(match expr
|
|
|
|
[(? binding-symbol? b) (set b)]
|
|
|
|
[(cons a d) (set-union (walk a) (walk d))]
|
|
|
|
[_ (set)])))
|
|
|
|
|
2016-07-09 20:18:30 +00:00
|
|
|
(define (non-void-field? f) (not (void? (f))))
|
2016-03-01 04:35:06 +00:00
|
|
|
|
|
|
|
(define (cell-expr->actor-expr name expr)
|
|
|
|
(define bindings (set->list (extract-bindings expr)))
|
|
|
|
`(actor (until (message (set-cell ',name _))
|
2016-07-09 20:18:30 +00:00
|
|
|
(field ,@(for/list [(b bindings)] `[,b (void)]))
|
|
|
|
(assert #:when (andmap non-void-field? (list ,@bindings))
|
|
|
|
(cell ',name
|
|
|
|
(let (,@(for/list [(b bindings)] `(,b (,b))))
|
|
|
|
,expr)))
|
2016-03-01 04:35:06 +00:00
|
|
|
,@(for/list [(b bindings)]
|
|
|
|
`(on (asserted (cell ',b $value))
|
2016-07-09 20:18:30 +00:00
|
|
|
(,b value))))))
|
2016-03-01 04:35:06 +00:00
|
|
|
|
2016-07-09 20:18:30 +00:00
|
|
|
(actor (react (on (message (set-cell $name $expr))
|
|
|
|
(define actor-expr (cell-expr->actor-expr name expr))
|
|
|
|
;; (local-require racket/pretty) (pretty-print actor-expr)
|
|
|
|
(eval actor-expr (namespace-anchor->namespace ns)))))
|
2016-03-01 04:35:06 +00:00
|
|
|
|
2016-07-09 20:18:30 +00:00
|
|
|
(actor (react (on (asserted (cell $name $value))
|
|
|
|
(printf ">>> ~a ~v\n" name value)
|
|
|
|
(flush-output))))
|
2016-03-01 04:35:06 +00:00
|
|
|
|
|
|
|
(actor (void (thread (lambda ()
|
|
|
|
(let loop ()
|
|
|
|
(define cell-name (read))
|
|
|
|
(if (eof-object? cell-name)
|
|
|
|
(send-ground-message 'quit)
|
|
|
|
(let ((new-expr (read)))
|
|
|
|
(send-ground-message (set-cell cell-name new-expr))
|
|
|
|
(loop)))))))
|
2016-07-30 17:02:07 +00:00
|
|
|
(until (message (inbound 'quit))
|
|
|
|
(on (message (inbound (set-cell $name $expr)))
|
2016-03-01 04:35:06 +00:00
|
|
|
(send! (set-cell name expr)))))
|