module TypedSession.State.Constraint (SubMap, Constraint (..), constrToSubMap) where
import Data.IntMap (IntMap)
import qualified Data.IntMap as I
import qualified Data.List as L
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 :: 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 :: [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 :: [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 :: [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 :: [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