subgraph stuff working better
This commit is contained in:
parent
c38bfdc2c0
commit
458bf93fef
|
@ -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))
|
||||||
|
|
Loading…
Reference in New Issue