module TypedSession.State.Constraint (SubMap, Constraint (..), constrToSubMap) where

import Data.IntMap (IntMap)
import qualified Data.IntMap as I
import qualified Data.List as L

{- | Constraint
 1 ~ 2 = Constraint 1 2
 2 ~ 3 = Constraint 2 3
-}
data Constraint = Constraint Int Int
  deriving (Int -> Constraint -> ShowS
[Constraint] -> ShowS
Constraint -> String
(Int -> Constraint -> ShowS)
-> (Constraint -> String)
-> ([Constraint] -> ShowS)
-> Show Constraint
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Constraint -> ShowS
showsPrec :: Int -> Constraint -> ShowS
$cshow :: Constraint -> String
show :: Constraint -> String
$cshowList :: [Constraint] -> ShowS
showList :: [Constraint] -> ShowS
Show, Constraint -> Constraint -> Bool
(Constraint -> Constraint -> Bool)
-> (Constraint -> Constraint -> Bool) -> Eq Constraint
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Constraint -> Constraint -> Bool
== :: Constraint -> Constraint -> Bool
$c/= :: Constraint -> Constraint -> Bool
/= :: Constraint -> Constraint -> Bool
Eq, Eq Constraint
Eq Constraint =>
(Constraint -> Constraint -> Ordering)
-> (Constraint -> Constraint -> Bool)
-> (Constraint -> Constraint -> Bool)
-> (Constraint -> Constraint -> Bool)
-> (Constraint -> Constraint -> Bool)
-> (Constraint -> Constraint -> Constraint)
-> (Constraint -> Constraint -> Constraint)
-> Ord Constraint
Constraint -> Constraint -> Bool
Constraint -> Constraint -> Ordering
Constraint -> Constraint -> Constraint
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Constraint -> Constraint -> Ordering
compare :: Constraint -> Constraint -> Ordering
$c< :: Constraint -> Constraint -> Bool
< :: Constraint -> Constraint -> Bool
$c<= :: Constraint -> Constraint -> Bool
<= :: Constraint -> Constraint -> Bool
$c> :: Constraint -> Constraint -> Bool
> :: Constraint -> Constraint -> Bool
$c>= :: Constraint -> Constraint -> Bool
>= :: Constraint -> Constraint -> Bool
$cmax :: Constraint -> Constraint -> Constraint
max :: Constraint -> Constraint -> Constraint
$cmin :: Constraint -> Constraint -> Constraint
min :: Constraint -> Constraint -> Constraint
Ord)

type SubMap = IntMap Int

toTuple :: Constraint -> (Int, Int)
toTuple :: Constraint -> (Int, Int)
toTuple (Constraint Int
b Int
s) = (Int
b, Int
s)

{- | bigSwapConstr
>>> bigSwapConstr (Constraint 1 2)
Constraint 2 1
-}
bigSwapConstr :: Constraint -> Constraint
bigSwapConstr :: Constraint -> Constraint
bigSwapConstr (Constraint Int
a Int
b)
  | Int
a Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
b = Int -> Int -> Constraint
Constraint Int
a Int
b
  | Bool
otherwise = Int -> Int -> Constraint
Constraint Int
b Int
a

subFun :: [Constraint] -> [Constraint]
subFun :: [Constraint] -> [Constraint]
subFun [] = []
subFun (Constraint Int
b Int
s : [Constraint]
ys) = Int -> Int -> Constraint
Constraint Int
b Int
s Constraint -> [Constraint] -> [Constraint]
forall a. a -> [a] -> [a]
: [Constraint] -> [Constraint]
subFun (Int -> Int -> [Constraint] -> [Constraint]
replace Int
b Int
s [Constraint]
ys)

replace :: Int -> Int -> [Constraint] -> [Constraint]
replace :: Int -> Int -> [Constraint] -> [Constraint]
replace Int
_b Int
_s [] = []
replace Int
b Int
s ((Constraint Int
b' Int
s') : [Constraint]
ys) =
  if Int
b Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
s'
    then Int -> Int -> Constraint
Constraint Int
b' Int
s Constraint -> [Constraint] -> [Constraint]
forall a. a -> [a] -> [a]
: Int -> Int -> [Constraint] -> [Constraint]
replace Int
b Int
s [Constraint]
ys
    else Int -> Int -> Constraint
Constraint Int
b' Int
s' Constraint -> [Constraint] -> [Constraint]
forall a. a -> [a] -> [a]
: Int -> Int -> [Constraint] -> [Constraint]
replace Int
b Int
s [Constraint]
ys

{- | findNewConstraint
>>> findNewConstraint [Constraint 3 1, Constraint 4 2, Constraint 4 3]
[[Constraint 3 2]]
-}
findNewConstraint :: [Constraint] -> [[Constraint]]
findNewConstraint :: [Constraint] -> [[Constraint]]
findNewConstraint [Constraint]
ls =
  let grouped :: [[Constraint]]
grouped = (Constraint -> Constraint -> Bool)
-> [Constraint] -> [[Constraint]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
L.groupBy (\(Constraint Int
a Int
_) (Constraint Int
c Int
_) -> Int
a Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
c) [Constraint]
ls
      genCons :: [[Constraint]] -> [Constraint] -> [[Constraint]]
genCons [[Constraint]]
s [Constraint]
val = case [Constraint]
val of
        [] -> [[Constraint]]
s
        [Constraint
_] -> [[Constraint]]
s
        [Constraint]
xs ->
          case [Int] -> [Int]
forall a. Ord a => [a] -> [a]
L.sort ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ (Constraint -> Int) -> [Constraint] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map ((Int, Int) -> Int
forall a b. (a, b) -> b
snd ((Int, Int) -> Int)
-> (Constraint -> (Int, Int)) -> Constraint -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Constraint -> (Int, Int)
toTuple) [Constraint]
xs of
            [] -> String -> [[Constraint]]
forall a. HasCallStack => String -> a
error String
"np"
            Int
minVal : [Int]
txs' -> (Int -> Constraint) -> [Int] -> [Constraint]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Int -> Constraint
`Constraint` Int
minVal) [Int]
txs' [Constraint] -> [[Constraint]] -> [[Constraint]]
forall a. a -> [a] -> [a]
: [[Constraint]]
s
   in ([[Constraint]] -> [Constraint] -> [[Constraint]])
-> [[Constraint]] -> [[Constraint]] -> [[Constraint]]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' [[Constraint]] -> [Constraint] -> [[Constraint]]
genCons [] [[Constraint]]
grouped

{- | stepConstraint
>>> stepConstraint [Constraint 3 1, Constraint 4 2, Constraint 4 3]
[Constraint 3 1,Constraint 4 2,Constraint 4 1]
-}
stepConstraint :: [Constraint] -> [Constraint]
stepConstraint :: [Constraint] -> [Constraint]
stepConstraint = [Constraint] -> [Constraint]
forall a. Eq a => [a] -> [a]
L.nub ([Constraint] -> [Constraint])
-> ([Constraint] -> [Constraint]) -> [Constraint] -> [Constraint]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Constraint] -> [Constraint]
subFun ([Constraint] -> [Constraint])
-> ([Constraint] -> [Constraint]) -> [Constraint] -> [Constraint]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Constraint] -> [Constraint]
forall a. Ord a => [a] -> [a]
L.sort ([Constraint] -> [Constraint])
-> ([Constraint] -> [Constraint]) -> [Constraint] -> [Constraint]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Constraint] -> [Constraint]
forall a. Eq a => [a] -> [a]
L.nub ([Constraint] -> [Constraint])
-> ([Constraint] -> [Constraint]) -> [Constraint] -> [Constraint]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Constraint -> Constraint) -> [Constraint] -> [Constraint]
forall a b. (a -> b) -> [a] -> [b]
map Constraint -> Constraint
bigSwapConstr

{- | constraintLoop
>>> constraintLoop [Constraint 3 1, Constraint 4 2, Constraint 4 3]
[Constraint 2 1,Constraint 3 1,Constraint 4 1]

-------------------------------------------------

>>> stepConstraint [Constraint 3 1, Constraint 4 2, Constraint 4 3]
[Constraint 3 1,Constraint 4 2,Constraint 4 1]

>>> findNewConstraint [Constraint 3 1,Constraint 4 2,Constraint 4 1]
[[Constraint 2 1]]

>>> stepConstraint ([Constraint 3 1,Constraint 4 2,Constraint 4 1] <> [Constraint 2 1])
[Constraint 2 1,Constraint 3 1,Constraint 4 1]
-}
constraintLoop :: [Constraint] -> [Constraint]
constraintLoop :: [Constraint] -> [Constraint]
constraintLoop [Constraint]
ls =
  let ls' :: [Constraint]
ls' = [Constraint] -> [Constraint]
stepConstraint [Constraint]
ls
   in case [Constraint] -> [[Constraint]]
findNewConstraint [Constraint]
ls' of
        [] -> [Constraint]
ls'
        [[Constraint]]
xs -> [Constraint] -> [Constraint]
constraintLoop ([[Constraint]] -> [Constraint]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Constraint]]
xs [Constraint] -> [Constraint] -> [Constraint]
forall a. Semigroup a => a -> a -> a
<> [Constraint]
ls')

{- | constrToSubMap
>>> constrToSubMap [Constraint 3 1, Constraint 4 2, Constraint 4 3]
fromList [(2,1),(3,1),(4,1)]
-}
constrToSubMap :: [Constraint] -> SubMap
constrToSubMap :: [Constraint] -> SubMap
constrToSubMap [Constraint]
ls = [(Int, Int)] -> SubMap
forall a. [(Int, a)] -> IntMap a
I.fromList ([(Int, Int)] -> SubMap) -> [(Int, Int)] -> SubMap
forall a b. (a -> b) -> a -> b
$ (Constraint -> (Int, Int)) -> [Constraint] -> [(Int, Int)]
forall a b. (a -> b) -> [a] -> [b]
map Constraint -> (Int, Int)
toTuple ([Constraint] -> [(Int, Int)]) -> [Constraint] -> [(Int, Int)]
forall a b. (a -> b) -> a -> b
$ [Constraint] -> [Constraint]
constraintLoop [Constraint]
ls