> {-# OPTIONS_HADDOCK show-extensions #-}
> {-|
> Module    : LTK.Algebra
> Copyright : (c) 2021-2023 Dakotah Lambert
> License   : MIT

> This module centralizes definitions of some commonly used
> algebraic properties.
>
> @since 1.0
> -}

> module LTK.Algebra
>     ( -- *Type
>       SynMon
>       -- *Tests
>     , isCommutative
>       -- *Generated Submonoids and Subsemigroups
>     , me
>     , emee
>     , ese
>       -- * Other generation
>     , syntacticOrder
>     , emblock
>       -- *Powers
>     , idempotents
>     , omega
>     ) where

> import Data.Set (Set)
> import qualified Data.Set as Set

> import LTK.FSA

> type S n e = (n, [Symbol e])
> type T n e = State (S n e)

> -- | A simpler way to denote syntactic monoids in type signatures.
> type SynMon n e = FSA ([Maybe n],[Symbol e]) e


Generated Submonoids
====================

For a monid M and idempotent e, Me is the set generated by
    {m : e is in the two-sided ideal of m}.

The class MeV, for some variety V, is the set of all monoids M
where for all idempotents e, e*Me*e is in V.

> -- |For a given idempotent \(e\), return the set generated by
> -- \(\{m : (\exists u,v)[umv=e]\}\).
> me :: (Ord n, Ord e) => FSA (S n e) e -> T n e -> Set (T n e)
> me :: forall n e. (Ord n, Ord e) => FSA (S n e) e -> T n e -> Set (T n e)
me FSA (S n e) e
monoid T n e
e = forall e n. (Ord e, Ord n) => FSA n e -> Set (State n)
states forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e n. (Ord e, Ord n) => FSA n e -> FSA n e
trimUnreachables
>               forall a b. (a -> b) -> a -> b
$ forall a b. (Ord a, Ord b) => Set b -> FSA a b -> FSA a b
contractAlphabetTo Set e
syms FSA (S n e) e
monoid
>     where syms :: Set e
syms = forall (s :: * -> *) a.
(Collapsible s, Container (s a) a) =>
(a -> Bool) -> s a -> s a
keep (forall c a. (Container c a, Eq a) => a -> c -> Bool
contains T n e
e forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions
>                        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (forall n e. (Ord n, Ord e) => FSA (S n e) e -> T n e -> Set (T n e)
primitiveIdeal2 FSA (S n e) e
monoid) forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> Set (T n e)
s)
>                  forall a b. (a -> b) -> a -> b
$ forall (g :: * -> *) e. HasAlphabet g => g e -> Set e
alphabet FSA (S n e) e
monoid
>           s :: e -> Set (T n e)
s e
x = forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions
>                 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (forall n e.
(Ord n, Ord e) =>
FSA n e -> [Symbol e] -> State n -> Set (State n)
follow FSA (S n e) e
monoid [forall e. e -> Symbol e
Symbol e
x])
>                 forall a b. (a -> b) -> a -> b
$ forall n e. FSA n e -> Set (State n)
initials FSA (S n e) e
monoid

emee is e*Me*e: first follow the label of e from all the states,
then take the resulting labels and follow those from e.

> -- |For a given idempotent \(e\), return the set @me monoid e@
> -- multiplied on the left and right by \(e\).
> emee :: (Ord n, Ord e) => FSA (S n e) e -> T n e -> Set (T n e)
> emee :: forall n e. (Ord n, Ord e) => FSA (S n e) e -> T n e -> Set (T n e)
emee FSA (S n e) e
monoid T n e
e = forall (c :: * -> *) a b.
Collapsible c =>
(a -> b -> b) -> b -> c a -> b
collapse (forall c a. Container c a => c -> c -> c
union forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall n e.
(Ord n, Ord e) =>
FSA n e -> [Symbol e] -> State n -> Set (State n)
follow FSA (S n e) e
monoid) T n e
e forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a} {c}. State (a, c) -> c
s) forall c a. Container c a => c
empty
>                 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (c :: * -> *) a b.
Collapsible c =>
(a -> b -> b) -> b -> c a -> b
collapse (forall c a. Container c a => c -> c -> c
union forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n e.
(Ord n, Ord e) =>
FSA n e -> [Symbol e] -> State n -> Set (State n)
follow FSA (S n e) e
monoid (forall {a} {c}. State (a, c) -> c
s T n e
e)) forall c a. Container c a => c
empty
>                 forall a b. (a -> b) -> a -> b
$ Set (T n e)
x
>     where x :: Set (T n e)
x = forall n e. (Ord n, Ord e) => FSA (S n e) e -> T n e -> Set (T n e)
me FSA (S n e) e
monoid T n e
e
>           s :: State (a, c) -> c
s = forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. State n -> n
nodeLabel

ese is e*S*e: first go wherever you can from e, then take another e.

> -- |The semigroup multiplied on the left and right
> -- by the given idempotent.
> ese :: (Ord n, Ord e) => FSA (S n e) e -> T n e -> Set (T n e)
> ese :: forall n e. (Ord n, Ord e) => FSA (S n e) e -> T n e -> Set (T n e)
ese FSA (S n e) e
sg T n e
e = forall (c :: * -> *) a b.
Collapsible c =>
(a -> b -> b) -> b -> c a -> b
collapse (forall c a. Container c a => c -> c -> c
union forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n e.
(Ord n, Ord e) =>
FSA n e -> [Symbol e] -> State n -> Set (State n)
follow FSA (S n e) e
sg (forall {a} {c}. State (a, c) -> c
s T n e
e)) forall c a. Container c a => c
empty Set (T n e)
es
>     where es :: Set (T n e)
es = forall n e. (Ord n, Ord e) => FSA n e -> State n -> Set (State n)
primitiveIdealR FSA (S n e) e
sg T n e
e
>           s :: State (a, c) -> c
s = forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. State n -> n
nodeLabel


Commutativity
=============

Testing commutativity by checking that all elements commute with one another.

> -- |True iff the supplied elements commute with one another
> -- in the provided monoid.
> isCommutative :: (Ord n, Ord e) =>
>                  FSA (n, [Symbol e]) e -> Set (State (n, [Symbol e])) ->
>                  Bool
> isCommutative :: forall n e.
(Ord n, Ord e) =>
FSA (n, [Symbol e]) e -> Set (State (n, [Symbol e])) -> Bool
isCommutative FSA (n, [Symbol e]) e
f Set (State (n, [Symbol e]))
ss = forall (s :: * -> *) a. Collapsible s => (a -> Bool) -> s a -> Bool
allS (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry State (n, [Symbol e]) -> State (n, [Symbol e]) -> Bool
commute) (forall a. Ord a => Set a -> Set (a, a)
pairs Set (State (n, [Symbol e]))
ss)
>     where commute :: State (n, [Symbol e]) -> State (n, [Symbol e]) -> Bool
commute State (n, [Symbol e])
u State (n, [Symbol e])
v = forall n e.
(Ord n, Ord e) =>
FSA n e -> [Symbol e] -> State n -> Set (State n)
follow FSA (n, [Symbol e]) e
f (forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall n. State n -> n
nodeLabel State (n, [Symbol e])
u) State (n, [Symbol e])
v forall a. Eq a => a -> a -> Bool
==
>                         forall n e.
(Ord n, Ord e) =>
FSA n e -> [Symbol e] -> State n -> Set (State n)
follow FSA (n, [Symbol e]) e
f (forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall n. State n -> n
nodeLabel State (n, [Symbol e])
v) State (n, [Symbol e])
u


Powers
======

An element x is idempotent iff xx == x.
Here we use the syntactic monoid and simply exclude the identity
if it does not appear in the syntactic semigroup.

> -- |All elements \(e\) of the given monoid such that \(e*e=e\).
> -- Except the null word.  Add that manually if you need it.
> idempotents :: (Ord n, Ord e) =>
>                FSA (n, [Symbol e]) e -> Set (T n e)
> idempotents :: forall n e. (Ord n, Ord e) => FSA (n, [Symbol e]) e -> Set (T n e)
idempotents FSA (n, [Symbol e]) e
f = forall (s :: * -> *) a.
(Collapsible s, Container (s a) a) =>
(a -> Bool) -> s a -> s a
keep T n e -> Bool
isIdem forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (s :: * -> *) b1 b a.
(Collapsible s, Container (s b1) b) =>
(a -> b) -> s a -> s b1
tmap forall n e. Transition n e -> State n
destination forall a b. (a -> b) -> a -> b
$ forall n e. FSA n e -> Set (Transition n e)
transitions FSA (n, [Symbol e]) e
f
>     where isIdem :: T n e -> Bool
isIdem T n e
x = forall n e.
(Ord n, Ord e) =>
FSA n e -> [Symbol e] -> State n -> Set (State n)
follow FSA (n, [Symbol e]) e
f (forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall n. State n -> n
nodeLabel T n e
x) T n e
x forall a. Eq a => a -> a -> Bool
== forall c a. Container c a => a -> c
singleton T n e
x

> -- |@omega monoid s@ is the unique element \(t\) where \(t*t\) = \(t\)
> -- and \(t\) is in \(\{s, s^2, s^3, \ldots\}\).
> -- In other words, \(t\) is the unique idempotent element
> -- in this set.
> omega :: (Ord n, Ord e) => FSA (S n e) e -> T n e -> T n e
> omega :: forall n e. (Ord n, Ord e) => FSA (S n e) e -> T n e -> T n e
omega FSA (n, [Symbol e]) e
monoid State (n, [Symbol e])
s = forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> (a -> a) -> a -> a
until (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a. Eq a => a -> a -> Bool
(==)) (\(State (n, [Symbol e])
a,State (n, [Symbol e])
_) -> State (n, [Symbol e])
-> (State (n, [Symbol e]), State (n, [Symbol e]))
f (State (n, [Symbol e]) -> State (n, [Symbol e])
next State (n, [Symbol e])
a)) forall a b. (a -> b) -> a -> b
$ State (n, [Symbol e])
-> (State (n, [Symbol e]), State (n, [Symbol e]))
f State (n, [Symbol e])
s
>     where square :: State (n, [Symbol e]) -> State (n, [Symbol e])
square State (n, [Symbol e])
x = forall a. Set a -> a
Set.findMin forall a b. (a -> b) -> a -> b
$ forall n e.
(Ord n, Ord e) =>
FSA n e -> [Symbol e] -> State n -> Set (State n)
follow FSA (n, [Symbol e]) e
monoid (forall a b. (a, b) -> b
snd (forall n. State n -> n
nodeLabel State (n, [Symbol e])
x)) State (n, [Symbol e])
x
>           next :: State (n, [Symbol e]) -> State (n, [Symbol e])
next   State (n, [Symbol e])
x = forall a. Set a -> a
Set.findMin forall a b. (a -> b) -> a -> b
$ forall n e.
(Ord n, Ord e) =>
FSA n e -> [Symbol e] -> State n -> Set (State n)
follow FSA (n, [Symbol e]) e
monoid (forall a b. (a, b) -> b
snd (forall n. State n -> n
nodeLabel State (n, [Symbol e])
s)) State (n, [Symbol e])
x
>           f :: State (n, [Symbol e])
-> (State (n, [Symbol e]), State (n, [Symbol e]))
f      State (n, [Symbol e])
x = (State (n, [Symbol e])
x, State (n, [Symbol e]) -> State (n, [Symbol e])
square State (n, [Symbol e])
x)

> -- |Construct a monoid based on the idempotent paths
> -- as described by Straubing (1985).  Elements are of the form
> -- \((e,esf,f)\) for idempotents \(e\) and \(f\) and arbitrary \(s\).
> --
> -- @since 1.1
> emblock :: (Ord n, Ord e) => SynMon n e -> SynMon Integer Integer
> emblock :: forall n e. (Ord n, Ord e) => SynMon n e -> SynMon Integer Integer
emblock = forall e n.
(Ord e, Ord n) =>
FSA n e -> FSA ([Maybe n], [Symbol e]) e
syntacticMonoid forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e n n1.
(Ord e, Ord n, Ord n1, Enum n1) =>
FSA n e -> FSA n1 e
renameStates forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {e} {e1} {n}.
(Ord e, Ord e1, Ord n, Enum e1, Num e1) =>
FSA n e -> FSA n e1
renameSymbols forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n e.
(Ord n, Ord e) =>
SynMon n e -> FSA ([e], [e], [e]) ([e], [e], [e])
emblock'
>     where renameSymbols :: FSA n e -> FSA n e1
renameSymbols FSA n e
f = forall e e1 n.
(Ord e, Ord e1, Ord n) =>
(e -> e1) -> FSA n e -> FSA n e1
renameSymbolsBy e -> e1
index FSA n e
f
>               where syms :: [(e, e1)]
syms = forall a b. [a] -> [b] -> [(a, b)]
zip (forall a. Set a -> [a]
Set.toList forall a b. (a -> b) -> a -> b
$ forall (g :: * -> *) e. HasAlphabet g => g e -> Set e
alphabet FSA n e
f) [e1
1..]
>                     index :: e -> e1
index e
x = let xs :: [(e, e1)]
xs = forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Eq a => a -> a -> Bool
==e
x) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(e, e1)]
syms
>                               in case [(e, e1)]
xs of
>                                    []    -> e1
0
>                                    ((e, e1)
y:[(e, e1)]
_) -> forall a b. (a, b) -> b
snd (e, e1)
y

> emblock' :: (Ord n, Ord e) => SynMon n e
>          -> FSA ([e],[e],[e]) ([e],[e],[e])
> emblock' :: forall n e.
(Ord n, Ord e) =>
SynMon n e -> FSA ([e], [e], [e]) ([e], [e], [e])
emblock' SynMon n e
s = FSA { sigma :: Set ([e], [e], [e])
sigma = forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall n. State n -> n
nodeLabel forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n e. Transition n e -> State n
source) [Transition ([e], [e], [e]) ([e], [e], [e])]
trs
>                  , transitions :: Set (Transition ([e], [e], [e]) ([e], [e], [e]))
transitions = forall a. Ord a => [a] -> Set a
Set.fromList ([Transition ([e], [e], [e]) ([e], [e], [e])]
trs forall a. [a] -> [a] -> [a]
++ [Transition ([e], [e], [e]) ([e], [e], [e])]
itrs)
>                  , initials :: Set (State ([e], [e], [e]))
initials = forall a. a -> Set a
Set.singleton (forall n. n -> State n
State ([],[],[]))
>                  , finals :: Set (State ([e], [e], [e]))
finals = forall a. Set a
Set.empty
>                  , isDeterministic :: Bool
isDeterministic = Bool
True
>                  }
>     where es :: [[e]]
es = forall a b. (a -> b) -> [a] -> [b]
map forall {a} {e}. State (a, [Symbol e]) -> [e]
h forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> [a]
Set.toList forall a b. (a -> b) -> a -> b
$ forall n e. (Ord n, Ord e) => FSA (n, [Symbol e]) e -> Set (T n e)
idempotents SynMon n e
s
>           qs :: [[e]]
qs = forall a b. (a -> b) -> [a] -> [b]
map forall {a} {e}. State (a, [Symbol e]) -> [e]
h forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> [a]
Set.toList forall a b. (a -> b) -> a -> b
$ forall e n. (Ord e, Ord n) => FSA n e -> Set (State n)
states SynMon n e
s
>           ismon :: Bool
ismon = forall n e. FSA n e -> Set (State n)
initials SynMon n e
s forall a. Ord a => Set a -> Set a -> Bool
`Set.isSubsetOf` forall n e. (Ord n, Ord e) => FSA (n, [Symbol e]) e -> Set (T n e)
idempotents SynMon n e
s
>           h :: State (a, [Symbol e]) -> [e]
h = ([] forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (s :: * -> *) c e.
(Collapsible s, Container c e, Monoid c) =>
s (Symbol e) -> c
unsymbols forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. State n -> n
nodeLabel
>           go :: t [e]
-> State ([Maybe n], [Symbol e]) -> State ([Maybe n], [Symbol e])
go t [e]
xs State ([Maybe n], [Symbol e])
q = forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (l :: * -> *) a. Linearizable l => l a -> (a, l a)
choose forall a b. (a -> b) -> a -> b
$ forall n e.
(Ord n, Ord e) =>
FSA n e -> [Symbol e] -> State n -> Set (State n)
follow SynMon n e
s (forall a b. (a -> b) -> [a] -> [b]
map forall e. e -> Symbol e
Symbol forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat t [e]
xs) State ([Maybe n], [Symbol e])
q
>           q0 :: State ([Maybe n], [Symbol e])
q0 = forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (l :: * -> *) a. Linearizable l => l a -> (a, l a)
choose forall a b. (a -> b) -> a -> b
$ forall n e. FSA n e -> Set (State n)
initials SynMon n e
s
>           trs :: [Transition ([e], [e], [e]) ([e], [e], [e])]
trs = [let exf :: State ([Maybe n], [Symbol e])
exf = forall {t :: * -> *}.
Foldable t =>
t [e]
-> State ([Maybe n], [Symbol e]) -> State ([Maybe n], [Symbol e])
go [[e]
e,[e]
x,[e]
f] State ([Maybe n], [Symbol e])
q0
>                      fyg :: State ([Maybe n], [Symbol e])
fyg = forall {t :: * -> *}.
Foldable t =>
t [e]
-> State ([Maybe n], [Symbol e]) -> State ([Maybe n], [Symbol e])
go [[e]
f,[e]
y,[e]
g] State ([Maybe n], [Symbol e])
q0
>                  in Transition { source :: State ([e], [e], [e])
source      = forall n. n -> State n
State ([e]
e, forall {a} {e}. State (a, [Symbol e]) -> [e]
h State ([Maybe n], [Symbol e])
exf, [e]
f)
>                                , destination :: State ([e], [e], [e])
destination = forall n. n -> State n
State
>                                                ([e]
e,forall {a} {e}. State (a, [Symbol e]) -> [e]
h forall a b. (a -> b) -> a -> b
$ forall {t :: * -> *}.
Foldable t =>
t [e]
-> State ([Maybe n], [Symbol e]) -> State ([Maybe n], [Symbol e])
go [forall {a} {e}. State (a, [Symbol e]) -> [e]
h State ([Maybe n], [Symbol e])
fyg] State ([Maybe n], [Symbol e])
exf,[e]
g)
>                                , edgeLabel :: Symbol ([e], [e], [e])
edgeLabel   = forall e. e -> Symbol e
Symbol ([e]
f, forall {a} {e}. State (a, [Symbol e]) -> [e]
h State ([Maybe n], [Symbol e])
fyg, [e]
g)
>                             }
>                 | [e]
e <- [[e]]
es, [e]
f <- [[e]]
es, [e]
g <- [[e]]
es
>                 , [e]
x <- [[e]]
qs, [e]
y <- [[e]]
qs
>                 ]
>           itrs :: [Transition ([e], [e], [e]) ([e], [e], [e])]
itrs = if Bool
ismon
>                  then []
>                  else [Transition { source :: State ([e], [e], [e])
source = forall n. n -> State n
State ([],[],[])
>                                   , destination :: State ([e], [e], [e])
destination = forall n. n -> State n
State ([e], [e], [e])
p
>                                   , edgeLabel :: Symbol ([e], [e], [e])
edgeLabel = forall e. e -> Symbol e
Symbol ([e], [e], [e])
p
>                                   }
>                       | (Symbol ([e], [e], [e])
p) <- forall a b. (a -> b) -> [a] -> [b]
map forall n e. Transition n e -> Symbol e
edgeLabel [Transition ([e], [e], [e]) ([e], [e], [e])]
trs
>                       ]

Syntactic Order
===============
Pin (1997) suggests the following parial order on syntactic semigroups:
s <= t iff for all u,v it holds that utv in L implies usv in L.
This is a weak partial order:
* reflexive: clear from construction
* antisymmetric:
  suppose x <= y and y <= x; then uxv in L iff uyv in L
  and thus x is Myhill-related to y.

The way the syntactic monoid is constructed,
this information does remain accessible, so we can generate this order.
We'll generate it as an FSA with only one sort of edge label,
where an edge exists from p to q iff p <= q.
The initial state is the identity and the finals are the finals.

> -- |Returns a machine whose states represent monoid elements
> -- and where a transition exists from \(p\) to \(q\)
> -- if and only if \(p\leq q\).
> --
> -- @since 1.1
> syntacticOrder :: (Ord n, Ord e) => SynMon n e -> FSA [e] ()
> syntacticOrder :: forall n e. (Ord n, Ord e) => SynMon n e -> FSA [e] ()
syntacticOrder SynMon n e
s = FSA
>                    { sigma :: Set ()
sigma = forall a. a -> Set a
Set.singleton ()
>                    , transitions :: Set (Transition [e] ())
transitions = forall a. Ord a => [a] -> Set a
Set.fromList
>                                    [ Transition { source :: State [e]
source = forall {a}. State (a, [Symbol e]) -> State [e]
f State ([Maybe n], [Symbol e])
x
>                                                 , destination :: State [e]
destination = forall {a}. State (a, [Symbol e]) -> State [e]
f State ([Maybe n], [Symbol e])
y
>                                                 , edgeLabel :: Symbol ()
edgeLabel = forall e. e -> Symbol e
Symbol ()
>                                                 }
>                                    | State ([Maybe n], [Symbol e])
x <- [State ([Maybe n], [Symbol e])]
q, State ([Maybe n], [Symbol e])
y <- [State ([Maybe n], [Symbol e])]
q, State ([Maybe n], [Symbol e])
x forall {a} {a}.
State (a, [Symbol e]) -> State (a, [Symbol e]) -> Bool
# State ([Maybe n], [Symbol e])
y
>                                    ]
>                    , initials :: Set (State [e])
initials = forall (s :: * -> *) b1 b a.
(Collapsible s, Container (s b1) b) =>
(a -> b) -> s a -> s b1
tmap forall {a}. State (a, [Symbol e]) -> State [e]
f (forall n e. FSA n e -> Set (State n)
initials SynMon n e
s)
>                    , finals :: Set (State [e])
finals = forall (s :: * -> *) b1 b a.
(Collapsible s, Container (s b1) b) =>
(a -> b) -> s a -> s b1
tmap forall {a}. State (a, [Symbol e]) -> State [e]
f (forall n e. FSA n e -> Set (State n)
finals SynMon n e
s)
>                    , isDeterministic :: Bool
isDeterministic = Bool
False
>                    }
>     where q :: [State ([Maybe n], [Symbol e])]
q = forall a. Set a -> [a]
Set.toList forall a b. (a -> b) -> a -> b
$ forall e n. (Ord e, Ord n) => FSA n e -> Set (State n)
states SynMon n e
s
>           f :: State (a, [Symbol e]) -> State [e]
f = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (s :: * -> *) c e.
(Collapsible s, Container c e, Monoid c) =>
s (Symbol e) -> c
unsymbols forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd)
>           g :: State (a, c) -> c
g = forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. State n -> n
nodeLabel
>           State (a, [Symbol e])
x # :: State (a, [Symbol e]) -> State (a, [Symbol e]) -> Bool
# State (a, [Symbol e])
y = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall e n. (Ord e, Ord n) => FSA n e -> [e] -> Bool
accepts SynMon n e
s forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (s :: * -> *) c e.
(Collapsible s, Container c e, Monoid c) =>
s (Symbol e) -> c
unsymbols)
>                   [ forall {a} {c}. State (a, c) -> c
g State ([Maybe n], [Symbol e])
u forall a. [a] -> [a] -> [a]
++ forall {a} {c}. State (a, c) -> c
g State (a, [Symbol e])
x forall a. [a] -> [a] -> [a]
++ forall {a} {c}. State (a, c) -> c
g State ([Maybe n], [Symbol e])
v
>                   | State ([Maybe n], [Symbol e])
u <- [State ([Maybe n], [Symbol e])]
q, State ([Maybe n], [Symbol e])
v <- [State ([Maybe n], [Symbol e])]
q,
>                     forall e n. (Ord e, Ord n) => FSA n e -> [e] -> Bool
accepts SynMon n e
s (forall (s :: * -> *) c e.
(Collapsible s, Container c e, Monoid c) =>
s (Symbol e) -> c
unsymbols (forall {a} {c}. State (a, c) -> c
g State ([Maybe n], [Symbol e])
u forall a. [a] -> [a] -> [a]
++ forall {a} {c}. State (a, c) -> c
g State (a, [Symbol e])
y forall a. [a] -> [a] -> [a]
++ forall {a} {c}. State (a, c) -> c
g State ([Maybe n], [Symbol e])
v))
>                   ]


Helpers
=======

> pairs :: Ord a => Set a -> Set (a, a)
> pairs :: forall a. Ord a => Set a -> Set (a, a)
pairs Set a
xs = forall (c :: * -> *) a b.
Collapsible c =>
(a -> b -> b) -> b -> c a -> b
collapse (forall c a. Container c a => c -> c -> c
union forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. a -> Set (a, a)
f) forall c a. Container c a => c
empty Set a
xs
>     where f :: a -> Set (a, a)
f a
x = forall a b. (a -> b) -> Set a -> Set b
Set.mapMonotonic ((,) a
x) Set a
xs