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

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

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

> -- |Draw the Hasse diagram of the syntactic order of the given monoid
> -- in GraphViz @dot@ format.
> exportSyntacticOrder :: (Ord n, Ord e, Show e) => SynMon n e -> String
> exportSyntacticOrder :: forall n e. (Ord n, Ord e, Show e) => SynMon n e -> [Char]
exportSyntacticOrder SynMon n e
m
>     = [[Char]] -> [Char]
unlines
>       ([ [Char]
"digraph {", [Char]
"graph [rankdir=BT]"
>        , [Char]
"node [shape=box]", [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])]
rel)
>       [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]
"}"]
>       )
>     where g :: FSA [e] ()
g = SynMon n e -> FSA [e] ()
forall n e. (Ord n, Ord e) => SynMon n e -> FSA [e] ()
syntacticOrder SynMon n e
m
>           qs :: [([Char], State [e])]
qs = [[Char]] -> [State [e]] -> [([Char], State [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 ..]) ([State [e]] -> [([Char], State [e])])
-> (Set (State [e]) -> [State [e]])
-> Set (State [e])
-> [([Char], State [e])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set (State [e]) -> [State [e]]
forall a. Set a -> [a]
Set.toList (Set (State [e]) -> [([Char], State [e])])
-> Set (State [e]) -> [([Char], State [e])]
forall a b. (a -> b) -> a -> b
$ FSA [e] () -> Set (State [e])
forall e n. (Ord e, Ord n) => FSA n e -> Set (State n)
states FSA [e] ()
g
>           rel :: [([Char], [Char])]
rel = [ (([Char], State [e]) -> [Char]
forall a b. (a, b) -> a
fst ([Char], State [e])
x, ([Char], State [e]) -> [Char]
forall a b. (a, b) -> a
fst ([Char], State [e])
y)
>                 | ([Char], State [e])
x <- [([Char], State [e])]
qs, ([Char], State [e])
y <- [([Char], State [e])]
qs
>                 , ([Char], State [e])
x ([Char], State [e]) -> ([Char], State [e]) -> Bool
forall a. Eq a => a -> a -> Bool
/= ([Char], State [e])
y
>                 , Transition { source :: State [e]
source = ([Char], State [e]) -> State [e]
forall a b. (a, b) -> b
snd ([Char], State [e])
x
>                              , destination :: State [e]
destination = ([Char], State [e]) -> State [e]
forall a b. (a, b) -> b
snd ([Char], State [e])
y
>                              , edgeLabel :: Symbol ()
edgeLabel = () -> Symbol ()
forall e. e -> Symbol e
Symbol () }
>                   Transition [e] () -> Set (Transition [e] ()) -> Bool
forall a. Eq a => a -> Set a -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` FSA [e] () -> Set (Transition [e] ())
forall n e. FSA n e -> Set (Transition n e)
transitions FSA [e] ()
g
>                 ]
>           sts :: [[Char]]
sts = (([Char], State [e]) -> [Char])
-> [([Char], State [e])] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map
>                 (\([Char]
x,State [e]
y) ->
>                  [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [Char]
x
>                         , [Char]
" [label=\""
>                         , [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"\x2009"
>                           ((e -> [Char]) -> [e] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map e -> [Char]
showish ([e] -> [[Char]]) -> [e] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ State [e] -> [e]
forall n. State n -> n
nodeLabel State [e]
y)
>                         , [Char]
"\"];"]
>                 ) [([Char], State [e])]
qs
>           showish :: e -> [Char]
showish = [Char] -> [Char]
deescape ([Char] -> [Char]) -> (e -> [Char]) -> e -> [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]) -> (e -> [Char]) -> e -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> [Char]
forall a. Show a => a -> [Char]
show
>           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]
";"

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 -> [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