120 lines
5.1 KiB
Racket
120 lines
5.1 KiB
Racket
#lang prospect
|
|
|
|
(require racket/set)
|
|
(require "../route.rkt")
|
|
(require "../demand-matcher.rkt")
|
|
(require "../drivers/timer.rkt")
|
|
|
|
(spawn-timer-driver)
|
|
|
|
(spawn (lambda (e old-count)
|
|
(match e
|
|
[(? patch?)
|
|
(define-values (in out)
|
|
(patch-project/set e (compile-projection `(parent ,(?!) ,(?!)))))
|
|
(define new-count (+ old-count (set-count in) (- (set-count out))))
|
|
(printf "New parent-record count: ~v\n" new-count)
|
|
(transition new-count
|
|
(list (retract `(parent-count ,?))
|
|
(assert `(parent-count ,new-count))))]
|
|
[_ #f]))
|
|
0
|
|
(sub `(parent ,? ,?))
|
|
(assert `(parent-count 0)))
|
|
|
|
(define (insert-record record . monitors)
|
|
(printf "Record ~v inserted, depending on ~v\n" record monitors)
|
|
(spawn (lambda (e s)
|
|
(match e
|
|
[(? patch/removed?)
|
|
(printf "Retracting ~v because dependencies ~v vanished\n"
|
|
record
|
|
(set->list (matcher-project/set (patch-removed e) (compile-projection (?!)))))
|
|
(quit)]
|
|
[(message `(retract ,(== record)))
|
|
(printf "Retracting ~v because we were told to explicitly\n" record)
|
|
(quit)]
|
|
[_ #f]))
|
|
(void)
|
|
(assert record)
|
|
(sub `(retract ,record))
|
|
(patch-seq* (map sub monitors))))
|
|
|
|
(insert-record `(parent john douglas))
|
|
(insert-record `(parent bob john))
|
|
(insert-record `(parent ebbon bob))
|
|
|
|
(spawn (lambda (e s)
|
|
(match e
|
|
[(? patch?)
|
|
(transition s
|
|
(for/list [(AB (matcher-project/set
|
|
(patch-added e)
|
|
(compile-projection `(parent ,(?!) ,(?!)))))]
|
|
(match-define (list A B) AB)
|
|
(insert-record `(ancestor ,A ,B)
|
|
`(parent ,A ,B))))]
|
|
[_ #f]))
|
|
(void)
|
|
(sub `(parent ,? ,?)))
|
|
|
|
(spawn (lambda (e s)
|
|
(match e
|
|
[(? patch?)
|
|
(transition s
|
|
(for/list [(AC (matcher-project/set
|
|
(patch-added e)
|
|
(compile-projection `(parent ,(?!) ,(?!)))))]
|
|
(match-define (list A C) AC)
|
|
(printf "Inductive step for ~v asserted\n" `(parent ,A ,C))
|
|
(spawn (lambda (e s)
|
|
(define removed-parents
|
|
(and (patch? e)
|
|
(matcher-project (patch-removed e)
|
|
(compile-projection
|
|
`(parent ,(?!) ,(?!))))))
|
|
(if (matcher-non-empty? removed-parents)
|
|
(begin
|
|
(printf
|
|
"Inductive step for ~v retracted because of removal ~v\n"
|
|
`(parent ,A ,C)
|
|
(matcher-key-set removed-parents))
|
|
(quit))
|
|
(and (patch? e)
|
|
(transition s
|
|
(for/list [(CB (matcher-project/set
|
|
(patch-added e)
|
|
(compile-projection
|
|
`(ancestor ,(?!) ,(?!)))))]
|
|
(match-define (list _ B) CB)
|
|
(insert-record `(ancestor ,A ,B)
|
|
`(parent ,A ,C)
|
|
`(ancestor ,C ,B)))))))
|
|
(void)
|
|
(sub `(parent ,A ,C))
|
|
(sub `(ancestor ,C ,?)))))]
|
|
[_ #f]))
|
|
(void)
|
|
(sub `(parent ,? ,?)))
|
|
|
|
(define (after msec thunk)
|
|
(define id (gensym 'after))
|
|
(if (zero? msec)
|
|
(thunk)
|
|
(list
|
|
(spawn (lambda (e s) (and (message? e) (quit (thunk))))
|
|
(void)
|
|
(sub (timer-expired id ?)))
|
|
(message (set-timer id msec 'relative)))))
|
|
|
|
(define use-delays? #t)
|
|
|
|
(after (if use-delays? 1000 0) (lambda ()
|
|
(printf "----- Retracting\n")
|
|
(message `(retract (parent bob john)))))
|
|
(after (if use-delays? 2000 0) (lambda ()
|
|
(printf "----- Asserting\n")
|
|
(list (insert-record `(parent bob mary))
|
|
(insert-record `(parent mary sue))
|
|
(insert-record `(parent sue john)))))
|