{-# OPTIONS_GHC -Wall #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  ToySolver.Converter.PB.Internal.Product
-- Copyright   :  (c) Masahiro Sakai 2018
-- License     :  BSD-style
--
-- Maintainer  :  masahiro.sakai@gmail.com
-- Stability   :  provisional
-- Portability :  portable
--
-----------------------------------------------------------------------------
module ToySolver.Converter.PB.Internal.Product
  ( decomposeToBinaryProducts
  ) where

import Data.IntSet (IntSet)
import qualified Data.IntSet as IntSet
import Data.List hiding (insert)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Ord
import Data.Set (Set)
import qualified Data.Set as Set

import qualified ToySolver.Converter.PB.Internal.LargestIntersectionFinder as LargestIntersectionFinder

decomposeToBinaryProducts :: Set IntSet -> Map IntSet (IntSet,IntSet)
decomposeToBinaryProducts :: Set IntSet -> Map IntSet (IntSet, IntSet)
decomposeToBinaryProducts = Map IntSet (Maybe (IntSet, IntSet)) -> Map IntSet (IntSet, IntSet)
decompose2 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set IntSet -> Map IntSet (Maybe (IntSet, IntSet))
decompose1

decompose1 :: Set IntSet -> Map IntSet (Maybe (IntSet,IntSet))
decompose1 :: Set IntSet -> Map IntSet (Maybe (IntSet, IntSet))
decompose1 Set IntSet
ss = forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (forall a b c. (a -> b -> c) -> b -> a -> c
flip IntSet
-> (Table, Map IntSet (Maybe (IntSet, IntSet)))
-> (Table, Map IntSet (Maybe (IntSet, IntSet)))
f) (Table
LargestIntersectionFinder.empty, forall k a. Map k a
Map.empty) [IntSet]
ss'
  where
    ss' :: [IntSet]
ss' = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing forall a b. (a, b) -> b
snd) [(IntSet
s, IntSet -> Int
IntSet.size IntSet
s) | IntSet
s <- forall a. Set a -> [a]
Set.toList Set IntSet
ss]

    f :: IntSet
      -> (LargestIntersectionFinder.Table, Map IntSet (Maybe (IntSet,IntSet)))
      -> (LargestIntersectionFinder.Table, Map IntSet (Maybe (IntSet,IntSet)))
    f :: IntSet
-> (Table, Map IntSet (Maybe (IntSet, IntSet)))
-> (Table, Map IntSet (Maybe (IntSet, IntSet)))
f IntSet
s (Table
t,Map IntSet (Maybe (IntSet, IntSet))
r) | IntSet -> Int
IntSet.size IntSet
s forall a. Ord a => a -> a -> Bool
< Int
2 Bool -> Bool -> Bool
|| IntSet
s forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Map IntSet (Maybe (IntSet, IntSet))
r = (Table
t,Map IntSet (Maybe (IntSet, IntSet))
r)
    f IntSet
s (Table
t,Map IntSet (Maybe (IntSet, IntSet))
r) =
      case IntSet -> Table -> Maybe IntSet
LargestIntersectionFinder.findLargestIntersectionSet IntSet
s Table
t of
        Maybe IntSet
Nothing ->
          ( IntSet -> Table -> Table
LargestIntersectionFinder.insert IntSet
s Table
t
          , forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert IntSet
s forall a. Maybe a
Nothing Map IntSet (Maybe (IntSet, IntSet))
r
          )
        Just IntSet
s0 ->
          let s1 :: IntSet
s1 = IntSet
s IntSet -> IntSet -> IntSet
`IntSet.intersection` IntSet
s0
              s2 :: IntSet
s2 = IntSet
s IntSet -> IntSet -> IntSet
IntSet.\\ IntSet
s1
           in if IntSet -> Int
IntSet.size IntSet
s1 forall a. Ord a => a -> a -> Bool
< Int
2 Bool -> Bool -> Bool
&& IntSet -> Int
IntSet.size IntSet
s2 forall a. Ord a => a -> a -> Bool
< Int
2 then
                ( IntSet -> Table -> Table
LargestIntersectionFinder.insert IntSet
s Table
t
                , forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert IntSet
s forall a. Maybe a
Nothing Map IntSet (Maybe (IntSet, IntSet))
r
                )
              else if IntSet -> Bool
IntSet.null IntSet
s2 then -- i.e. s⊆s0
                case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup IntSet
s0 Map IntSet (Maybe (IntSet, IntSet))
r of
                  Maybe (Maybe (IntSet, IntSet))
Nothing -> forall a. HasCallStack => [Char] -> a
error [Char]
"should not happen"
                  Just Maybe (IntSet, IntSet)
Nothing ->
                    let s3 :: IntSet
s3 = IntSet
s0 IntSet -> IntSet -> IntSet
IntSet.\\ IntSet
s
                     in ( IntSet -> Table -> Table
LargestIntersectionFinder.insert IntSet
s3 forall a b. (a -> b) -> a -> b
$ IntSet -> Table -> Table
LargestIntersectionFinder.insert IntSet
s Table
t
                        , -- union is left-biased
                          forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert IntSet
s0 (forall a. a -> Maybe a
Just (IntSet
s, IntSet
s3)) forall a b. (a -> b) -> a -> b
$
                            forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union Map IntSet (Maybe (IntSet, IntSet))
r (forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (\(IntSet
s',Maybe (IntSet, IntSet)
_) -> IntSet -> Int
IntSet.size IntSet
s' forall a. Ord a => a -> a -> Bool
>= Int
2) [(IntSet
s, forall a. Maybe a
Nothing), (IntSet
s3, forall a. Maybe a
Nothing)])
                        )
                  Just Maybe (IntSet, IntSet)
_ ->
                    ( IntSet -> Table -> Table
LargestIntersectionFinder.insert IntSet
s Table
t
                    , forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union Map IntSet (Maybe (IntSet, IntSet))
r (forall k a. k -> a -> Map k a
Map.singleton IntSet
s forall a. Maybe a
Nothing)
                    )
              else
                case IntSet
-> (Table, Map IntSet (Maybe (IntSet, IntSet)))
-> (Table, Map IntSet (Maybe (IntSet, IntSet)))
f IntSet
s2 (IntSet
-> (Table, Map IntSet (Maybe (IntSet, IntSet)))
-> (Table, Map IntSet (Maybe (IntSet, IntSet)))
f IntSet
s1 (Table
t,Map IntSet (Maybe (IntSet, IntSet))
r))  of
                   (Table
t',Map IntSet (Maybe (IntSet, IntSet))
r') ->
                     ( IntSet -> Table -> Table
LargestIntersectionFinder.insert IntSet
s Table
t'
                     , forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert IntSet
s (forall a. a -> Maybe a
Just (IntSet
s1,IntSet
s2)) Map IntSet (Maybe (IntSet, IntSet))
r'
                     )

decompose2 :: Map IntSet (Maybe (IntSet,IntSet)) -> Map IntSet (IntSet,IntSet)
decompose2 :: Map IntSet (Maybe (IntSet, IntSet)) -> Map IntSet (IntSet, IntSet)
decompose2 Map IntSet (Maybe (IntSet, IntSet))
m = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ do
  (IntSet
s,Maybe (IntSet, IntSet)
d) <- forall k a. Map k a -> [(k, a)]
Map.toList Map IntSet (Maybe (IntSet, IntSet))
m
  case Maybe (IntSet, IntSet)
d of
    Just (IntSet
s1,IntSet
s2) -> forall (m :: * -> *) a. Monad m => a -> m a
return (IntSet
s, (IntSet
s1,IntSet
s2))
    Maybe (IntSet, IntSet)
Nothing -> [Int] -> Int -> [(IntSet, (IntSet, IntSet))]
f (IntSet -> [Int]
IntSet.toList IntSet
s) (IntSet -> Int
IntSet.size IntSet
s)
  where
    f :: [Int] -> Int -> [(IntSet, (IntSet, IntSet))]
f [Int]
s Int
n
      | Int
n forall a. Ord a => a -> a -> Bool
< Int
2  = []
      | Int
n forall a. Eq a => a -> a -> Bool
== Int
2 = forall (m :: * -> *) a. Monad m => a -> m a
return ([Int] -> IntSet
IntSet.fromList [Int]
s, (Int -> IntSet
IntSet.singleton ([Int]
s forall a. [a] -> Int -> a
!! Int
0), Int -> IntSet
IntSet.singleton ([Int]
s forall a. [a] -> Int -> a
!! Int
1)))
      | Bool
otherwise =
          case forall a. Int -> [a] -> ([a], [a])
splitAt (Int
n forall a. Integral a => a -> a -> a
`div` Int
2) [Int]
s  of
            ([Int]
s1, [Int]
s2) -> ([Int] -> IntSet
IntSet.fromList [Int]
s, ([Int] -> IntSet
IntSet.fromList [Int]
s1, [Int] -> IntSet
IntSet.fromList [Int]
s2)) forall a. a -> [a] -> [a]
: [Int] -> Int -> [(IntSet, (IntSet, IntSet))]
f [Int]
s1 (Int
n forall a. Integral a => a -> a -> a
`div` Int
2) forall a. [a] -> [a] -> [a]
++ [Int] -> Int -> [(IntSet, (IntSet, IntSet))]
f [Int]
s2 (Int
n forall a. Num a => a -> a -> a
- (Int
n forall a. Integral a => a -> a -> a
`div` Int
2))