{-# LANGUAGE ScopedTypeVariables#-}
module MultisetOrdering where

import Data.Hashable
import Language.REST.Dot
import qualified Data.Maybe as Mb
import qualified Data.List as L
import qualified Language.REST.Internal.MultiSet as M
import qualified Data.HashMap.Strict as Mp
import qualified Data.HashSet as S
import Language.REST.Types

data Replace a =
    ReplaceOne a a
  | Replace a [a]
  deriving (Int -> Replace a -> ShowS
forall a. Show a => Int -> Replace a -> ShowS
forall a. Show a => [Replace a] -> ShowS
forall a. Show a => Replace a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Replace a] -> ShowS
$cshowList :: forall a. Show a => [Replace a] -> ShowS
show :: Replace a -> String
$cshow :: forall a. Show a => Replace a -> String
showsPrec :: Int -> Replace a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Replace a -> ShowS
Show)

newtype MultisetGE a = MultisetGE [Replace a] deriving (Int -> MultisetGE a -> ShowS
forall a. Show a => Int -> MultisetGE a -> ShowS
forall a. Show a => [MultisetGE a] -> ShowS
forall a. Show a => MultisetGE a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MultisetGE a] -> ShowS
$cshowList :: forall a. Show a => [MultisetGE a] -> ShowS
show :: MultisetGE a -> String
$cshow :: forall a. Show a => MultisetGE a -> String
showsPrec :: Int -> MultisetGE a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> MultisetGE a -> ShowS
Show)

type GTE a = a -> a -> Bool

type Indexed a = (a, Int)

type IndexedMultisetPair a = (Indexed (M.MultiSet (Indexed a)) , Indexed (M.MultiSet (Indexed a)))

multisetGE :: forall a . Eq a => GTE a -> M.MultiSet a -> M.MultiSet a -> Maybe (MultisetGE a)
multisetGE :: forall a.
Eq a =>
GTE a -> MultiSet a -> MultiSet a -> Maybe (MultisetGE a)
multisetGE GTE a
gte MultiSet a
ts0 MultiSet a
us0 = [Replace a] -> [a] -> [a] -> Maybe (MultisetGE a)
go [] (forall a. MultiSet a -> [a]
M.toList MultiSet a
ts0) (forall a. MultiSet a -> [a]
M.toList MultiSet a
us0)
  where
    equiv :: GTE a
equiv a
t a
u = a
t GTE a
`gte` a
u Bool -> Bool -> Bool
&& a
u GTE a
`gte` a
t
    gt :: GTE a
gt a
t a
u = a
t GTE a
`gte` a
u Bool -> Bool -> Bool
&& Bool -> Bool
not (a
u GTE a
`gte` a
t)

    go :: [Replace a] -> [a] -> [a] -> Maybe (MultisetGE a)
    go :: [Replace a] -> [a] -> [a] -> Maybe (MultisetGE a)
go [Replace a]
rs (a
t : [a]
ts) [a]
us | Just a
u <- forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find (GTE a
equiv a
t) [a]
us
      = [Replace a] -> [a] -> [a] -> Maybe (MultisetGE a)
go (forall a. a -> a -> Replace a
ReplaceOne a
t a
uforall a. a -> [a] -> [a]
:[Replace a]
rs) [a]
ts (forall a. Eq a => a -> [a] -> [a]
L.delete a
u [a]
us)

    go [Replace a]
rs (a
t : [a]
ts) [a]
us  =
        let
          ([a]
lts, [a]
us') = forall a. (a -> Bool) -> [a] -> ([a], [a])
L.partition (a
t GTE a
`gt`)  [a]
us
        in
          [Replace a] -> [a] -> [a] -> Maybe (MultisetGE a)
go (forall a. a -> [a] -> Replace a
Replace a
t [a]
lts forall a. a -> [a] -> [a]
: [Replace a]
rs) [a]
ts [a]
us'
    go [Replace a]
rs [a]
ts [] = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. [Replace a] -> MultisetGE a
MultisetGE forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a. a -> [a] -> Replace a
`Replace` []) [a]
ts forall a. [a] -> [a] -> [a]
++ [Replace a]
rs
    go [Replace a]
_  [] [a]
_  = forall a. Maybe a
Nothing


multisetOrd :: (Eq a, Hashable a, Ord a)  => [a] -> [a] -> Maybe (MultisetGE a)
multisetOrd :: forall a.
(Eq a, Hashable a, Ord a) =>
[a] -> [a] -> Maybe (MultisetGE a)
multisetOrd [a]
ts [a]
us = forall a.
Eq a =>
GTE a -> MultiSet a -> MultiSet a -> Maybe (MultisetGE a)
multisetGE forall a. Ord a => a -> a -> Bool
(>=) (forall a. (Eq a, Hashable a) => [a] -> MultiSet a
M.fromList [a]
ts) (forall a. (Eq a, Hashable a) => [a] -> MultiSet a
M.fromList [a]
us)

zindex :: [a] -> [(a, Int)]
zindex :: forall a. [a] -> [(a, Int)]
zindex [a]
xs = forall a b. [a] -> [b] -> [(a, b)]
zip [a]
xs [Int
0 ..]

indexMS :: (Eq a, Hashable a) => M.MultiSet a -> M.MultiSet (a, Int)
indexMS :: forall a. (Eq a, Hashable a) => MultiSet a -> MultiSet (a, Int)
indexMS MultiSet a
ms = forall a. (Eq a, Hashable a) => [a] -> MultiSet a
M.fromList forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [(a, Int)]
zindex (forall a. MultiSet a -> [a]
M.toList MultiSet a
ms)

mkEdge :: NodeID -> NodeID -> Edge
mkEdge :: String -> String -> Edge
mkEdge String
t String
u = String -> String -> String -> String -> String -> String -> Edge
Edge String
t String
u String
" " String
"black" String
" " String
"solid"

botNodeName :: Int -> Int -> String
botNodeName :: Int -> Int -> String
botNodeName Int
tIndex Int
mIndex = String
"bot_" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
tIndex forall a. [a] -> [a] -> [a]
++ String
"_" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
mIndex

botNode :: Int -> Int -> Node
botNode :: Int -> Int -> Node
botNode Int
tIndex Int
mIndex =
  String -> String -> String -> String -> Node
Node (Int -> Int -> String
botNodeName Int
tIndex Int
mIndex) String
"⊥" String
"solid" String
"black"

toGraph' :: forall a. (Eq a, Hashable a, Show a) => GTE a -> [M.MultiSet a] -> DiGraph
toGraph' :: forall a.
(Eq a, Hashable a, Show a) =>
GTE a -> [MultiSet a] -> DiGraph
toGraph' GTE a
gte [MultiSet a]
mss0 = String -> Set Node -> Set Edge -> DiGraph
DiGraph String
"msograph" (forall a. (Eq a, Hashable a, Ord a) => HashSet a -> Set a
toOrderedSet (forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
S.union HashSet Node
elemNodes HashSet Node
botNodes)) (forall a. (Eq a, Hashable a, Ord a) => HashSet a -> Set a
toOrderedSet HashSet Edge
edges)
  where
    indexed :: [(M.MultiSet (a, Int), Int)]
    indexed :: [(MultiSet (a, Int), Int)]
indexed = forall a. [a] -> [(a, Int)]
zindex (forall a b. (a -> b) -> [a] -> [b]
map forall a. (Eq a, Hashable a) => MultiSet a -> MultiSet (a, Int)
indexMS [MultiSet a]
mss0)

    pairs :: [((M.MultiSet (a, Int), Int), (M.MultiSet (a, Int), Int))]
    pairs :: [((MultiSet (a, Int), Int), (MultiSet (a, Int), Int))]
pairs = forall a b. [a] -> [b] -> [(a, b)]
zip [(MultiSet (a, Int), Int)]
indexed (forall a. [a] -> [a]
tail [(MultiSet (a, Int), Int)]
indexed)

    elemNodes :: HashSet Node
elemNodes = forall a. (Eq a, Hashable a) => [a] -> HashSet a
S.fromList forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter Node -> Bool
hasEdge forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall {a}. Show a => (MultiSet (a, Int), Int) -> [Node]
toNodes [(MultiSet (a, Int), Int)]
indexed

    hasEdge :: Node -> Bool
hasEdge Node
node = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Edge -> Node -> Bool
`pointsTo` Node
node) forall a b. (a -> b) -> a -> b
$ forall a. HashSet a -> [a]
S.toList HashSet Edge
edges

    pointsTo :: Edge -> Node -> Bool
pointsTo Edge
edge Node
node =
      Edge -> String
from Edge
edge forall a. Eq a => a -> a -> Bool
== Node -> String
nodeID Node
node Bool -> Bool -> Bool
|| Edge -> String
to Edge
edge forall a. Eq a => a -> a -> Bool
== Node -> String
nodeID Node
node

    edges :: S.HashSet Edge
    edges :: HashSet Edge
edges = forall a. (Eq a, Hashable a) => [a] -> HashSet a
S.fromList forall a b. (a -> b) -> a -> b
$ [Edge]
topEdges forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd ([((MultiSet (a, Int), Int), (MultiSet (a, Int), Int))]
-> [(Maybe Node, Edge)]
replEdges [((MultiSet (a, Int), Int), (MultiSet (a, Int), Int))]
pairs)

    topEdges :: [Edge]
topEdges = forall a b. (a -> b) -> [a] -> [b]
map forall {a}. (a, Int) -> Edge
go (forall a. MultiSet a -> [a]
M.toList (forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
head [(MultiSet (a, Int), Int)]
indexed)) where
      go :: (a, Int) -> Edge
go (a
_, Int
index) =
        String -> String -> Edge
mkEdge String
"⊤" ((Int, Int) -> String
nodeName (Int
index,  Int
0))

    botNodes :: HashSet Node
botNodes = forall a. (Eq a, Hashable a) => [a] -> HashSet a
S.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
Mb.mapMaybe forall a b. (a, b) -> a
fst ([((MultiSet (a, Int), Int), (MultiSet (a, Int), Int))]
-> [(Maybe Node, Edge)]
replEdges [((MultiSet (a, Int), Int), (MultiSet (a, Int), Int))]
pairs)

    nodeName :: (Int,  Int) -> String
    nodeName :: (Int, Int) -> String
nodeName (Int
elemIndex,  Int
msIndex) =
      String
"n" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
elemIndex forall a. [a] -> [a] -> [a]
++ String
"_" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
msIndex

    replEdges :: [((MultiSet (a, Int), Int), (MultiSet (a, Int), Int))]
-> [(Maybe Node, Edge)]
replEdges = HashMap (Int, Int) (Int, Int)
-> [((MultiSet (a, Int), Int), (MultiSet (a, Int), Int))]
-> [(Maybe Node, Edge)]
toEdges forall k v. HashMap k v
Mp.empty

    toEdges :: Mp.HashMap (Int, Int) (Int, Int) -> [IndexedMultisetPair a] -> [(Maybe Node, Edge)]
    toEdges :: HashMap (Int, Int) (Int, Int)
-> [((MultiSet (a, Int), Int), (MultiSet (a, Int), Int))]
-> [(Maybe Node, Edge)]
toEdges HashMap (Int, Int) (Int, Int)
_ [] = []
    toEdges HashMap (Int, Int) (Int, Int)
mp (((MultiSet (a, Int)
ts, Int
tsIndex), (MultiSet (a, Int)
us, Int
usIndex)) : [((MultiSet (a, Int), Int), (MultiSet (a, Int), Int))]
mss) =
        forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall {a}. Replace (a, Int) -> [(Maybe Node, Edge)]
redges [Replace (a, Int)]
repls forall a. [a] -> [a] -> [a]
++ HashMap (Int, Int) (Int, Int)
-> [((MultiSet (a, Int), Int), (MultiSet (a, Int), Int))]
-> [(Maybe Node, Edge)]
toEdges HashMap (Int, Int) (Int, Int)
mp' [((MultiSet (a, Int), Int), (MultiSet (a, Int), Int))]
mss
      where
        Just (MultisetGE [Replace (a, Int)]
repls) = forall a.
Eq a =>
GTE a -> MultiSet a -> MultiSet a -> Maybe (MultisetGE a)
multisetGE (\(a, Int)
t (a, Int)
u -> GTE a
gte (forall a b. (a, b) -> a
fst (a, Int)
t) (forall a b. (a, b) -> a
fst (a, Int)
u)) MultiSet (a, Int)
ts MultiSet (a, Int)
us

        lookupTIndex :: Int -> (Int, Int)
        lookupTIndex :: Int -> (Int, Int)
lookupTIndex Int
tindex = forall a. a -> Maybe a -> a
Mb.fromMaybe (Int
tindex, Int
tsIndex) (forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Mp.lookup (Int
tindex, Int
tsIndex) HashMap (Int, Int) (Int, Int)
mp)

        mp' :: HashMap (Int, Int) (Int, Int)
mp' = forall {a}.
HashMap (Int, Int) (Int, Int)
-> [Replace (a, Int)] -> HashMap (Int, Int) (Int, Int)
go HashMap (Int, Int) (Int, Int)
mp [Replace (a, Int)]
repls where
          go :: HashMap (Int, Int) (Int, Int)
-> [Replace (a, Int)] -> HashMap (Int, Int) (Int, Int)
go HashMap (Int, Int) (Int, Int)
mpi [] = HashMap (Int, Int) (Int, Int)
mpi
          go HashMap (Int, Int) (Int, Int)
mpi ((ReplaceOne (a
_, Int
i) (a
_, Int
j)):[Replace (a, Int)]
repls')
            = HashMap (Int, Int) (Int, Int)
-> [Replace (a, Int)] -> HashMap (Int, Int) (Int, Int)
go (forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
Mp.insert (Int
j, Int
usIndex) (Int -> (Int, Int)
lookupTIndex Int
i) HashMap (Int, Int) (Int, Int)
mpi) [Replace (a, Int)]
repls'
          go HashMap (Int, Int) (Int, Int)
mpi (Replace (a, Int)
_:[Replace (a, Int)]
repls') = HashMap (Int, Int) (Int, Int)
-> [Replace (a, Int)] -> HashMap (Int, Int) (Int, Int)
go HashMap (Int, Int) (Int, Int)
mpi [Replace (a, Int)]
repls'


        redges :: Replace (a, Int) -> [(Maybe Node, Edge)]
redges (Replace (a
_, Int
index) [])
          = [ ( forall a. a -> Maybe a
Just (Int -> Int -> Node
botNode Int
index Int
tsIndex)
              , String -> String -> Edge
mkEdge
                ((Int, Int) -> String
nodeName (Int -> (Int, Int)
lookupTIndex Int
index))
                (Int -> Int -> String
botNodeName Int
index Int
tsIndex)
              ) ]
        redges (ReplaceOne (a, Int)
_ (a, Int)
_) = []
        redges (Replace (a
_, Int
tindex) [(a, Int)]
us') = forall a b. (a -> b) -> [a] -> [b]
map forall {a} {a}. (a, Int) -> (Maybe a, Edge)
go [(a, Int)]
us' where
          go :: (a, Int) -> (Maybe a, Edge)
go (a
_, Int
uindex) =
            (forall a. Maybe a
Nothing, String -> String -> Edge
mkEdge ((Int, Int) -> String
nodeName (Int -> (Int, Int)
lookupTIndex Int
tindex)) ((Int, Int) -> String
nodeName (Int
uindex,  Int
usIndex)))

    toNodes :: (MultiSet (a, Int), Int) -> [Node]
toNodes (MultiSet (a, Int)
ms, Int
index) = forall a b. (a -> b) -> [a] -> [b]
map forall {a}. Show a => (a, Int) -> Node
go (forall a. MultiSet a -> [a]
M.toList MultiSet (a, Int)
ms) where

      go :: (a, Int) -> Node
go (a
e, Int
elemIndex) =
        String -> String -> String -> String -> Node
Node
          ((Int, Int) -> String
nodeName (Int
elemIndex, Int
index))
          (forall a. Show a => a -> String
show a
e)
          String
"solid"
          String
"black"

toGraph :: (Ord a, Eq a, Hashable a, Show a) => [[a]] -> DiGraph
toGraph :: forall a. (Ord a, Eq a, Hashable a, Show a) => [[a]] -> DiGraph
toGraph [[a]]
mss = forall a.
(Eq a, Hashable a, Show a) =>
GTE a -> [MultiSet a] -> DiGraph
toGraph' forall a. Ord a => a -> a -> Bool
(>=) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. (Eq a, Hashable a) => [a] -> MultiSet a
M.fromList [[a]]
mss

mkMSOGraph :: (Ord a, Eq a, Hashable a, Show a) => String -> [[a]] -> IO ()
mkMSOGraph :: forall a.
(Ord a, Eq a, Hashable a, Show a) =>
String -> [[a]] -> IO ()
mkMSOGraph String
name [[a]]
mss = String -> DiGraph -> IO ()
mkGraph String
name (forall a. (Ord a, Eq a, Hashable a, Show a) => [[a]] -> DiGraph
toGraph [[a]]
mss)

mkMSOGraphs :: (Ord a, Eq a, Hashable a, Show a) => String -> [[a]] -> IO ()
mkMSOGraphs :: forall a.
(Ord a, Eq a, Hashable a, Show a) =>
String -> [[a]] -> IO ()
mkMSOGraphs String
name [[a]]
mss0 = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall {a}. (Ord a, Hashable a, Show a) => [[a]] -> IO ()
go (forall a. Int -> [a] -> [a]
drop Int
1 forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [[a]]
L.inits [[a]]
mss0) where
  go :: [[a]] -> IO ()
go [[a]]
mss = String -> DiGraph -> IO ()
mkGraph (String
name forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length [[a]]
mss)) (forall a. (Ord a, Eq a, Hashable a, Show a) => [[a]] -> DiGraph
toGraph [[a]]
mss)

multisetGE' :: (Ord a, Hashable a) => [a] -> [a] -> Maybe (MultisetGE a)
multisetGE' :: forall a. (Ord a, Hashable a) => [a] -> [a] -> Maybe (MultisetGE a)
multisetGE' [a]
ts [a]
us = forall a.
Eq a =>
GTE a -> MultiSet a -> MultiSet a -> Maybe (MultisetGE a)
multisetGE forall a. Ord a => a -> a -> Bool
(>=) (forall a. (Eq a, Hashable a) => [a] -> MultiSet a
M.fromList [a]
ts) (forall a. (Eq a, Hashable a) => [a] -> MultiSet a
M.fromList [a]
us)