{-# 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 (Map IntSet (Maybe (IntSet, IntSet))
 -> Map IntSet (IntSet, IntSet))
-> (Set IntSet -> Map IntSet (Maybe (IntSet, IntSet)))
-> Set IntSet
-> Map IntSet (IntSet, IntSet)
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 = (Table, Map IntSet (Maybe (IntSet, IntSet)))
-> Map IntSet (Maybe (IntSet, IntSet))
forall a b. (a, b) -> b
snd ((Table, Map IntSet (Maybe (IntSet, IntSet)))
 -> Map IntSet (Maybe (IntSet, IntSet)))
-> (Table, Map IntSet (Maybe (IntSet, IntSet)))
-> Map IntSet (Maybe (IntSet, IntSet))
forall a b. (a -> b) -> a -> b
$ ((Table, Map IntSet (Maybe (IntSet, IntSet)))
 -> IntSet -> (Table, Map IntSet (Maybe (IntSet, IntSet))))
-> (Table, Map IntSet (Maybe (IntSet, IntSet)))
-> [IntSet]
-> (Table, Map IntSet (Maybe (IntSet, IntSet)))
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ((IntSet
 -> (Table, Map IntSet (Maybe (IntSet, IntSet)))
 -> (Table, Map IntSet (Maybe (IntSet, IntSet))))
-> (Table, Map IntSet (Maybe (IntSet, IntSet)))
-> IntSet
-> (Table, Map IntSet (Maybe (IntSet, IntSet)))
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, Map IntSet (Maybe (IntSet, IntSet))
forall k a. Map k a
Map.empty) [IntSet]
ss'
  where
    ss' :: [IntSet]
ss' = ((IntSet, Int) -> IntSet) -> [(IntSet, Int)] -> [IntSet]
forall a b. (a -> b) -> [a] -> [b]
map (IntSet, Int) -> IntSet
forall a b. (a, b) -> a
fst ([(IntSet, Int)] -> [IntSet]) -> [(IntSet, Int)] -> [IntSet]
forall a b. (a -> b) -> a -> b
$ ((IntSet, Int) -> (IntSet, Int) -> Ordering)
-> [(IntSet, Int)] -> [(IntSet, Int)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((IntSet, Int) -> Int)
-> (IntSet, Int) -> (IntSet, Int) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (IntSet, Int) -> Int
forall a b. (a, b) -> b
snd) [(IntSet
s, IntSet -> Int
IntSet.size IntSet
s) | IntSet
s <- Set IntSet -> [IntSet]
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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2 Bool -> Bool -> Bool
|| IntSet
s IntSet -> Map IntSet (Maybe (IntSet, IntSet)) -> Bool
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
          , IntSet
-> Maybe (IntSet, IntSet)
-> Map IntSet (Maybe (IntSet, IntSet))
-> Map IntSet (Maybe (IntSet, IntSet))
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert IntSet
s Maybe (IntSet, IntSet)
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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2 Bool -> Bool -> Bool
&& IntSet -> Int
IntSet.size IntSet
s2 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2 then
                ( IntSet -> Table -> Table
LargestIntersectionFinder.insert IntSet
s Table
t
                , IntSet
-> Maybe (IntSet, IntSet)
-> Map IntSet (Maybe (IntSet, IntSet))
-> Map IntSet (Maybe (IntSet, IntSet))
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert IntSet
s Maybe (IntSet, IntSet)
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 IntSet
-> Map IntSet (Maybe (IntSet, IntSet))
-> Maybe (Maybe (IntSet, IntSet))
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 -> [Char] -> (Table, Map IntSet (Maybe (IntSet, IntSet)))
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 (Table -> Table) -> Table -> Table
forall a b. (a -> b) -> a -> b
$ IntSet -> Table -> Table
LargestIntersectionFinder.insert IntSet
s Table
t
                        , -- union is left-biased
                          IntSet
-> Maybe (IntSet, IntSet)
-> Map IntSet (Maybe (IntSet, IntSet))
-> Map IntSet (Maybe (IntSet, IntSet))
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert IntSet
s0 ((IntSet, IntSet) -> Maybe (IntSet, IntSet)
forall a. a -> Maybe a
Just (IntSet
s, IntSet
s3)) (Map IntSet (Maybe (IntSet, IntSet))
 -> Map IntSet (Maybe (IntSet, IntSet)))
-> Map IntSet (Maybe (IntSet, IntSet))
-> Map IntSet (Maybe (IntSet, IntSet))
forall a b. (a -> b) -> a -> b
$
                            Map IntSet (Maybe (IntSet, IntSet))
-> Map IntSet (Maybe (IntSet, IntSet))
-> Map IntSet (Maybe (IntSet, IntSet))
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union Map IntSet (Maybe (IntSet, IntSet))
r ([(IntSet, Maybe (IntSet, IntSet))]
-> Map IntSet (Maybe (IntSet, IntSet))
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(IntSet, Maybe (IntSet, IntSet))]
 -> Map IntSet (Maybe (IntSet, IntSet)))
-> [(IntSet, Maybe (IntSet, IntSet))]
-> Map IntSet (Maybe (IntSet, IntSet))
forall a b. (a -> b) -> a -> b
$ ((IntSet, Maybe (IntSet, IntSet)) -> Bool)
-> [(IntSet, Maybe (IntSet, IntSet))]
-> [(IntSet, Maybe (IntSet, IntSet))]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(IntSet
s',Maybe (IntSet, IntSet)
_) -> IntSet -> Int
IntSet.size IntSet
s' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2) [(IntSet
s, Maybe (IntSet, IntSet)
forall a. Maybe a
Nothing), (IntSet
s3, Maybe (IntSet, IntSet)
forall a. Maybe a
Nothing)])
                        )
                  Just Maybe (IntSet, IntSet)
_ ->
                    ( IntSet -> Table -> Table
LargestIntersectionFinder.insert IntSet
s Table
t
                    , Map IntSet (Maybe (IntSet, IntSet))
-> Map IntSet (Maybe (IntSet, IntSet))
-> Map IntSet (Maybe (IntSet, IntSet))
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union Map IntSet (Maybe (IntSet, IntSet))
r (IntSet
-> Maybe (IntSet, IntSet) -> Map IntSet (Maybe (IntSet, IntSet))
forall k a. k -> a -> Map k a
Map.singleton IntSet
s Maybe (IntSet, IntSet)
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'
                     , IntSet
-> Maybe (IntSet, IntSet)
-> Map IntSet (Maybe (IntSet, IntSet))
-> Map IntSet (Maybe (IntSet, IntSet))
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert IntSet
s ((IntSet, IntSet) -> Maybe (IntSet, IntSet)
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 = [(IntSet, (IntSet, IntSet))] -> Map IntSet (IntSet, IntSet)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(IntSet, (IntSet, IntSet))] -> Map IntSet (IntSet, IntSet))
-> [(IntSet, (IntSet, IntSet))] -> Map IntSet (IntSet, IntSet)
forall a b. (a -> b) -> a -> b
$ do
  (IntSet
s,Maybe (IntSet, IntSet)
d) <- Map IntSet (Maybe (IntSet, IntSet))
-> [(IntSet, Maybe (IntSet, IntSet))]
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) -> (IntSet, (IntSet, IntSet)) -> [(IntSet, (IntSet, IntSet))]
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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2  = []
      | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2 = (IntSet, (IntSet, IntSet)) -> [(IntSet, (IntSet, IntSet))]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Int] -> IntSet
IntSet.fromList [Int]
s, (Int -> IntSet
IntSet.singleton ([Int]
s [Int] -> Int -> Int
forall a. [a] -> Int -> a
!! Int
0), Int -> IntSet
IntSet.singleton ([Int]
s [Int] -> Int -> Int
forall a. [a] -> Int -> a
!! Int
1)))
      | Bool
otherwise =
          case Int -> [Int] -> ([Int], [Int])
forall a. Int -> [a] -> ([a], [a])
splitAt (Int
n Int -> Int -> Int
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)) (IntSet, (IntSet, IntSet))
-> [(IntSet, (IntSet, IntSet))] -> [(IntSet, (IntSet, IntSet))]
forall a. a -> [a] -> [a]
: [Int] -> Int -> [(IntSet, (IntSet, IntSet))]
f [Int]
s1 (Int
n Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2) [(IntSet, (IntSet, IntSet))]
-> [(IntSet, (IntSet, IntSet))] -> [(IntSet, (IntSet, IntSet))]
forall a. [a] -> [a] -> [a]
++ [Int] -> Int -> [(IntSet, (IntSet, IntSet))]
f [Int]
s2 (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- (Int
n Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2))