From 601e8ed8b32df9230d2892cd4c85daa160edb160 Mon Sep 17 00:00:00 2001
From: Sergiu Ivanov <sivanov@colimite.fr>
Date: Fri, 28 Feb 2020 21:39:02 +0100
Subject: [PATCH] generic: Generalise fallback-dds-build-state-graph to work
 with annotations.

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.
---
 generic.rkt | 68 +++++++++++++++++++++++++++++++++++++++++------------
 1 file changed, 53 insertions(+), 15 deletions(-)

diff --git a/generic.rkt b/generic.rkt
index ed8feed..19635de 100644
--- a/generic.rkt
+++ b/generic.rkt
@@ -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)])
-        (values
-         (append new-edges (for/list ([s-next ss-next]) (list s s-next)))
-         (set-union ss-next new-states))))))
+      (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
+            (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)))