> {-# OPTIONS_HADDOCK hide,show-extensions #-}
> {-|
> Module    : LTK.Porters.EggBox
> Copyright : (c) 2022-2023 Dakotah Lambert
> License   : MIT
>
> This module provides a mechanism to display the egg-box representation
> for a syntactic monoid.  This is an export-only format, as information
> is lost.
>
> @since 1.1
> -}
> module LTK.Porters.EggBox ( exportEggBox ) where

> import Data.List (intercalate, nub)
> import Data.Maybe (mapMaybe)
> import Data.Set (Set)
> import qualified Data.Set as Set

> import LTK.FSA
> import LTK.Algebra (SynMon, idempotents)

> -- |Draw the egg-box representation of the given monoid
> -- in GraphViz @dot@ format.
> exportEggBox :: (Ord n, Ord e, Show e) => SynMon n e -> String
> exportEggBox :: forall n e. (Ord n, Ord e, Show e) => SynMon n e -> [Char]
exportEggBox SynMon n e
m
>     = [[Char]] -> [Char]
unlines
>       ([ [Char]
"digraph {", [Char]
"node [shape=plaintext]", [Char]
"edge [dir=none]" ]
>       [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]]
sts
>       [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ (([Char], [Char]) -> [Char]) -> [([Char], [Char])] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (([Char] -> [Char] -> [Char]) -> ([Char], [Char]) -> [Char]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [Char] -> [Char] -> [Char]
showtr) ([([Char], [Char])] -> [([Char], [Char])]
forall a. Eq a => [(a, a)] -> [(a, a)]
reduce [([Char], [Char])]
g)
>       [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]
"}"]
>       )
>     where js :: [([Char], Set (State ([Maybe n], [Symbol e])))]
js = [[Char]]
-> [Set (State ([Maybe n], [Symbol e]))]
-> [([Char], Set (State ([Maybe n], [Symbol e])))]
forall a b. [a] -> [b] -> [(a, b)]
zip ((Integer -> [Char]) -> [Integer] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Integer -> [Char]
forall a. Show a => a -> [Char]
show [Integer
1::Integer ..]) ([Set (State ([Maybe n], [Symbol e]))]
 -> [([Char], Set (State ([Maybe n], [Symbol e])))])
-> (Set (Set (State ([Maybe n], [Symbol e])))
    -> [Set (State ([Maybe n], [Symbol e]))])
-> Set (Set (State ([Maybe n], [Symbol e])))
-> [([Char], Set (State ([Maybe n], [Symbol e])))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set (Set (State ([Maybe n], [Symbol e])))
-> [Set (State ([Maybe n], [Symbol e]))]
forall a. Set a -> [a]
Set.toList
>                (Set (Set (State ([Maybe n], [Symbol e])))
 -> [([Char], Set (State ([Maybe n], [Symbol e])))])
-> Set (Set (State ([Maybe n], [Symbol e])))
-> [([Char], Set (State ([Maybe n], [Symbol e])))]
forall a b. (a -> b) -> a -> b
$ SynMon n e -> Set (Set (State ([Maybe n], [Symbol e])))
forall e n.
(Ord e, Ord n) =>
FSA ([Maybe n], [Symbol e]) e
-> Set (Set (State ([Maybe n], [Symbol e])))
jEquivalence SynMon n e
m
>           sts :: [[Char]]
sts = (([Char], Set (State ([Maybe n], [Symbol e]))) -> [Char])
-> [([Char], Set (State ([Maybe n], [Symbol e])))] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map
>                 (\([Char]
x,Set (State ([Maybe n], [Symbol e]))
y) -> [Char]
x [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"[label=<"
>                           [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ SynMon n e -> Set (State ([Maybe n], [Symbol e])) -> [Char]
forall n e.
(Ord n, Ord e, Show e) =>
SynMon n e -> Set (State ([Maybe n], [Symbol e])) -> [Char]
constructTable SynMon n e
m Set (State ([Maybe n], [Symbol e]))
y [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
">];")
>                 [([Char], Set (State ([Maybe n], [Symbol e])))]
js
>           ps :: [(([Char], Set (State ([Maybe n], [Symbol e]))),
  ([Char], Set (State ([Maybe n], [Symbol e]))))]
ps = [([Char], Set (State ([Maybe n], [Symbol e])))]
-> [(([Char], Set (State ([Maybe n], [Symbol e]))),
     ([Char], Set (State ([Maybe n], [Symbol e]))))]
forall a. [a] -> [(a, a)]
pairs [([Char], Set (State ([Maybe n], [Symbol e])))]
js
>           g :: [([Char], [Char])]
g = ((([Char], Set (State ([Maybe n], [Symbol e]))),
  ([Char], Set (State ([Maybe n], [Symbol e]))))
 -> Maybe ([Char], [Char]))
-> [(([Char], Set (State ([Maybe n], [Symbol e]))),
     ([Char], Set (State ([Maybe n], [Symbol e]))))]
-> [([Char], [Char])]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((([Char], Set (State ([Maybe n], [Symbol e])))
 -> ([Char], Set (State ([Maybe n], [Symbol e])))
 -> Maybe ([Char], [Char]))
-> (([Char], Set (State ([Maybe n], [Symbol e]))),
    ([Char], Set (State ([Maybe n], [Symbol e]))))
-> Maybe ([Char], [Char])
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ([Char], Set (State ([Maybe n], [Symbol e])))
-> ([Char], Set (State ([Maybe n], [Symbol e])))
-> Maybe ([Char], [Char])
forall {a}.
(a, Set (State ([Maybe n], [Symbol e])))
-> (a, Set (State ([Maybe n], [Symbol e]))) -> Maybe (a, a)
f) [(([Char], Set (State ([Maybe n], [Symbol e]))),
  ([Char], Set (State ([Maybe n], [Symbol e]))))]
ps
>           f :: (a, Set (State ([Maybe n], [Symbol e])))
-> (a, Set (State ([Maybe n], [Symbol e]))) -> Maybe (a, a)
f (a, Set (State ([Maybe n], [Symbol e])))
x (a, Set (State ([Maybe n], [Symbol e])))
y
>               | Set (State ([Maybe n], [Symbol e]))
x2 Set (State ([Maybe n], [Symbol e]))
-> Set (State ([Maybe n], [Symbol e])) -> Bool
forall a. Ord a => Set a -> Set a -> Bool
`Set.isSubsetOf` Set (State ([Maybe n], [Symbol e]))
y2 = (a, a) -> Maybe (a, a)
forall a. a -> Maybe a
Just ((a, Set (State ([Maybe n], [Symbol e]))) -> a
forall a b. (a, b) -> a
fst (a, Set (State ([Maybe n], [Symbol e])))
y, (a, Set (State ([Maybe n], [Symbol e]))) -> a
forall a b. (a, b) -> a
fst (a, Set (State ([Maybe n], [Symbol e])))
x)
>               | Set (State ([Maybe n], [Symbol e]))
y2 Set (State ([Maybe n], [Symbol e]))
-> Set (State ([Maybe n], [Symbol e])) -> Bool
forall a. Ord a => Set a -> Set a -> Bool
`Set.isSubsetOf` Set (State ([Maybe n], [Symbol e]))
x2 = (a, a) -> Maybe (a, a)
forall a. a -> Maybe a
Just ((a, Set (State ([Maybe n], [Symbol e]))) -> a
forall a b. (a, b) -> a
fst (a, Set (State ([Maybe n], [Symbol e])))
x, (a, Set (State ([Maybe n], [Symbol e]))) -> a
forall a b. (a, b) -> a
fst (a, Set (State ([Maybe n], [Symbol e])))
y)
>               | Bool
otherwise = Maybe (a, a)
forall a. Maybe a
Nothing
>               where x2 :: Set (State ([Maybe n], [Symbol e]))
x2 = SynMon n e
-> State ([Maybe n], [Symbol e])
-> Set (State ([Maybe n], [Symbol e]))
forall n e.
(Ord n, Ord e) =>
FSA (n, [Symbol e]) e
-> State (n, [Symbol e]) -> Set (State (n, [Symbol e]))
primitiveIdeal2 SynMon n e
m (Set (State ([Maybe n], [Symbol e]))
-> State ([Maybe n], [Symbol e])
forall a. Set a -> a
Set.findMin (Set (State ([Maybe n], [Symbol e]))
 -> State ([Maybe n], [Symbol e]))
-> Set (State ([Maybe n], [Symbol e]))
-> State ([Maybe n], [Symbol e])
forall a b. (a -> b) -> a -> b
$ (a, Set (State ([Maybe n], [Symbol e])))
-> Set (State ([Maybe n], [Symbol e]))
forall a b. (a, b) -> b
snd (a, Set (State ([Maybe n], [Symbol e])))
x)
>                     y2 :: Set (State ([Maybe n], [Symbol e]))
y2 = SynMon n e
-> State ([Maybe n], [Symbol e])
-> Set (State ([Maybe n], [Symbol e]))
forall n e.
(Ord n, Ord e) =>
FSA (n, [Symbol e]) e
-> State (n, [Symbol e]) -> Set (State (n, [Symbol e]))
primitiveIdeal2 SynMon n e
m (Set (State ([Maybe n], [Symbol e]))
-> State ([Maybe n], [Symbol e])
forall a. Set a -> a
Set.findMin (Set (State ([Maybe n], [Symbol e]))
 -> State ([Maybe n], [Symbol e]))
-> Set (State ([Maybe n], [Symbol e]))
-> State ([Maybe n], [Symbol e])
forall a b. (a -> b) -> a -> b
$ (a, Set (State ([Maybe n], [Symbol e])))
-> Set (State ([Maybe n], [Symbol e]))
forall a b. (a, b) -> b
snd (a, Set (State ([Maybe n], [Symbol e])))
y)
>           showtr :: [Char] -> [Char] -> [Char]
showtr [Char]
x [Char]
y = [Char]
x [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" -> " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
y [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
";"

> pairs :: [a] -> [(a,a)]
> pairs :: forall a. [a] -> [(a, a)]
pairs (a
x:[a]
xs) = (a -> (a, a)) -> [a] -> [(a, a)]
forall a b. (a -> b) -> [a] -> [b]
map ((,) a
x) [a]
xs [(a, a)] -> [(a, a)] -> [(a, a)]
forall a. [a] -> [a] -> [a]
++ [a] -> [(a, a)]
forall a. [a] -> [(a, a)]
pairs [a]
xs
> pairs [a]
_ = []

> constructTable :: (Ord n, Ord e, Show e) =>
>                  SynMon n e -> Set (State ([Maybe n], [Symbol e]))
>                -> String
> constructTable :: forall n e.
(Ord n, Ord e, Show e) =>
SynMon n e -> Set (State ([Maybe n], [Symbol e])) -> [Char]
constructTable SynMon n e
m Set (State ([Maybe n], [Symbol e]))
j
>     = [[Char]] -> [Char]
unlines ([ [Char]
"<TABLE " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
unwords [[Char]]
attrs [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
">"]
>               [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ (Set (State ([Maybe n], [Symbol e])) -> [[Char]])
-> [Set (State ([Maybe n], [Symbol e]))] -> [[Char]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([Char] -> [[Char]]
lines ([Char] -> [[Char]])
-> (Set (State ([Maybe n], [Symbol e])) -> [Char])
-> Set (State ([Maybe n], [Symbol e]))
-> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SynMon n e -> Set (State ([Maybe n], [Symbol e])) -> [Char]
forall n e.
(Ord n, Ord e, Show e) =>
SynMon n e -> Set (State ([Maybe n], [Symbol e])) -> [Char]
constructRow SynMon n e
m) [Set (State ([Maybe n], [Symbol e]))]
rs
>               [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++  [ [Char]
"</TABLE>" ])
>     where rs :: [Set (State ([Maybe n], [Symbol e]))]
rs = Set (Set (State ([Maybe n], [Symbol e])))
-> [Set (State ([Maybe n], [Symbol e]))]
forall a. Set a -> [a]
Set.toList (Set (Set (State ([Maybe n], [Symbol e])))
 -> [Set (State ([Maybe n], [Symbol e]))])
-> Set (Set (State ([Maybe n], [Symbol e])))
-> [Set (State ([Maybe n], [Symbol e]))]
forall a b. (a -> b) -> a -> b
$ (State ([Maybe n], [Symbol e])
 -> Set (State ([Maybe n], [Symbol e])))
-> Set (State ([Maybe n], [Symbol e]))
-> Set (Set (State ([Maybe n], [Symbol e])))
forall a n. (Ord a, Ord n) => (n -> a) -> Set n -> Set (Set n)
partitionBy (SynMon n e
-> State ([Maybe n], [Symbol e])
-> Set (State ([Maybe n], [Symbol e]))
forall n e. (Ord n, Ord e) => FSA n e -> State n -> Set (State n)
primitiveIdealR SynMon n e
m) Set (State ([Maybe n], [Symbol e]))
j
>           attrs :: [[Char]]
attrs = [ [Char]
"BORDER=\"0\""
>                   , [Char]
"CELLBORDER=\"1\""
>                   , [Char]
"CELLSPACING=\"0\""
>                   ]

A row is an R-class.  But a column is an L-class,
so we have to make certain that the cells are generated
in a consistent order.

> constructRow :: (Ord n, Ord e, Show e) =>
>                SynMon n e -> Set (State ([Maybe n], [Symbol e]))
>              -> String
> constructRow :: forall n e.
(Ord n, Ord e, Show e) =>
SynMon n e -> Set (State ([Maybe n], [Symbol e])) -> [Char]
constructRow SynMon n e
m Set (State ([Maybe n], [Symbol e]))
r
>     = [[Char]] -> [Char]
unlines ([[Char]
"<TR>"]
>                [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ (Set (State ([Maybe n], [Symbol e])) -> [Char])
-> [Set (State ([Maybe n], [Symbol e]))] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (SynMon n e -> Set (State ([Maybe n], [Symbol e])) -> [Char]
forall n e.
(Ord n, Ord e, Show e) =>
SynMon n e -> Set (State ([Maybe n], [Symbol e])) -> [Char]
constructCell SynMon n e
m) [Set (State ([Maybe n], [Symbol e]))]
ls
>                [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]
"</TR>"])
>     where ls :: [Set (State ([Maybe n], [Symbol e]))]
ls = (Set
   (Set (State ([Maybe n], [Symbol e])),
    State ([Maybe n], [Symbol e]))
 -> Set (State ([Maybe n], [Symbol e])))
-> [Set
      (Set (State ([Maybe n], [Symbol e])),
       State ([Maybe n], [Symbol e]))]
-> [Set (State ([Maybe n], [Symbol e]))]
forall a b. (a -> b) -> [a] -> [b]
map (((Set (State ([Maybe n], [Symbol e])),
  State ([Maybe n], [Symbol e]))
 -> State ([Maybe n], [Symbol e]))
-> Set
     (Set (State ([Maybe n], [Symbol e])),
      State ([Maybe n], [Symbol e]))
-> Set (State ([Maybe n], [Symbol e]))
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (Set (State ([Maybe n], [Symbol e])),
 State ([Maybe n], [Symbol e]))
-> State ([Maybe n], [Symbol e])
forall a b. (a, b) -> b
snd) ([Set
    (Set (State ([Maybe n], [Symbol e])),
     State ([Maybe n], [Symbol e]))]
 -> [Set (State ([Maybe n], [Symbol e]))])
-> (Set
      (Set
         (Set (State ([Maybe n], [Symbol e])),
          State ([Maybe n], [Symbol e])))
    -> [Set
          (Set (State ([Maybe n], [Symbol e])),
           State ([Maybe n], [Symbol e]))])
-> Set
     (Set
        (Set (State ([Maybe n], [Symbol e])),
         State ([Maybe n], [Symbol e])))
-> [Set (State ([Maybe n], [Symbol e]))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set
  (Set
     (Set (State ([Maybe n], [Symbol e])),
      State ([Maybe n], [Symbol e])))
-> [Set
      (Set (State ([Maybe n], [Symbol e])),
       State ([Maybe n], [Symbol e]))]
forall a. Set a -> [a]
Set.toAscList (Set
   (Set
      (Set (State ([Maybe n], [Symbol e])),
       State ([Maybe n], [Symbol e])))
 -> [Set (State ([Maybe n], [Symbol e]))])
-> Set
     (Set
        (Set (State ([Maybe n], [Symbol e])),
         State ([Maybe n], [Symbol e])))
-> [Set (State ([Maybe n], [Symbol e]))]
forall a b. (a -> b) -> a -> b
$ ((Set (State ([Maybe n], [Symbol e])),
  State ([Maybe n], [Symbol e]))
 -> Set (State ([Maybe n], [Symbol e])))
-> Set
     (Set (State ([Maybe n], [Symbol e])),
      State ([Maybe n], [Symbol e]))
-> Set
     (Set
        (Set (State ([Maybe n], [Symbol e])),
         State ([Maybe n], [Symbol e])))
forall a n. (Ord a, Ord n) => (n -> a) -> Set n -> Set (Set n)
partitionBy (Set (State ([Maybe n], [Symbol e])),
 State ([Maybe n], [Symbol e]))
-> Set (State ([Maybe n], [Symbol e]))
forall a b. (a, b) -> a
fst Set
  (Set (State ([Maybe n], [Symbol e])),
   State ([Maybe n], [Symbol e]))
ls'
>           ls' :: Set
  (Set (State ([Maybe n], [Symbol e])),
   State ([Maybe n], [Symbol e]))
ls' = (State ([Maybe n], [Symbol e])
 -> (Set (State ([Maybe n], [Symbol e])),
     State ([Maybe n], [Symbol e])))
-> Set (State ([Maybe n], [Symbol e]))
-> Set
     (Set (State ([Maybe n], [Symbol e])),
      State ([Maybe n], [Symbol e]))
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (\State ([Maybe n], [Symbol e])
x -> (SynMon n e
-> State ([Maybe n], [Symbol e])
-> Set (State ([Maybe n], [Symbol e]))
forall n e.
(Ord n, Ord e) =>
FSA (n, [Symbol e]) e
-> State (n, [Symbol e]) -> Set (State (n, [Symbol e]))
primitiveIdealL SynMon n e
m State ([Maybe n], [Symbol e])
x, State ([Maybe n], [Symbol e])
x)) Set (State ([Maybe n], [Symbol e]))
r

A cell is an H-class.  Idempotent elements are marked by a star.
The most intensive part of `constructCell` is one of design principle:
I want to visually see if identity is reachable in a star-free system.
If there is a nonsalient symbol, that symbol is used for identity.
Otherwise, we use □ symbol.

> constructCell :: (Ord n, Ord e, Show e) =>
>                SynMon n e -> Set (State ([Maybe n], [Symbol e]))
>              -> String
> constructCell :: forall n e.
(Ord n, Ord e, Show e) =>
SynMon n e -> Set (State ([Maybe n], [Symbol e])) -> [Char]
constructCell SynMon n e
m Set (State ([Maybe n], [Symbol e]))
h = [Char]
"<TD>" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"<BR/>" [[Char]]
h' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"</TD>"
>     where h' :: [[Char]]
h' = (State ([Maybe n], [Symbol e]) -> [Char])
-> [State ([Maybe n], [Symbol e])] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ([Symbol e] -> [Char]
display ([Symbol e] -> [Char])
-> (State ([Maybe n], [Symbol e]) -> [Symbol e])
-> State ([Maybe n], [Symbol e])
-> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Maybe n], [Symbol e]) -> [Symbol e]
forall a b. (a, b) -> b
snd (([Maybe n], [Symbol e]) -> [Symbol e])
-> (State ([Maybe n], [Symbol e]) -> ([Maybe n], [Symbol e]))
-> State ([Maybe n], [Symbol e])
-> [Symbol e]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State ([Maybe n], [Symbol e]) -> ([Maybe n], [Symbol e])
forall n. State n -> n
nodeLabel) ([State ([Maybe n], [Symbol e])] -> [[Char]])
-> [State ([Maybe n], [Symbol e])] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ Set (State ([Maybe n], [Symbol e]))
-> [State ([Maybe n], [Symbol e])]
forall a. Set a -> [a]
Set.toList Set (State ([Maybe n], [Symbol e]))
h
>           display :: [Symbol e] -> [Char]
display [Symbol e]
x
>               | Bool -> Bool
not ([Symbol e] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Symbol e]
x) = [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"\x2009"
>                                ((Symbol e -> Maybe [Char]) -> [Symbol e] -> [[Char]]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Symbol [Char] -> Maybe [Char]
forall {a}. Symbol a -> Maybe a
toMaybe (Symbol [Char] -> Maybe [Char])
-> (Symbol e -> Symbol [Char]) -> Symbol e -> Maybe [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (e -> [Char]) -> Symbol e -> Symbol [Char]
forall a b. (a -> b) -> Symbol a -> Symbol b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap e -> [Char]
forall a. Show a => a -> [Char]
showish) [Symbol e]
x)
>                                [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ if [Symbol e]
x [Symbol e] -> Set [Symbol e] -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set [Symbol e]
i then [Char]
"*" else [Char]
""
>               | Bool
otherwise = (case [Symbol e]
t of
>                                ((Symbol e
n):[Symbol e]
_) -> e -> [Char]
forall a. Show a => a -> [Char]
showish e
n
>                                [Symbol e]
_ -> [Char]
"□") [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"*"
>               where t :: [Symbol e]
t = (Transition ([Maybe n], [Symbol e]) e -> Symbol e)
-> [Transition ([Maybe n], [Symbol e]) e] -> [Symbol e]
forall a b. (a -> b) -> [a] -> [b]
map Transition ([Maybe n], [Symbol e]) e -> Symbol e
forall n e. Transition n e -> Symbol e
edgeLabel
>                         ([Transition ([Maybe n], [Symbol e]) e] -> [Symbol e])
-> (Set (Transition ([Maybe n], [Symbol e]) e)
    -> [Transition ([Maybe n], [Symbol e]) e])
-> Set (Transition ([Maybe n], [Symbol e]) e)
-> [Symbol e]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Transition ([Maybe n], [Symbol e]) e -> Bool)
-> [Transition ([Maybe n], [Symbol e]) e]
-> [Transition ([Maybe n], [Symbol e]) e]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Symbol e -> Symbol e -> Bool
forall a. Eq a => a -> a -> Bool
/= Symbol e
forall e. Symbol e
Epsilon) (Symbol e -> Bool)
-> (Transition ([Maybe n], [Symbol e]) e -> Symbol e)
-> Transition ([Maybe n], [Symbol e]) e
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Transition ([Maybe n], [Symbol e]) e -> Symbol e
forall n e. Transition n e -> Symbol e
edgeLabel)
>                         ([Transition ([Maybe n], [Symbol e]) e]
 -> [Transition ([Maybe n], [Symbol e]) e])
-> (Set (Transition ([Maybe n], [Symbol e]) e)
    -> [Transition ([Maybe n], [Symbol e]) e])
-> Set (Transition ([Maybe n], [Symbol e]) e)
-> [Transition ([Maybe n], [Symbol e]) e]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Transition ([Maybe n], [Symbol e]) e -> Bool)
-> [Transition ([Maybe n], [Symbol e]) e]
-> [Transition ([Maybe n], [Symbol e]) e]
forall a. (a -> Bool) -> [a] -> [a]
filter ((State ([Maybe n], [Symbol e])
-> Set (State ([Maybe n], [Symbol e])) -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` SynMon n e -> Set (State ([Maybe n], [Symbol e]))
forall n e. FSA n e -> Set (State n)
initials SynMon n e
m)
>                                   (State ([Maybe n], [Symbol e]) -> Bool)
-> (Transition ([Maybe n], [Symbol e]) e
    -> State ([Maybe n], [Symbol e]))
-> Transition ([Maybe n], [Symbol e]) e
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Transition ([Maybe n], [Symbol e]) e
-> State ([Maybe n], [Symbol e])
forall n e. Transition n e -> State n
destination)
>                         ([Transition ([Maybe n], [Symbol e]) e]
 -> [Transition ([Maybe n], [Symbol e]) e])
-> (Set (Transition ([Maybe n], [Symbol e]) e)
    -> [Transition ([Maybe n], [Symbol e]) e])
-> Set (Transition ([Maybe n], [Symbol e]) e)
-> [Transition ([Maybe n], [Symbol e]) e]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Transition ([Maybe n], [Symbol e]) e -> Bool)
-> [Transition ([Maybe n], [Symbol e]) e]
-> [Transition ([Maybe n], [Symbol e]) e]
forall a. (a -> Bool) -> [a] -> [a]
filter ((State ([Maybe n], [Symbol e])
-> Set (State ([Maybe n], [Symbol e])) -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` SynMon n e -> Set (State ([Maybe n], [Symbol e]))
forall n e. FSA n e -> Set (State n)
initials SynMon n e
m) (State ([Maybe n], [Symbol e]) -> Bool)
-> (Transition ([Maybe n], [Symbol e]) e
    -> State ([Maybe n], [Symbol e]))
-> Transition ([Maybe n], [Symbol e]) e
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Transition ([Maybe n], [Symbol e]) e
-> State ([Maybe n], [Symbol e])
forall n e. Transition n e -> State n
source)
>                         ([Transition ([Maybe n], [Symbol e]) e]
 -> [Transition ([Maybe n], [Symbol e]) e])
-> (Set (Transition ([Maybe n], [Symbol e]) e)
    -> [Transition ([Maybe n], [Symbol e]) e])
-> Set (Transition ([Maybe n], [Symbol e]) e)
-> [Transition ([Maybe n], [Symbol e]) e]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set (Transition ([Maybe n], [Symbol e]) e)
-> [Transition ([Maybe n], [Symbol e]) e]
forall a. Set a -> [a]
Set.toList (Set (Transition ([Maybe n], [Symbol e]) e) -> [Symbol e])
-> Set (Transition ([Maybe n], [Symbol e]) e) -> [Symbol e]
forall a b. (a -> b) -> a -> b
$ SynMon n e -> Set (Transition ([Maybe n], [Symbol e]) e)
forall n e. FSA n e -> Set (Transition n e)
transitions SynMon n e
m
>                     toMaybe :: Symbol a -> Maybe a
toMaybe (Symbol a
a) = a -> Maybe a
forall a. a -> Maybe a
Just a
a
>                     toMaybe Symbol a
_ = Maybe a
forall a. Maybe a
Nothing
>           showish :: a -> [Char]
showish a
x = [Char] -> [Char]
deescape ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'"') ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ a -> [Char]
forall a. Show a => a -> [Char]
show a
x
>           i :: Set [Symbol e]
i = (State ([Maybe n], [Symbol e]) -> [Symbol e])
-> Set (State ([Maybe n], [Symbol e])) -> Set [Symbol e]
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (([Maybe n], [Symbol e]) -> [Symbol e]
forall a b. (a, b) -> b
snd (([Maybe n], [Symbol e]) -> [Symbol e])
-> (State ([Maybe n], [Symbol e]) -> ([Maybe n], [Symbol e]))
-> State ([Maybe n], [Symbol e])
-> [Symbol e]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State ([Maybe n], [Symbol e]) -> ([Maybe n], [Symbol e])
forall n. State n -> n
nodeLabel)
>               (SynMon n e -> Set (State ([Maybe n], [Symbol e]))
forall n e. FSA n e -> Set (State n)
initials SynMon n e
m Set (State ([Maybe n], [Symbol e]))
-> Set (State ([Maybe n], [Symbol e]))
-> Set (State ([Maybe n], [Symbol e]))
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` SynMon n e -> Set (State ([Maybe n], [Symbol e]))
forall n e.
(Ord n, Ord e) =>
FSA (n, [Symbol e]) e -> Set (State (n, [Symbol e]))
idempotents SynMon n e
m)

If you show a string, quotes and some other symbols get escaped.
Undo that.  A better approach would be to not use Show to begin with,
but that makes the system less generic, so we accept the burden.

> deescape :: String -> String
> deescape :: [Char] -> [Char]
deescape (Char
'\\' : Char
'&' : [Char]
xs) = [Char] -> [Char]
deescape [Char]
xs
> deescape (Char
'\\' : Char
x : [Char]
xs)
>     | [Char] -> Bool
forall c a. Container c a => c -> Bool
isEmpty [Char]
digits = Char
x Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char] -> [Char]
deescape [Char]
xs
>     | Bool
otherwise      = Int -> Char
forall a. Enum a => Int -> a
toEnum ([Char] -> Int
forall a. Read a => [Char] -> a
read [Char]
digits) Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char] -> [Char]
deescape [Char]
others
>     where ([Char]
digits, [Char]
others) = (Char -> Bool) -> [Char] -> ([Char], [Char])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span ([Char] -> Char -> Bool
forall c a. (Container c a, Eq a) => c -> a -> Bool
isIn [Char]
"0123456789") (Char
xChar -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:[Char]
xs)
> deescape (Char
x:[Char]
xs) = Char
x Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char] -> [Char]
deescape [Char]
xs
> deescape [Char]
_      = []

Compute the transitive reduction of an acyclic graph
which is specified by source/destination pairs.
The precondition, that the graph be acyclic, is not checked.

> reduce :: (Eq a) => [(a,a)] -> [(a,a)]
> reduce :: forall a. Eq a => [(a, a)] -> [(a, a)]
reduce [(a, a)]
ps = [(a
x,a
y) | a
x <- [a]
nodes, a
y <- [a]
nodes, a
y a -> [a] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` a -> [a]
expand a
x,
>              (a -> Bool) -> [a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (((a, a) -> [(a, a)] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [(a, a)]
ps) ((a, a) -> Bool) -> (a -> (a, a)) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> a -> (a, a)) -> a -> a -> (a, a)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (,) a
y) ([a] -> Bool) -> [a] -> Bool
forall a b. (a -> b) -> a -> b
$ a -> [a]
expand a
x]
>     where nodes :: [a]
nodes = [a] -> [a]
forall a. Eq a => [a] -> [a]
nub ([a] -> [a]) -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ ((a, a) -> a) -> [(a, a)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (a, a) -> a
forall a b. (a, b) -> a
fst [(a, a)]
ps [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ ((a, a) -> a) -> [(a, a)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (a, a) -> a
forall a b. (a, b) -> b
snd [(a, a)]
ps
>           expand :: a -> [a]
expand a
p = let n :: [a]
n = ((a, a) -> a) -> [(a, a)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (a, a) -> a
forall a b. (a, b) -> b
snd ([(a, a)] -> [a]) -> [(a, a)] -> [a]
forall a b. (a -> b) -> a -> b
$ ((a, a) -> Bool) -> [(a, a)] -> [(a, a)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((a
p a -> a -> Bool
forall a. Eq a => a -> a -> Bool
==) (a -> Bool) -> ((a, a) -> a) -> (a, a) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, a) -> a
forall a b. (a, b) -> a
fst) [(a, a)]
ps
>                      in [a]
n [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ (a -> [a]) -> [a] -> [a]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap a -> [a]
expand [a]
n