> {-# 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]" ]
>       forall a. [a] -> [a] -> [a]
++ [[Char]]
sts
>       forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [Char] -> [Char] -> [Char]
showtr) (forall a. Eq a => [(a, a)] -> [(a, a)]
reduce [([Char], [Char])]
g)
>       forall a. [a] -> [a] -> [a]
++ [[Char]
"}"]
>       )
>     where js :: [([Char], Set (State ([Maybe n], [Symbol e])))]
js = forall a b. [a] -> [b] -> [(a, b)]
zip (forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> [Char]
show [Integer
1::Integer ..]) 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 ([Maybe n], [Symbol e]) e
-> Set (Set (State ([Maybe n], [Symbol e])))
jEquivalence SynMon n e
m
>           sts :: [[Char]]
sts = forall a b. (a -> b) -> [a] -> [b]
map
>                 (\([Char]
x,Set (State ([Maybe n], [Symbol e]))
y) -> [Char]
x forall a. [a] -> [a] -> [a]
++ [Char]
"[label=<"
>                           forall a. [a] -> [a] -> [a]
++ 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 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 = forall a. [a] -> [(a, a)]
pairs [([Char], Set (State ([Maybe n], [Symbol e])))]
js
>           g :: [([Char], [Char])]
g = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry 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 forall a. Ord a => Set a -> Set a -> Bool
`Set.isSubsetOf` Set (State ([Maybe n], [Symbol e]))
y2 = forall a. a -> Maybe a
Just (forall a b. (a, b) -> a
fst (a, Set (State ([Maybe n], [Symbol e])))
y, forall a b. (a, b) -> a
fst (a, Set (State ([Maybe n], [Symbol e])))
x)
>               | Set (State ([Maybe n], [Symbol e]))
y2 forall a. Ord a => Set a -> Set a -> Bool
`Set.isSubsetOf` Set (State ([Maybe n], [Symbol e]))
x2 = forall a. a -> Maybe a
Just (forall a b. (a, b) -> a
fst (a, Set (State ([Maybe n], [Symbol e])))
x, forall a b. (a, b) -> a
fst (a, Set (State ([Maybe n], [Symbol e])))
y)
>               | Bool
otherwise = forall a. Maybe a
Nothing
>               where x2 :: Set (State ([Maybe n], [Symbol e]))
x2 = 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 (forall a. Set a -> a
Set.findMin forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> b
snd (a, Set (State ([Maybe n], [Symbol e])))
x)
>                     y2 :: Set (State ([Maybe n], [Symbol e]))
y2 = 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 (forall a. Set a -> a
Set.findMin forall a b. (a -> b) -> a -> b
$ 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 forall a. [a] -> [a] -> [a]
++ [Char]
" -> " forall a. [a] -> [a] -> [a]
++ [Char]
y forall a. [a] -> [a] -> [a]
++ [Char]
";"

> pairs :: [a] -> [(a,a)]
> pairs :: forall a. [a] -> [(a, a)]
pairs (a
x:[a]
xs) = forall a b. (a -> b) -> [a] -> [b]
map ((,) a
x) [a]
xs forall 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 " forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
unwords [[Char]]
attrs forall a. [a] -> [a] -> [a]
++ [Char]
">"]
>               forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([Char] -> [[Char]]
lines forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
>               forall a. [a] -> [a] -> [a]
++  [ [Char]
"</TABLE>" ])
>     where rs :: [Set (State ([Maybe n], [Symbol e]))]
rs = forall a. Set a -> [a]
Set.toList forall a b. (a -> b) -> a -> b
$ forall a n. (Ord a, Ord n) => (n -> a) -> Set n -> Set (Set n)
partitionBy (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>"]
>                forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map (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
>                forall a. [a] -> [a] -> [a]
++ [[Char]
"</TR>"])
>     where ls :: [Set (State ([Maybe n], [Symbol e]))]
ls = forall a b. (a -> b) -> [a] -> [b]
map (forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map forall a b. (a, b) -> b
snd) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> [a]
Set.toAscList forall a b. (a -> b) -> a -> b
$ forall a n. (Ord a, Ord n) => (n -> a) -> Set n -> Set (Set n)
partitionBy 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' = forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (\State ([Maybe n], [Symbol e])
x -> (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>" forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"<BR/>" [[Char]]
h' forall a. [a] -> [a] -> [a]
++ [Char]
"</TD>"
>     where h' :: [[Char]]
h' = forall a b. (a -> b) -> [a] -> [b]
map ([Symbol e] -> [Char]
display 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) forall a b. (a -> b) -> a -> b
$ 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 (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Symbol e]
x) = forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"\x2009"
>                                (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall {a}. Symbol a -> Maybe a
toMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Show a => a -> [Char]
showish) [Symbol e]
x)
>                                forall a. [a] -> [a] -> [a]
++ if [Symbol e]
x 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]
_) -> forall a. Show a => a -> [Char]
showish e
n
>                                [Symbol e]
_ -> [Char]
"□") forall a. [a] -> [a] -> [a]
++ [Char]
"*"
>               where t :: [Symbol e]
t = forall a b. (a -> b) -> [a] -> [b]
map forall n e. Transition n e -> Symbol e
edgeLabel
>                         forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Eq a => a -> a -> Bool
/= forall e. Symbol e
Epsilon) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n e. Transition n e -> Symbol e
edgeLabel)
>                         forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Ord a => a -> Set a -> Bool
`Set.member` forall n e. FSA n e -> Set (State n)
initials SynMon n e
m)
>                                   forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n e. Transition n e -> State n
destination)
>                         forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Ord a => a -> Set a -> Bool
`Set.member` forall n e. FSA n e -> Set (State n)
initials SynMon n e
m) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n e. Transition n e -> State n
source)
>                         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. FSA n e -> Set (Transition n e)
transitions SynMon n e
m
>                     toMaybe :: Symbol a -> Maybe a
toMaybe (Symbol a
a) = forall a. a -> Maybe a
Just a
a
>                     toMaybe Symbol a
_ = forall a. Maybe a
Nothing
>           showish :: a -> [Char]
showish a
x = [Char] -> [Char]
deescape forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/= Char
'"') forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show a
x
>           i :: Set [Symbol e]
i = forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. State n -> n
nodeLabel)
>               (forall n e. FSA n e -> Set (State n)
initials SynMon n e
m forall a. Ord a => Set a -> Set a -> Set a
`Set.union` forall n e. (Ord n, Ord e) => FSA (n, [Symbol e]) e -> Set (T n 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)
>     | forall c a. Container c a => c -> Bool
isEmpty [Char]
digits = Char
x forall a. a -> [a] -> [a]
: [Char] -> [Char]
deescape [Char]
xs
>     | Bool
otherwise      = forall a. Enum a => Int -> a
toEnum (forall a. Read a => [Char] -> a
read [Char]
digits) forall a. a -> [a] -> [a]
: [Char] -> [Char]
deescape [Char]
others
>     where ([Char]
digits, [Char]
others) = forall a. (a -> Bool) -> [a] -> ([a], [a])
span (forall c a. (Container c a, Eq a) => c -> a -> Bool
isIn [Char]
"0123456789") (Char
xforall a. a -> [a] -> [a]
:[Char]
xs)
> deescape (Char
x:[Char]
xs) = Char
x 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 forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` a -> [a]
expand a
x,
>              forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [(a, a)]
ps) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip (,) a
y) forall a b. (a -> b) -> a -> b
$ a -> [a]
expand a
x]
>     where nodes :: [a]
nodes = forall a. Eq a => [a] -> [a]
nub forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(a, a)]
ps forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(a, a)]
ps
>           expand :: a -> [a]
expand a
p = let n :: [a]
n = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter ((a
p forall a. Eq a => a -> a -> Bool
==) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(a, a)]
ps
>                      in [a]
n forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap a -> [a]
expand [a]
n