scolobb/dds
1
0
Fork 0
Code Issues Pull requests Releases Wiki Activity

generic: Generalise fallback-dds-build-state-graph to work with annotations.

Browse source 
This function is now called fallback-dds-build-state-graph-edges and
it is parameterised by a function which produces the next states with
annotations (like dds-one-step-annotated).  The functions
dds-build-state-graph and dds-build-n-step-state-graph now fall back
to calling fallback-dds-build-state-graph-edges, passing it the
function dummy-annotated-dds-step-one to add a 'dummy annotation to
each new state produced.
This commit is contained in:
Sergiu Ivanov 2020-02-28 21:39:02 +01:00
parent fd290a049e
commit 601e8ed8b3
1 changed files with 53 additions and 15 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

66
generic.rkt
View file

@ -25,28 +25,52 @@
(apply set-union (for/list ([s ss]) (dds-step-one dds s))))
;;; Given a dds, a set of starting states, and a range whose length
;;; determines the number of steps to run, produces the state graph
;;; reachable from the starting steps in this many steps. This is a
;;; fallback for dds-build-state-graph and dds-build-n-step-state
;;; graph.
(define (fallback-dds-build-state-graph dds states step-range)
;;; determines the number of steps to run, produces the edges (and the
;;; edge labels) of the state graph reachable from the starting states
;;; in this many steps. The last argument is a function similar do
;;; dds-step-one-annotated: given a state, it should produce the set
;;; of next states, labelled with appropriate labels.
;;;
;;; This is a fallback for dds-build-state-graph,
;;; dds-build-n-step-state-graph, dds-build-state-graph-annotated, and
;;; dds-build-n-step-state-graph-annotated.
(define (fallback-dds-build-state-graph-edges dds states step-range step-func)
(for/fold ([edges empty]
[labels empty]
[current-states states]
[visited-states states]
#:result (directed-graph edges))
#:result (values edges labels))
([i step-range]
#:break (set-empty? current-states))
(for/fold ([new-edges empty]
[new-labels empty]
[new-states (set)]
#:result (values
(append edges new-edges)
(append labels new-labels)
(set-subtract new-states visited-states)
(set-union current-states visited-states)))
([s current-states])
(let ([ss-next (dds-step-one dds s)])
(for/fold ([edges-to-add empty]
[labels-to-add empty]
[states-to-add empty]
#:result (values
(append new-edges edges-to-add)
(append new-labels labels-to-add)
(set-union (list->set states-to-add) new-states)))
([next (set->list (step-func dds s))])
(match next
[(cons label s-next)
(values
(append new-edges (for/list ([s-next ss-next]) (list s s-next)))
(set-union ss-next new-states))))))
(cons (list s s-next) edges-to-add)
(cons label labels-to-add)
(cons s-next states-to-add))])))))
;;; Run dds-step-one, and produce a set of new states annotated with a
;;; 'dummy annotation.
(define (dummy-annotated-dds-step-one dds s)
(for/set ([new-s (dds-step-one dds s)])
(cons 'dummy new-s)))
;;; A discrete dynamical system.
(define-generics dds
@ -74,10 +98,24 @@
#:defined-predicate dds-implements?
#:fallbacks
[(define dds-step fallback-dds-step)
;; Run fallback-dds-build-state-graph-edges with an infinite range,
;; which will make it stop only when it has explored all the state
;; graph. Use dummy-annotated-dds-step-one to produce dummy edge
;; labels and then discard them.
(define (dds-build-state-graph dds states)
;; Run fallback-dds-build-state-graph with an infinite range,
;; which will make it stop only when it has explored all the
;; state graph.
(fallback-dds-build-state-graph dds states (in-naturals)))
(let-values ([(edges labels)
(fallback-dds-build-state-graph-edges
dds states (in-naturals)
dummy-annotated-dds-step-one)])
(directed-graph edges)))
;; Run fallback-dds-build-state-graph-edges within the given range.
;; Use dummy-annotated-dds-step-one to produce dummy edge labels
;; and then discard them.
(define (dds-build-n-step-state-graph dds states nsteps)
(fallback-dds-build-state-graph dds states (in-range nsteps)))])
(let-values ([(edges labels)
(fallback-dds-build-state-graph-edges
dds states (in-range nsteps)
dummy-annotated-dds-step-one)])
(directed-graph edges)))