150 lines
6.6 KiB
Racket
150 lines
6.6 KiB
Racket
#lang racket
|
|
|
|
;;; dds/generic
|
|
|
|
;;; Provides the definition of several generic interfaces for discrete
|
|
;;; dynamical systems.
|
|
|
|
(require racket/generic graph "utils.rkt")
|
|
|
|
(provide
|
|
;; Generics
|
|
gen:dds
|
|
;; Functions
|
|
(contract-out [dds-step-one (-> dds? any/c (set/c any/c))]
|
|
[dds-step-one-annotated (-> dds? any/c (set/c (cons/c any/c any/c)))]
|
|
[dds-step (-> dds? (set/c any/c #:kind 'dont-care) (set/c any/c))]
|
|
[dds-build-state-graph (-> dds? (set/c any/c #:kind 'dont-care) graph?)]
|
|
[dds-build-n-step-state-graph (-> dds? (set/c any/c #:kind 'dont-care) number? graph?)]
|
|
[dds-build-state-graph-annotated (-> dds? (set/c any/c #:kind 'dont-care) graph?)]
|
|
[dds-build-n-step-state-graph-annotated (-> dds? (set/c any/c #:kind 'dont-care) number? graph?)])
|
|
;; Predicates
|
|
(contract-out [dds? (-> any/c boolean?)]))
|
|
|
|
;;; Given a dds and a set of starting states, produce the set of
|
|
;;; states reachable in one step. This is a fallback for dds-step.
|
|
(define (fallback-dds-step dds ss)
|
|
(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 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 (collect-by-key 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])
|
|
(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 poor man's fallback for dds-step-one-annotated.
|
|
(define (fallback-dds-step-one-annotated dds s) (dds-step-one-annotated dds s))
|
|
|
|
;;; A discrete dynamical system.
|
|
(define-generics dds
|
|
;; Given a dds and a state, produce the next states of the dds.
|
|
;; This method has no fallback.
|
|
(dds-step-one dds state)
|
|
;; Given a dds and a state, produce the next states paired with some
|
|
;; annotation. Typical usage would include including the
|
|
;; information about the update mode. This method has no fallback.
|
|
(dds-step-one-annotated dds state)
|
|
;; Given a dds and a set of starting states, produce the set of
|
|
;; states reachable in one step. This method falls back to running
|
|
;; dds-step-one for all states.
|
|
(dds-step dds states)
|
|
;; Given a dds and a set of starting states, produces the state
|
|
;; graph reachable from the starting states. This method falls back
|
|
;; to exploring the state graph with dds-step-one.
|
|
(dds-build-state-graph dds states)
|
|
;; Given a dds, a set of starting states, and a number of steps to
|
|
;; run, produces the state graph reachable from the starting states
|
|
;; in this many steps. This method falls back to exploring the
|
|
;; state graph with dds-step-one.
|
|
(dds-build-n-step-state-graph dds states nsteps)
|
|
;; Given a dds and a set of starting states, produces the labelled
|
|
;; state graph reachable from the starting states. This method
|
|
;; falls back to exploring the state graph with
|
|
;; dds-step-one-annotated.
|
|
(dds-build-state-graph-annotated dds states)
|
|
;; Given a dds, a set of starting states, and a number of steps to
|
|
;; run, produces the labelled state graph reachable from the
|
|
;; starting states in this many steps. This method falls back to
|
|
;; exploring the state graph with dds-step-one-annotated.
|
|
(dds-build-n-step-state-graph-annotated dds states nsteps)
|
|
|
|
#: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)
|
|
(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)
|
|
(let-values ([(edges labels)
|
|
(fallback-dds-build-state-graph-edges
|
|
dds states (in-range nsteps)
|
|
dummy-annotated-dds-step-one)])
|
|
(directed-graph edges)))
|
|
|
|
(define (dds-build-state-graph-annotated dds states)
|
|
(let-values ([(edges labels)
|
|
(fallback-dds-build-state-graph-edges
|
|
dds states (in-naturals)
|
|
fallback-dds-step-one-annotated)])
|
|
(directed-graph edges labels)))
|
|
|
|
(define (dds-build-n-step-state-graph-annotated dds states nsteps)
|
|
(let-values ([(edges labels)
|
|
(fallback-dds-build-state-graph-edges
|
|
dds states (in-range nsteps)
|
|
fallback-dds-step-one-annotated)])
|
|
(directed-graph edges labels)))])
|