syndicate-lang
/
syndicate-2017
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

subgraph stuff working better

This commit is contained in:
Sam Caldwell 2019-06-10 13:59:19 -04:00
parent c38bfdc2c0
commit 458bf93fef
1 changed files with 131 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

163
racket/typed/proto.rkt
View File

@ -1215,6 +1215,29 @@
;; --------------------------------------------------------------------------- ;; ---------------------------------------------------------------------------
;; SubGraphs ;; SubGraphs
;; Role Role -> (Listof RoleGraph)
;; Find all subgraphs of the implementation role that simulate the spec role
(define (simulating-subgraphs impl spec)
(define spec-rg (compile spec))
(define impl-rg (compile impl))
(define evts (relevant-events spec-rg))
(for/list ([srg (subgraphs impl-rg evts)]
#:when (simulates?/rg srg impl spec-rg spec))
srg))
(module+ test
(test-case
"task manager has task performer subgraphs"
(define tpr (parse-T task-performer-spec))
(define tmr (parse-T task-manager-ty))
(define ans (simulating-subgraphs tmr tpr))
(check-equal? (length ans) 4)
(define tprg (compile tpr))
(check-true (simulates?/rg (first ans) tmr tprg tpr))
(check-true (simulates?/rg (second ans) tmr tprg tpr))
(check-true (simulates?/rg (third ans) tmr tprg tpr))
(check-true (simulates?/rg (fourth ans) tmr tprg tpr))))
;; RoleGraph (Setof τ) -> (Sequenceof RoleGraph) ;; RoleGraph (Setof τ) -> (Sequenceof RoleGraph)
;; generate non-empty subgraphs, where at least the given assertions are enabled ;; generate non-empty subgraphs, where at least the given assertions are enabled
(define (subgraphs rg as) (define (subgraphs rg as)
@ -1229,37 +1252,113 @@
τ] τ]
[_ D]))) [_ D])))
(in-generator (in-generator
(for* ([states* (in-combinations (hash-keys state#))] (define cache (mutable-set))
[events* (in-combinations (set->list all-events))] (for* ([states* (in-combinations (hash-keys state#))]
[event-set (in-value (list->set events*))] [events* (in-combinations (set->list all-events))]
#:when (assertion-superset? (set-remove event-set DataflowEvt) as)) [event-set (in-value (list->set events*))]
(define states (list->set states*)) #:when (assertion-superset? (set-remove event-set DataflowEvt) as))
(define (event-enabled? D) (define states (list->set states*))
(for/or ([e (in-set event-set)]) (define (event-enabled? D)
(or (equal? DataflowEvt e) (for/or ([e (in-set event-set)])
(D<:? D (Know e)) (or (equal? DataflowEvt e)
(D<:? D (¬Know e))))) (D<:? D (Know e))
#;(define implied-events (D<:? D (¬Know e)))))
(for*/set ([evt (in-list events*)] (define st#
[evt+ (in-set all-events)] (for/hash ([st (in-list states*)])
#:when (D<:? evt evt+)) (define orig-txn# (state-transitions (hash-ref state# st)))
evt+)) (define txn#
;; TODO - difference between Know and ¬Know should be ignored (for*/hash ([(D dests) (in-hash orig-txn#)]
#;(define active-events (set-union implied-events (list->set events*))) #:when (event-enabled? D)
(define st# [dests+ (in-value (set-intersect dests states))]
(for/hash ([st (in-list states*)]) ;; empty dests+ might mean want to ignore this set of
(define orig-txn# (state-transitions (hash-ref state# st))) ;; events? TODO
(define txn# #:unless (set-empty? dests+))
(for*/hash ([(D dests) (in-hash orig-txn#)] (values D dests+)))
#:when (event-enabled? D) (values st (state st txn#))))
[dests+ (in-value (set-intersect dests states))] (for ([st0 (in-list states*)])
;; empty dests+ might mean want to ignore this set of (define rg (role-graph st0 st#))
;; events? TODO (unless (set-member? cache rg)
#:unless (set-empty? dests+)) (define reachable (reachable-states rg))
(values D dests+))) (define all-inc?
(values st (state st txn#)))) (for/and ([st (in-set states)])
(for ([st0 (in-list states*)]) (set-member? reachable st)))
(yield (role-graph st0 st#)))))) (when all-inc?
(yield rg))
(set-add! cache rg))))))
;; RoleGraph -> (Setof StateName)
;; Determine the set of states reachable from the starting state
(define (reachable-states rg)
(match-define (role-graph st0 state#) rg)
(let search ([work (list st0)]
[seen (set)])
(match work
['() seen]
[(cons current more)
(match-define (state name txn#) (hash-ref state# current))
(cond
[(set-member? seen name)
(search more seen)]
[else
(define connections
(for*/list ([dests (in-hash-values txn#)]
[d (in-set dests)])
d))
(search (append more connections)
(set-add seen name))])])))
(module+ test
(test-case
"reachable states"
(define rg
(role-graph (set 'X 'Y 'Z)
(hash (set 'X 'Y 'Z) (state (set 'X 'Y 'Z) (hash (Know Int) (set (set 'X 'Y 'Z))
(¬Know Int) (set (set 'X 'Y))))
(set 'X) (state (set 'X) '#hash())
(set 'X 'Y) (state (set 'X 'Y) (hash (Know Int) (set (set 'X 'Y 'Z)))))))
(define reachable (reachable-states rg))
(check-true (set-member? reachable (set 'X 'Y 'Z)))
(check-true (set-member? reachable (set 'X 'Y)))
(check-false (set-member? reachable (set 'X))))
(test-case
"struct seems to make a difference?"
(define rg
(role-graph
(set 'during-inner2 'during-inner1 'tm)
(hash
(set 'during-inner2 'during-inner1 'tm)
(state
(set 'during-inner2 'during-inner1 'tm)
(hash
(Know (Struct 'TaskAssignment (list)))
(set (set 'during-inner2 'during-inner1 'tm))
(¬Know (Struct 'TaskAssignment (list)))
(set (set 'during-inner1 'tm))))
(set 'tm)
(state (set 'tm) '#hash())
(set 'during-inner1 'tm)
(state
(set 'during-inner1 'tm)
(hash
(Know (Struct 'TaskAssignment (list)))
(set (set 'during-inner2 'during-inner1 'tm)))))))
(define reachable (reachable-states rg))
(check-true (set-member? reachable (set 'during-inner2 'during-inner1 'tm)))
(check-true (set-member? reachable (set 'during-inner1 'tm)))
(check-false (set-member? reachable (set 'tm)))))
;; RoleGraph -> (Setof (U τ DataflowEvt))
;; extract the assertions that cause transitions, and dataflow events if they
;; occur
(define (relevant-events rg)
(match-define (role-graph _ state#) rg)
(for*/set ([st (in-hash-values state#)]
[txn# (in-value (state-transitions st))]
[D (in-hash-keys txn#)])
(match D
[(or (Know τ) (¬Know τ))
τ]
[_ D])))
;; --------------------------------------------------------------------------- ;; ---------------------------------------------------------------------------
;; Visualization ;; Visualization
@ -1274,7 +1373,7 @@
#:name [name #f]) #:name [name #f])
(match-define (role-graph st0 st#) rg) (match-define (role-graph st0 st#) rg)
(define graph-name (or name "Roles")) (define graph-name (or name "Roles"))
(define entry-node (format "~a;" (state-name->dot-name st0))) (define entry-node (format "~a [style=bold];" (state-name->dot-name st0)))
(define edges (define edges
(for/list ([(sn st) (in-hash st#)]) (for/list ([(sn st) (in-hash st#)])
(define dot-name (state-name->dot-name sn)) (define dot-name (state-name->dot-name sn))