{- |
This implements "Math.SetCover.Exact" using unboxed arrays of bit vectors.
It should always be faster than using 'Integer's as bit vectors.
In contrast to 'IntSet' the set representation here is dense,
but has a much simpler structure.
It should be faster than 'IntSet' for most applications.
-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Math.SetCover.Exact.UArray (
   partitions, search, step,
   State(..), initState, updateState,
   ) where

import qualified Math.SetCover.Exact as ESC
import qualified Math.SetCover.Bit as Bit
import Math.SetCover.Exact.Block (blocksFromSets)

import Control.Monad.ST.Strict (ST)
import Control.Monad (foldM, forM_, when)

import qualified Data.Array.ST as STUArray
import qualified Data.Array.Unboxed as UArray
import qualified Data.List.Match as Match
import qualified Data.Set as Set
import qualified Data.Word as Word
import Data.Array.ST (STUArray, runSTUArray, writeArray)
import Data.Array.Unboxed (UArray)
import Data.Array.IArray (listArray, bounds, range, (!))
import Data.Array (Array, Ix)
import Data.Set (Set)
import Data.Tuple.HT (mapPair, mapSnd, fst3)
import Data.Bits (xor, (.&.), (.|.))



type Block = Word.Word64

newtype SetId = SetId Int deriving (SetId -> SetId -> Bool
(SetId -> SetId -> Bool) -> (SetId -> SetId -> Bool) -> Eq SetId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SetId -> SetId -> Bool
== :: SetId -> SetId -> Bool
$c/= :: SetId -> SetId -> Bool
/= :: SetId -> SetId -> Bool
Eq,Eq SetId
Eq SetId
-> (SetId -> SetId -> Ordering)
-> (SetId -> SetId -> Bool)
-> (SetId -> SetId -> Bool)
-> (SetId -> SetId -> Bool)
-> (SetId -> SetId -> Bool)
-> (SetId -> SetId -> SetId)
-> (SetId -> SetId -> SetId)
-> Ord SetId
SetId -> SetId -> Bool
SetId -> SetId -> Ordering
SetId -> SetId -> SetId
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 :: SetId -> SetId -> Ordering
compare :: SetId -> SetId -> Ordering
$c< :: SetId -> SetId -> Bool
< :: SetId -> SetId -> Bool
$c<= :: SetId -> SetId -> Bool
<= :: SetId -> SetId -> Bool
$c> :: SetId -> SetId -> Bool
> :: SetId -> SetId -> Bool
$c>= :: SetId -> SetId -> Bool
>= :: SetId -> SetId -> Bool
$cmax :: SetId -> SetId -> SetId
max :: SetId -> SetId -> SetId
$cmin :: SetId -> SetId -> SetId
min :: SetId -> SetId -> SetId
Ord,Ord SetId
Ord SetId
-> ((SetId, SetId) -> [SetId])
-> ((SetId, SetId) -> SetId -> Int)
-> ((SetId, SetId) -> SetId -> Int)
-> ((SetId, SetId) -> SetId -> Bool)
-> ((SetId, SetId) -> Int)
-> ((SetId, SetId) -> Int)
-> Ix SetId
(SetId, SetId) -> Int
(SetId, SetId) -> [SetId]
(SetId, SetId) -> SetId -> Bool
(SetId, SetId) -> SetId -> Int
forall a.
Ord a
-> ((a, a) -> [a])
-> ((a, a) -> a -> Int)
-> ((a, a) -> a -> Int)
-> ((a, a) -> a -> Bool)
-> ((a, a) -> Int)
-> ((a, a) -> Int)
-> Ix a
$crange :: (SetId, SetId) -> [SetId]
range :: (SetId, SetId) -> [SetId]
$cindex :: (SetId, SetId) -> SetId -> Int
index :: (SetId, SetId) -> SetId -> Int
$cunsafeIndex :: (SetId, SetId) -> SetId -> Int
unsafeIndex :: (SetId, SetId) -> SetId -> Int
$cinRange :: (SetId, SetId) -> SetId -> Bool
inRange :: (SetId, SetId) -> SetId -> Bool
$crangeSize :: (SetId, SetId) -> Int
rangeSize :: (SetId, SetId) -> Int
$cunsafeRangeSize :: (SetId, SetId) -> Int
unsafeRangeSize :: (SetId, SetId) -> Int
Ix,Int -> SetId
SetId -> Int
SetId -> [SetId]
SetId -> SetId
SetId -> SetId -> [SetId]
SetId -> SetId -> SetId -> [SetId]
(SetId -> SetId)
-> (SetId -> SetId)
-> (Int -> SetId)
-> (SetId -> Int)
-> (SetId -> [SetId])
-> (SetId -> SetId -> [SetId])
-> (SetId -> SetId -> [SetId])
-> (SetId -> SetId -> SetId -> [SetId])
-> Enum SetId
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: SetId -> SetId
succ :: SetId -> SetId
$cpred :: SetId -> SetId
pred :: SetId -> SetId
$ctoEnum :: Int -> SetId
toEnum :: Int -> SetId
$cfromEnum :: SetId -> Int
fromEnum :: SetId -> Int
$cenumFrom :: SetId -> [SetId]
enumFrom :: SetId -> [SetId]
$cenumFromThen :: SetId -> SetId -> [SetId]
enumFromThen :: SetId -> SetId -> [SetId]
$cenumFromTo :: SetId -> SetId -> [SetId]
enumFromTo :: SetId -> SetId -> [SetId]
$cenumFromThenTo :: SetId -> SetId -> SetId -> [SetId]
enumFromThenTo :: SetId -> SetId -> SetId -> [SetId]
Enum,Int -> SetId -> ShowS
[SetId] -> ShowS
SetId -> String
(Int -> SetId -> ShowS)
-> (SetId -> String) -> ([SetId] -> ShowS) -> Show SetId
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SetId -> ShowS
showsPrec :: Int -> SetId -> ShowS
$cshow :: SetId -> String
show :: SetId -> String
$cshowList :: [SetId] -> ShowS
showList :: [SetId] -> ShowS
Show)
newtype DigitId = DigitId Int deriving (DigitId -> DigitId -> Bool
(DigitId -> DigitId -> Bool)
-> (DigitId -> DigitId -> Bool) -> Eq DigitId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DigitId -> DigitId -> Bool
== :: DigitId -> DigitId -> Bool
$c/= :: DigitId -> DigitId -> Bool
/= :: DigitId -> DigitId -> Bool
Eq,Eq DigitId
Eq DigitId
-> (DigitId -> DigitId -> Ordering)
-> (DigitId -> DigitId -> Bool)
-> (DigitId -> DigitId -> Bool)
-> (DigitId -> DigitId -> Bool)
-> (DigitId -> DigitId -> Bool)
-> (DigitId -> DigitId -> DigitId)
-> (DigitId -> DigitId -> DigitId)
-> Ord DigitId
DigitId -> DigitId -> Bool
DigitId -> DigitId -> Ordering
DigitId -> DigitId -> DigitId
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 :: DigitId -> DigitId -> Ordering
compare :: DigitId -> DigitId -> Ordering
$c< :: DigitId -> DigitId -> Bool
< :: DigitId -> DigitId -> Bool
$c<= :: DigitId -> DigitId -> Bool
<= :: DigitId -> DigitId -> Bool
$c> :: DigitId -> DigitId -> Bool
> :: DigitId -> DigitId -> Bool
$c>= :: DigitId -> DigitId -> Bool
>= :: DigitId -> DigitId -> Bool
$cmax :: DigitId -> DigitId -> DigitId
max :: DigitId -> DigitId -> DigitId
$cmin :: DigitId -> DigitId -> DigitId
min :: DigitId -> DigitId -> DigitId
Ord,Ord DigitId
Ord DigitId
-> ((DigitId, DigitId) -> [DigitId])
-> ((DigitId, DigitId) -> DigitId -> Int)
-> ((DigitId, DigitId) -> DigitId -> Int)
-> ((DigitId, DigitId) -> DigitId -> Bool)
-> ((DigitId, DigitId) -> Int)
-> ((DigitId, DigitId) -> Int)
-> Ix DigitId
(DigitId, DigitId) -> Int
(DigitId, DigitId) -> [DigitId]
(DigitId, DigitId) -> DigitId -> Bool
(DigitId, DigitId) -> DigitId -> Int
forall a.
Ord a
-> ((a, a) -> [a])
-> ((a, a) -> a -> Int)
-> ((a, a) -> a -> Int)
-> ((a, a) -> a -> Bool)
-> ((a, a) -> Int)
-> ((a, a) -> Int)
-> Ix a
$crange :: (DigitId, DigitId) -> [DigitId]
range :: (DigitId, DigitId) -> [DigitId]
$cindex :: (DigitId, DigitId) -> DigitId -> Int
index :: (DigitId, DigitId) -> DigitId -> Int
$cunsafeIndex :: (DigitId, DigitId) -> DigitId -> Int
unsafeIndex :: (DigitId, DigitId) -> DigitId -> Int
$cinRange :: (DigitId, DigitId) -> DigitId -> Bool
inRange :: (DigitId, DigitId) -> DigitId -> Bool
$crangeSize :: (DigitId, DigitId) -> Int
rangeSize :: (DigitId, DigitId) -> Int
$cunsafeRangeSize :: (DigitId, DigitId) -> Int
unsafeRangeSize :: (DigitId, DigitId) -> Int
Ix,Int -> DigitId
DigitId -> Int
DigitId -> [DigitId]
DigitId -> DigitId
DigitId -> DigitId -> [DigitId]
DigitId -> DigitId -> DigitId -> [DigitId]
(DigitId -> DigitId)
-> (DigitId -> DigitId)
-> (Int -> DigitId)
-> (DigitId -> Int)
-> (DigitId -> [DigitId])
-> (DigitId -> DigitId -> [DigitId])
-> (DigitId -> DigitId -> [DigitId])
-> (DigitId -> DigitId -> DigitId -> [DigitId])
-> Enum DigitId
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: DigitId -> DigitId
succ :: DigitId -> DigitId
$cpred :: DigitId -> DigitId
pred :: DigitId -> DigitId
$ctoEnum :: Int -> DigitId
toEnum :: Int -> DigitId
$cfromEnum :: DigitId -> Int
fromEnum :: DigitId -> Int
$cenumFrom :: DigitId -> [DigitId]
enumFrom :: DigitId -> [DigitId]
$cenumFromThen :: DigitId -> DigitId -> [DigitId]
enumFromThen :: DigitId -> DigitId -> [DigitId]
$cenumFromTo :: DigitId -> DigitId -> [DigitId]
enumFromTo :: DigitId -> DigitId -> [DigitId]
$cenumFromThenTo :: DigitId -> DigitId -> DigitId -> [DigitId]
enumFromThenTo :: DigitId -> DigitId -> DigitId -> [DigitId]
Enum,Int -> DigitId -> ShowS
[DigitId] -> ShowS
DigitId -> String
(Int -> DigitId -> ShowS)
-> (DigitId -> String) -> ([DigitId] -> ShowS) -> Show DigitId
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DigitId -> ShowS
showsPrec :: Int -> DigitId -> ShowS
$cshow :: DigitId -> String
show :: DigitId -> String
$cshowList :: [DigitId] -> ShowS
showList :: [DigitId] -> ShowS
Show)
newtype BlockId = BlockId Int deriving (BlockId -> BlockId -> Bool
(BlockId -> BlockId -> Bool)
-> (BlockId -> BlockId -> Bool) -> Eq BlockId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BlockId -> BlockId -> Bool
== :: BlockId -> BlockId -> Bool
$c/= :: BlockId -> BlockId -> Bool
/= :: BlockId -> BlockId -> Bool
Eq,Eq BlockId
Eq BlockId
-> (BlockId -> BlockId -> Ordering)
-> (BlockId -> BlockId -> Bool)
-> (BlockId -> BlockId -> Bool)
-> (BlockId -> BlockId -> Bool)
-> (BlockId -> BlockId -> Bool)
-> (BlockId -> BlockId -> BlockId)
-> (BlockId -> BlockId -> BlockId)
-> Ord BlockId
BlockId -> BlockId -> Bool
BlockId -> BlockId -> Ordering
BlockId -> BlockId -> BlockId
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 :: BlockId -> BlockId -> Ordering
compare :: BlockId -> BlockId -> Ordering
$c< :: BlockId -> BlockId -> Bool
< :: BlockId -> BlockId -> Bool
$c<= :: BlockId -> BlockId -> Bool
<= :: BlockId -> BlockId -> Bool
$c> :: BlockId -> BlockId -> Bool
> :: BlockId -> BlockId -> Bool
$c>= :: BlockId -> BlockId -> Bool
>= :: BlockId -> BlockId -> Bool
$cmax :: BlockId -> BlockId -> BlockId
max :: BlockId -> BlockId -> BlockId
$cmin :: BlockId -> BlockId -> BlockId
min :: BlockId -> BlockId -> BlockId
Ord,Ord BlockId
Ord BlockId
-> ((BlockId, BlockId) -> [BlockId])
-> ((BlockId, BlockId) -> BlockId -> Int)
-> ((BlockId, BlockId) -> BlockId -> Int)
-> ((BlockId, BlockId) -> BlockId -> Bool)
-> ((BlockId, BlockId) -> Int)
-> ((BlockId, BlockId) -> Int)
-> Ix BlockId
(BlockId, BlockId) -> Int
(BlockId, BlockId) -> [BlockId]
(BlockId, BlockId) -> BlockId -> Bool
(BlockId, BlockId) -> BlockId -> Int
forall a.
Ord a
-> ((a, a) -> [a])
-> ((a, a) -> a -> Int)
-> ((a, a) -> a -> Int)
-> ((a, a) -> a -> Bool)
-> ((a, a) -> Int)
-> ((a, a) -> Int)
-> Ix a
$crange :: (BlockId, BlockId) -> [BlockId]
range :: (BlockId, BlockId) -> [BlockId]
$cindex :: (BlockId, BlockId) -> BlockId -> Int
index :: (BlockId, BlockId) -> BlockId -> Int
$cunsafeIndex :: (BlockId, BlockId) -> BlockId -> Int
unsafeIndex :: (BlockId, BlockId) -> BlockId -> Int
$cinRange :: (BlockId, BlockId) -> BlockId -> Bool
inRange :: (BlockId, BlockId) -> BlockId -> Bool
$crangeSize :: (BlockId, BlockId) -> Int
rangeSize :: (BlockId, BlockId) -> Int
$cunsafeRangeSize :: (BlockId, BlockId) -> Int
unsafeRangeSize :: (BlockId, BlockId) -> Int
Ix,Int -> BlockId -> ShowS
[BlockId] -> ShowS
BlockId -> String
(Int -> BlockId -> ShowS)
-> (BlockId -> String) -> ([BlockId] -> ShowS) -> Show BlockId
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BlockId -> ShowS
showsPrec :: Int -> BlockId -> ShowS
$cshow :: BlockId -> String
show :: BlockId -> String
$cshowList :: [BlockId] -> ShowS
showList :: [BlockId] -> ShowS
Show)


data State label =
   State {
      forall label.
State label -> (Array SetId label, UArray (SetId, BlockId) Block)
availableSubsets :: (Array SetId label, UArray (SetId,BlockId) Block),
      forall label. State label -> UArray BlockId Block
freeElements :: UArray BlockId Block,
      forall label. State label -> [label]
usedSubsets :: [label]
   }

initState :: (Ord a) => [ESC.Assign label (Set a)] -> State label
initState :: forall a label. Ord a => [Assign label (Set a)] -> State label
initState [Assign label (Set a)]
assigns =
   let neAssigns :: [Assign label (Set a)]
neAssigns = (Assign label (Set a) -> Bool)
-> [Assign label (Set a)] -> [Assign label (Set a)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> (Assign label (Set a) -> Bool) -> Assign label (Set a) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set a -> Bool
forall a. Set a -> Bool
Set.null (Set a -> Bool)
-> (Assign label (Set a) -> Set a) -> Assign label (Set a) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Assign label (Set a) -> Set a
forall label set. Assign label set -> set
ESC.labeledSet) [Assign label (Set a)]
assigns
       ([[Block]]
avails, [Block]
free) = [Set a] -> ([[Block]], [Block])
forall a block.
(Ord a, Num block, Bits block) =>
[Set a] -> ([[block]], [block])
blocksFromSets ([Set a] -> ([[Block]], [Block]))
-> [Set a] -> ([[Block]], [Block])
forall a b. (a -> b) -> a -> b
$ (Assign label (Set a) -> Set a)
-> [Assign label (Set a)] -> [Set a]
forall a b. (a -> b) -> [a] -> [b]
map Assign label (Set a) -> Set a
forall label set. Assign label set -> set
ESC.labeledSet [Assign label (Set a)]
neAssigns
       firstSet :: SetId
firstSet = Int -> SetId
SetId Int
0; lastSet :: SetId
lastSet = Int -> SetId
SetId (Int -> SetId) -> Int -> SetId
forall a b. (a -> b) -> a -> b
$ [Assign label (Set a)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Assign label (Set a)]
neAssigns Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
       firstBlock :: BlockId
firstBlock = Int -> BlockId
BlockId Int
0; lastBlock :: BlockId
lastBlock = Int -> BlockId
BlockId (Int -> BlockId) -> Int -> BlockId
forall a b. (a -> b) -> a -> b
$ [Block] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Block]
free Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
   in State {
         availableSubsets :: (Array SetId label, UArray (SetId, BlockId) Block)
availableSubsets =
            ((SetId, SetId) -> [label] -> Array SetId label
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
(i, i) -> [e] -> a i e
listArray (SetId
firstSet,SetId
lastSet) ([label] -> Array SetId label) -> [label] -> Array SetId label
forall a b. (a -> b) -> a -> b
$ (Assign label (Set a) -> label)
-> [Assign label (Set a)] -> [label]
forall a b. (a -> b) -> [a] -> [b]
map Assign label (Set a) -> label
forall label set. Assign label set -> label
ESC.label [Assign label (Set a)]
neAssigns,
             ((SetId, BlockId), (SetId, BlockId))
-> [Block] -> UArray (SetId, BlockId) Block
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
(i, i) -> [e] -> a i e
listArray ((SetId
firstSet,BlockId
firstBlock), (SetId
lastSet,BlockId
lastBlock)) ([Block] -> UArray (SetId, BlockId) Block)
-> [Block] -> UArray (SetId, BlockId) Block
forall a b. (a -> b) -> a -> b
$
             ([Block] -> [Block]) -> [[Block]] -> [Block]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([Block] -> [Block] -> [Block]
forall b a. [b] -> [a] -> [a]
Match.take [Block]
free) [[Block]]
avails),
         freeElements :: UArray BlockId Block
freeElements = (BlockId, BlockId) -> [Block] -> UArray BlockId Block
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
(i, i) -> [e] -> a i e
listArray (BlockId
firstBlock,BlockId
lastBlock) [Block]
free,
         usedSubsets :: [label]
usedSubsets = []
      }


type DifferenceWithRow k =
   UArray BlockId Block -> k ->
   UArray (k,BlockId) Block -> UArray BlockId Block

{-# SPECIALISE differenceWithRow :: DifferenceWithRow SetId #-}
{-# SPECIALISE differenceWithRow :: DifferenceWithRow DigitId #-}
differenceWithRow :: (Ix k) => DifferenceWithRow k
differenceWithRow :: forall k. Ix k => DifferenceWithRow k
differenceWithRow UArray BlockId Block
x k
k UArray (k, BlockId) Block
bag =
   (BlockId, BlockId) -> [Block] -> UArray BlockId Block
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
(i, i) -> [e] -> a i e
listArray (UArray BlockId Block -> (BlockId, BlockId)
forall i. Ix i => UArray i Block -> (i, i)
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> (i, i)
bounds UArray BlockId Block
x) ([Block] -> UArray BlockId Block)
-> [Block] -> UArray BlockId Block
forall a b. (a -> b) -> a -> b
$
   (BlockId -> Block) -> [BlockId] -> [Block]
forall a b. (a -> b) -> [a] -> [b]
map (\BlockId
j -> Block -> Block -> Block
forall bits. C bits => bits -> bits -> bits
Bit.difference (UArray BlockId Block
xUArray BlockId Block -> BlockId -> Block
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
!BlockId
j) (UArray (k, BlockId) Block
bagUArray (k, BlockId) Block -> (k, BlockId) -> Block
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
!(k
k,BlockId
j))) ((BlockId, BlockId) -> [BlockId]
forall a. Ix a => (a, a) -> [a]
range ((BlockId, BlockId) -> [BlockId])
-> (BlockId, BlockId) -> [BlockId]
forall a b. (a -> b) -> a -> b
$ UArray BlockId Block -> (BlockId, BlockId)
forall i. Ix i => UArray i Block -> (i, i)
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> (i, i)
bounds UArray BlockId Block
x)


disjoint :: Block -> Block -> Bool
disjoint :: Block -> Block -> Bool
disjoint Block
x Block
y  =  Block
xBlock -> Block -> Block
forall a. Bits a => a -> a -> a
.&.Block
y Block -> Block -> Bool
forall a. Eq a => a -> a -> Bool
== Block
0

disjointRow :: SetId -> SetId -> UArray (SetId, BlockId) Block -> Bool
disjointRow :: SetId -> SetId -> UArray (SetId, BlockId) Block -> Bool
disjointRow SetId
k0 SetId
k1 UArray (SetId, BlockId) Block
sets =
   (BlockId -> Bool) -> [BlockId] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all
      (\BlockId
j -> Block -> Block -> Bool
disjoint (UArray (SetId, BlockId) Block
setsUArray (SetId, BlockId) Block -> (SetId, BlockId) -> Block
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
!(SetId
k0,BlockId
j)) (UArray (SetId, BlockId) Block
setsUArray (SetId, BlockId) Block -> (SetId, BlockId) -> Block
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
!(SetId
k1,BlockId
j)))
      ((BlockId, BlockId) -> [BlockId]
forall a. Ix a => (a, a) -> [a]
range ((BlockId, BlockId) -> [BlockId])
-> (BlockId, BlockId) -> [BlockId]
forall a b. (a -> b) -> a -> b
$ ((SetId, BlockId) -> BlockId, (SetId, BlockId) -> BlockId)
-> ((SetId, BlockId), (SetId, BlockId)) -> (BlockId, BlockId)
forall a c b d. (a -> c, b -> d) -> (a, b) -> (c, d)
mapPair ((SetId, BlockId) -> BlockId
forall a b. (a, b) -> b
snd,(SetId, BlockId) -> BlockId
forall a b. (a, b) -> b
snd) (((SetId, BlockId), (SetId, BlockId)) -> (BlockId, BlockId))
-> ((SetId, BlockId), (SetId, BlockId)) -> (BlockId, BlockId)
forall a b. (a -> b) -> a -> b
$ UArray (SetId, BlockId) Block
-> ((SetId, BlockId), (SetId, BlockId))
forall i. Ix i => UArray i Block -> (i, i)
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> (i, i)
bounds UArray (SetId, BlockId) Block
sets)

filterDisjointRows ::
   SetId ->
   (Array SetId label, UArray (SetId,BlockId) Block) ->
   (Array SetId label, UArray (SetId,BlockId) Block)
filterDisjointRows :: forall label.
SetId
-> (Array SetId label, UArray (SetId, BlockId) Block)
-> (Array SetId label, UArray (SetId, BlockId) Block)
filterDisjointRows SetId
k0 (Array SetId label
labels,UArray (SetId, BlockId) Block
sets) =
   let ((SetId
kl,BlockId
jl), (SetId
ku,BlockId
ju)) = UArray (SetId, BlockId) Block
-> ((SetId, BlockId), (SetId, BlockId))
forall i. Ix i => UArray i Block -> (i, i)
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> (i, i)
bounds UArray (SetId, BlockId) Block
sets
       rows :: [SetId]
rows = (SetId -> Bool) -> [SetId] -> [SetId]
forall a. (a -> Bool) -> [a] -> [a]
filter (\SetId
k1 -> SetId -> SetId -> UArray (SetId, BlockId) Block -> Bool
disjointRow SetId
k0 SetId
k1 UArray (SetId, BlockId) Block
sets) ([SetId] -> [SetId]) -> [SetId] -> [SetId]
forall a b. (a -> b) -> a -> b
$ (SetId, SetId) -> [SetId]
forall a. Ix a => (a, a) -> [a]
range (SetId
kl,SetId
ku)
       firstSet :: SetId
firstSet = Int -> SetId
SetId Int
0; lastSet :: SetId
lastSet = Int -> SetId
SetId (Int -> SetId) -> Int -> SetId
forall a b. (a -> b) -> a -> b
$ [SetId] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [SetId]
rows Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
       rowsArr :: Array SetId SetId
rowsArr = (SetId, SetId) -> [SetId] -> Array SetId SetId
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
(i, i) -> [e] -> a i e
listArray (SetId
firstSet, SetId
lastSet) [SetId]
rows
       bnds :: ((SetId, BlockId), (SetId, BlockId))
bnds = ((SetId
firstSet,BlockId
jl), (SetId
lastSet,BlockId
ju))
   in  ((SetId -> label) -> Array SetId SetId -> Array SetId label
forall (a :: * -> * -> *) e' e i.
(IArray a e', IArray a e, Ix i) =>
(e' -> e) -> a i e' -> a i e
UArray.amap (Array SetId label
labelsArray SetId label -> SetId -> label
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
!) Array SetId SetId
rowsArr,
        ((SetId, BlockId), (SetId, BlockId))
-> [Block] -> UArray (SetId, BlockId) Block
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
(i, i) -> [e] -> a i e
listArray ((SetId, BlockId), (SetId, BlockId))
bnds ([Block] -> UArray (SetId, BlockId) Block)
-> [Block] -> UArray (SetId, BlockId) Block
forall a b. (a -> b) -> a -> b
$ ((SetId, BlockId) -> Block) -> [(SetId, BlockId)] -> [Block]
forall a b. (a -> b) -> [a] -> [b]
map (\(SetId
n,BlockId
j) -> UArray (SetId, BlockId) Block
setsUArray (SetId, BlockId) Block -> (SetId, BlockId) -> Block
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
!(Array SetId SetId
rowsArrArray SetId SetId -> SetId -> SetId
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
!SetId
n,BlockId
j)) ([(SetId, BlockId)] -> [Block]) -> [(SetId, BlockId)] -> [Block]
forall a b. (a -> b) -> a -> b
$ ((SetId, BlockId), (SetId, BlockId)) -> [(SetId, BlockId)]
forall a. Ix a => (a, a) -> [a]
range ((SetId, BlockId), (SetId, BlockId))
bnds)


{-# INLINE updateState #-}
updateState :: SetId -> State label -> State label
updateState :: forall label. SetId -> State label -> State label
updateState SetId
k State label
s =
   State {
      availableSubsets :: (Array SetId label, UArray (SetId, BlockId) Block)
availableSubsets = SetId
-> (Array SetId label, UArray (SetId, BlockId) Block)
-> (Array SetId label, UArray (SetId, BlockId) Block)
forall label.
SetId
-> (Array SetId label, UArray (SetId, BlockId) Block)
-> (Array SetId label, UArray (SetId, BlockId) Block)
filterDisjointRows SetId
k ((Array SetId label, UArray (SetId, BlockId) Block)
 -> (Array SetId label, UArray (SetId, BlockId) Block))
-> (Array SetId label, UArray (SetId, BlockId) Block)
-> (Array SetId label, UArray (SetId, BlockId) Block)
forall a b. (a -> b) -> a -> b
$ State label -> (Array SetId label, UArray (SetId, BlockId) Block)
forall label.
State label -> (Array SetId label, UArray (SetId, BlockId) Block)
availableSubsets State label
s,
      freeElements :: UArray BlockId Block
freeElements =
         DifferenceWithRow SetId
forall k. Ix k => DifferenceWithRow k
differenceWithRow (State label -> UArray BlockId Block
forall label. State label -> UArray BlockId Block
freeElements State label
s) SetId
k (UArray (SetId, BlockId) Block -> UArray BlockId Block)
-> UArray (SetId, BlockId) Block -> UArray BlockId Block
forall a b. (a -> b) -> a -> b
$ (Array SetId label, UArray (SetId, BlockId) Block)
-> UArray (SetId, BlockId) Block
forall a b. (a, b) -> b
snd ((Array SetId label, UArray (SetId, BlockId) Block)
 -> UArray (SetId, BlockId) Block)
-> (Array SetId label, UArray (SetId, BlockId) Block)
-> UArray (SetId, BlockId) Block
forall a b. (a -> b) -> a -> b
$ State label -> (Array SetId label, UArray (SetId, BlockId) Block)
forall label.
State label -> (Array SetId label, UArray (SetId, BlockId) Block)
availableSubsets State label
s,
      usedSubsets :: [label]
usedSubsets = (Array SetId label, UArray (SetId, BlockId) Block)
-> Array SetId label
forall a b. (a, b) -> a
fst (State label -> (Array SetId label, UArray (SetId, BlockId) Block)
forall label.
State label -> (Array SetId label, UArray (SetId, BlockId) Block)
availableSubsets State label
s) Array SetId label -> SetId -> label
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
! SetId
k label -> [label] -> [label]
forall a. a -> [a] -> [a]
: State label -> [label]
forall label. State label -> [label]
usedSubsets State label
s
   }



halfBags :: SetId -> SetId -> (SetId, SetId)
halfBags :: SetId -> SetId -> (SetId, SetId)
halfBags (SetId Int
firstBag) (SetId Int
lastBag) =
   (Int -> SetId
SetId (Int -> SetId) -> Int -> SetId
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int
forall a. Integral a => a -> a -> a
div (Int
lastBagInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
firstBag) Int
2,
    Int -> SetId
SetId (Int -> SetId) -> Int -> SetId
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int
forall a. Integral a => a -> a -> a
div (Int
lastBagInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
firstBagInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Int
2)

double :: SetId -> SetId
double :: SetId -> SetId
double (SetId Int
n) = Int -> SetId
SetId (Int
2Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
n)

add2TransposedST ::
   UArray (SetId, BlockId, DigitId) Block ->
   ST s (STUArray s (SetId, BlockId, DigitId) Block)
add2TransposedST :: forall s.
UArray (SetId, BlockId, DigitId) Block
-> ST s (STUArray s (SetId, BlockId, DigitId) Block)
add2TransposedST UArray (SetId, BlockId, DigitId) Block
xs = do
   let ((SetId
firstBag,BlockId
firstBlock,DigitId
firstDigit), (SetId
lastBag,BlockId
lastBlock,DigitId
lastDigit)) =
         UArray (SetId, BlockId, DigitId) Block
-> ((SetId, BlockId, DigitId), (SetId, BlockId, DigitId))
forall i. Ix i => UArray i Block -> (i, i)
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> (i, i)
UArray.bounds UArray (SetId, BlockId, DigitId) Block
xs
   let newFirstBag :: SetId
newFirstBag = Int -> SetId
SetId Int
0
   let (SetId
newLastBag, SetId
newLastFullBag) = SetId -> SetId -> (SetId, SetId)
halfBags SetId
firstBag SetId
lastBag

   let mostSigNull :: Bool
mostSigNull =
         ((SetId, BlockId) -> Bool) -> [(SetId, BlockId)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\(SetId
n,BlockId
j) -> UArray (SetId, BlockId, DigitId) Block
xsUArray (SetId, BlockId, DigitId) Block
-> (SetId, BlockId, DigitId) -> Block
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
!(SetId
n,BlockId
j,DigitId
lastDigit) Block -> Block -> Bool
forall a. Eq a => a -> a -> Bool
== Block
0) ([(SetId, BlockId)] -> Bool) -> [(SetId, BlockId)] -> Bool
forall a b. (a -> b) -> a -> b
$
         ((SetId, BlockId), (SetId, BlockId)) -> [(SetId, BlockId)]
forall a. Ix a => (a, a) -> [a]
range ((SetId
firstBag,BlockId
firstBlock), (SetId
lastBag,BlockId
lastBlock))
   let newLastDigit :: DigitId
newLastDigit = if Bool
mostSigNull then DigitId
lastDigit else DigitId -> DigitId
forall a. Enum a => a -> a
succ DigitId
lastDigit

   STUArray s (SetId, BlockId, DigitId) Block
ys <- ((SetId, BlockId, DigitId), (SetId, BlockId, DigitId))
-> ST s (STUArray s (SetId, BlockId, DigitId) Block)
forall i. Ix i => (i, i) -> ST s (STUArray s i Block)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> m (a i e)
STUArray.newArray_
            ((SetId
newFirstBag, BlockId
firstBlock, DigitId
firstDigit),
             (SetId
newLastBag, BlockId
lastBlock, DigitId
newLastDigit))
   [SetId] -> (SetId -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ((SetId, SetId) -> [SetId]
forall a. Ix a => (a, a) -> [a]
range (SetId
newFirstBag,SetId
newLastFullBag)) ((SetId -> ST s ()) -> ST s ()) -> (SetId -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \SetId
n ->
      [BlockId] -> (BlockId -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ((BlockId, BlockId) -> [BlockId]
forall a. Ix a => (a, a) -> [a]
range (BlockId
firstBlock,BlockId
lastBlock)) ((BlockId -> ST s ()) -> ST s ())
-> (BlockId -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \BlockId
j ->
         STUArray s (SetId, BlockId, DigitId) Block
-> (SetId, BlockId, DigitId) -> Block -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STUArray s (SetId, BlockId, DigitId) Block
ys (SetId
n,BlockId
j,DigitId
newLastDigit) (Block -> ST s ()) -> ST s Block -> ST s ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
            (Block -> DigitId -> ST s Block)
-> Block -> [DigitId] -> ST s Block
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM
               (\Block
carry DigitId
k -> do
                  let a :: Block
a = UArray (SetId, BlockId, DigitId) Block
xs UArray (SetId, BlockId, DigitId) Block
-> (SetId, BlockId, DigitId) -> Block
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
! (SetId -> SetId
double SetId
n, BlockId
j, DigitId
k)
                  let b :: Block
b = UArray (SetId, BlockId, DigitId) Block
xs UArray (SetId, BlockId, DigitId) Block
-> (SetId, BlockId, DigitId) -> Block
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
! (SetId -> SetId
forall a. Enum a => a -> a
succ (SetId -> SetId) -> SetId -> SetId
forall a b. (a -> b) -> a -> b
$ SetId -> SetId
double SetId
n, BlockId
j, DigitId
k)
                  STUArray s (SetId, BlockId, DigitId) Block
-> (SetId, BlockId, DigitId) -> Block -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STUArray s (SetId, BlockId, DigitId) Block
ys (SetId
n,BlockId
j,DigitId
k) (Block -> ST s ()) -> Block -> ST s ()
forall a b. (a -> b) -> a -> b
$ Block -> Block -> Block
forall a. Bits a => a -> a -> a
xor Block
carry (Block -> Block -> Block
forall a. Bits a => a -> a -> a
xor Block
a Block
b)
                  Block -> ST s Block
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return (Block -> ST s Block) -> Block -> ST s Block
forall a b. (a -> b) -> a -> b
$ Block
carryBlock -> Block -> Block
forall a. Bits a => a -> a -> a
.&.(Block
aBlock -> Block -> Block
forall a. Bits a => a -> a -> a
.|.Block
b) Block -> Block -> Block
forall a. Bits a => a -> a -> a
.|. Block
aBlock -> Block -> Block
forall a. Bits a => a -> a -> a
.&.Block
b)
               Block
0 ((DigitId, DigitId) -> [DigitId]
forall a. Ix a => (a, a) -> [a]
range (DigitId
firstDigit, DigitId -> DigitId
forall a. Enum a => a -> a
pred DigitId
newLastDigit))
   Bool -> ST s () -> ST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SetId
newLastFullBagSetId -> SetId -> Bool
forall a. Ord a => a -> a -> Bool
<SetId
newLastBag) (ST s () -> ST s ()) -> ST s () -> ST s ()
forall a b. (a -> b) -> a -> b
$ do
      let n :: SetId
n = SetId
newLastBag
      [BlockId] -> (BlockId -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ((BlockId, BlockId) -> [BlockId]
forall a. Ix a => (a, a) -> [a]
range (BlockId
firstBlock,BlockId
lastBlock)) ((BlockId -> ST s ()) -> ST s ())
-> (BlockId -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \BlockId
j -> do
         [DigitId] -> (DigitId -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ((DigitId, DigitId) -> [DigitId]
forall a. Ix a => (a, a) -> [a]
range (DigitId
firstDigit, DigitId -> DigitId
forall a. Enum a => a -> a
pred DigitId
newLastDigit)) ((DigitId -> ST s ()) -> ST s ())
-> (DigitId -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \DigitId
k ->
            STUArray s (SetId, BlockId, DigitId) Block
-> (SetId, BlockId, DigitId) -> Block -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STUArray s (SetId, BlockId, DigitId) Block
ys (SetId
n,BlockId
j,DigitId
k) (Block -> ST s ()) -> Block -> ST s ()
forall a b. (a -> b) -> a -> b
$ UArray (SetId, BlockId, DigitId) Block
xsUArray (SetId, BlockId, DigitId) Block
-> (SetId, BlockId, DigitId) -> Block
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
!(SetId -> SetId
double SetId
n,BlockId
j,DigitId
k)
         STUArray s (SetId, BlockId, DigitId) Block
-> (SetId, BlockId, DigitId) -> Block -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STUArray s (SetId, BlockId, DigitId) Block
ys (SetId
n,BlockId
j,DigitId
newLastDigit) Block
0
   STUArray s (SetId, BlockId, DigitId) Block
-> ST s (STUArray s (SetId, BlockId, DigitId) Block)
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return STUArray s (SetId, BlockId, DigitId) Block
ys

add2ST ::
   UArray (SetId, DigitId, BlockId) Block ->
   ST s (STUArray s (SetId, DigitId, BlockId) Block)
add2ST :: forall s.
UArray (SetId, DigitId, BlockId) Block
-> ST s (STUArray s (SetId, DigitId, BlockId) Block)
add2ST UArray (SetId, DigitId, BlockId) Block
xs = do
   let ((SetId
firstBag,DigitId
firstDigit,BlockId
firstBlock), (SetId
lastBag,DigitId
lastDigit,BlockId
lastBlock)) =
         UArray (SetId, DigitId, BlockId) Block
-> ((SetId, DigitId, BlockId), (SetId, DigitId, BlockId))
forall i. Ix i => UArray i Block -> (i, i)
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> (i, i)
UArray.bounds UArray (SetId, DigitId, BlockId) Block
xs
   let newFirstBag :: SetId
newFirstBag = Int -> SetId
SetId Int
0
   let (SetId
newLastBag, SetId
newLastFullBag) = SetId -> SetId -> (SetId, SetId)
halfBags SetId
firstBag SetId
lastBag

   let mostSigNull :: Bool
mostSigNull =
         ((SetId, BlockId) -> Bool) -> [(SetId, BlockId)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\(SetId
n,BlockId
j) -> UArray (SetId, DigitId, BlockId) Block
xsUArray (SetId, DigitId, BlockId) Block
-> (SetId, DigitId, BlockId) -> Block
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
!(SetId
n,DigitId
lastDigit,BlockId
j) Block -> Block -> Bool
forall a. Eq a => a -> a -> Bool
== Block
0) ([(SetId, BlockId)] -> Bool) -> [(SetId, BlockId)] -> Bool
forall a b. (a -> b) -> a -> b
$
         ((SetId, BlockId), (SetId, BlockId)) -> [(SetId, BlockId)]
forall a. Ix a => (a, a) -> [a]
range ((SetId
firstBag,BlockId
firstBlock), (SetId
lastBag,BlockId
lastBlock))
   let newLastDigit :: DigitId
newLastDigit = if Bool
mostSigNull then DigitId
lastDigit else DigitId -> DigitId
forall a. Enum a => a -> a
succ DigitId
lastDigit

   STUArray s (SetId, DigitId, BlockId) Block
ys <- ((SetId, DigitId, BlockId), (SetId, DigitId, BlockId))
-> ST s (STUArray s (SetId, DigitId, BlockId) Block)
forall i. Ix i => (i, i) -> ST s (STUArray s i Block)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> m (a i e)
STUArray.newArray_
            ((SetId
newFirstBag, DigitId
firstDigit, BlockId
firstBlock),
             (SetId
newLastBag, DigitId
newLastDigit, BlockId
lastBlock))
   [SetId] -> (SetId -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ((SetId, SetId) -> [SetId]
forall a. Ix a => (a, a) -> [a]
range (SetId
newFirstBag,SetId
newLastFullBag)) ((SetId -> ST s ()) -> ST s ()) -> (SetId -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \SetId
n ->
      [BlockId] -> (BlockId -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ((BlockId, BlockId) -> [BlockId]
forall a. Ix a => (a, a) -> [a]
range (BlockId
firstBlock,BlockId
lastBlock)) ((BlockId -> ST s ()) -> ST s ())
-> (BlockId -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \BlockId
j ->
         STUArray s (SetId, DigitId, BlockId) Block
-> (SetId, DigitId, BlockId) -> Block -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STUArray s (SetId, DigitId, BlockId) Block
ys (SetId
n,DigitId
newLastDigit,BlockId
j) (Block -> ST s ()) -> ST s Block -> ST s ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
            (Block -> DigitId -> ST s Block)
-> Block -> [DigitId] -> ST s Block
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM
               (\Block
carry DigitId
k -> do
                  let a :: Block
a = UArray (SetId, DigitId, BlockId) Block
xs UArray (SetId, DigitId, BlockId) Block
-> (SetId, DigitId, BlockId) -> Block
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
! (SetId -> SetId
double SetId
n, DigitId
k, BlockId
j)
                  let b :: Block
b = UArray (SetId, DigitId, BlockId) Block
xs UArray (SetId, DigitId, BlockId) Block
-> (SetId, DigitId, BlockId) -> Block
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
! (SetId -> SetId
forall a. Enum a => a -> a
succ (SetId -> SetId) -> SetId -> SetId
forall a b. (a -> b) -> a -> b
$ SetId -> SetId
double SetId
n, DigitId
k, BlockId
j)
                  STUArray s (SetId, DigitId, BlockId) Block
-> (SetId, DigitId, BlockId) -> Block -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STUArray s (SetId, DigitId, BlockId) Block
ys (SetId
n,DigitId
k,BlockId
j) (Block -> ST s ()) -> Block -> ST s ()
forall a b. (a -> b) -> a -> b
$ Block -> Block -> Block
forall a. Bits a => a -> a -> a
xor Block
carry (Block -> Block -> Block
forall a. Bits a => a -> a -> a
xor Block
a Block
b)
                  Block -> ST s Block
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return (Block -> ST s Block) -> Block -> ST s Block
forall a b. (a -> b) -> a -> b
$ Block
carryBlock -> Block -> Block
forall a. Bits a => a -> a -> a
.&.(Block
aBlock -> Block -> Block
forall a. Bits a => a -> a -> a
.|.Block
b) Block -> Block -> Block
forall a. Bits a => a -> a -> a
.|. Block
aBlock -> Block -> Block
forall a. Bits a => a -> a -> a
.&.Block
b)
               Block
0 ((DigitId, DigitId) -> [DigitId]
forall a. Ix a => (a, a) -> [a]
range (DigitId
firstDigit, DigitId -> DigitId
forall a. Enum a => a -> a
pred DigitId
newLastDigit))
   Bool -> ST s () -> ST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SetId
newLastFullBagSetId -> SetId -> Bool
forall a. Ord a => a -> a -> Bool
<SetId
newLastBag) (ST s () -> ST s ()) -> ST s () -> ST s ()
forall a b. (a -> b) -> a -> b
$ do
      let n :: SetId
n = SetId
newLastBag
      [BlockId] -> (BlockId -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ((BlockId, BlockId) -> [BlockId]
forall a. Ix a => (a, a) -> [a]
range (BlockId
firstBlock,BlockId
lastBlock)) ((BlockId -> ST s ()) -> ST s ())
-> (BlockId -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \BlockId
j -> do
         [DigitId] -> (DigitId -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ((DigitId, DigitId) -> [DigitId]
forall a. Ix a => (a, a) -> [a]
range (DigitId
firstDigit,DigitId -> DigitId
forall a. Enum a => a -> a
pred DigitId
newLastDigit)) ((DigitId -> ST s ()) -> ST s ())
-> (DigitId -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \DigitId
k ->
            STUArray s (SetId, DigitId, BlockId) Block
-> (SetId, DigitId, BlockId) -> Block -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STUArray s (SetId, DigitId, BlockId) Block
ys (SetId
n,DigitId
k,BlockId
j) (Block -> ST s ()) -> Block -> ST s ()
forall a b. (a -> b) -> a -> b
$ UArray (SetId, DigitId, BlockId) Block
xsUArray (SetId, DigitId, BlockId) Block
-> (SetId, DigitId, BlockId) -> Block
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
!(SetId -> SetId
double SetId
n,DigitId
k,BlockId
j)
         STUArray s (SetId, DigitId, BlockId) Block
-> (SetId, DigitId, BlockId) -> Block -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STUArray s (SetId, DigitId, BlockId) Block
ys (SetId
n,DigitId
newLastDigit,BlockId
j) Block
0
   STUArray s (SetId, DigitId, BlockId) Block
-> ST s (STUArray s (SetId, DigitId, BlockId) Block)
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return STUArray s (SetId, DigitId, BlockId) Block
ys

add2 ::
   UArray (SetId, DigitId, BlockId) Block ->
   UArray (SetId, DigitId, BlockId) Block
add2 :: UArray (SetId, DigitId, BlockId) Block
-> UArray (SetId, DigitId, BlockId) Block
add2 UArray (SetId, DigitId, BlockId) Block
xs = (forall s. ST s (STUArray s (SetId, DigitId, BlockId) Block))
-> UArray (SetId, DigitId, BlockId) Block
forall i e. (forall s. ST s (STUArray s i e)) -> UArray i e
runSTUArray (UArray (SetId, DigitId, BlockId) Block
-> ST s (STUArray s (SetId, DigitId, BlockId) Block)
forall s.
UArray (SetId, DigitId, BlockId) Block
-> ST s (STUArray s (SetId, DigitId, BlockId) Block)
add2ST UArray (SetId, DigitId, BlockId) Block
xs)

sumBags :: UArray (SetId,BlockId) Block -> UArray (DigitId,BlockId) Block
sumBags :: UArray (SetId, BlockId) Block -> UArray (DigitId, BlockId) Block
sumBags UArray (SetId, BlockId) Block
arr =
   let go :: UArray (SetId, DigitId, BlockId) Block
-> UArray (DigitId, BlockId) Block
go UArray (SetId, DigitId, BlockId) Block
xs =
         if ((SetId, SetId) -> Int
forall a. Ix a => (a, a) -> Int
UArray.rangeSize ((SetId, SetId) -> Int) -> (SetId, SetId) -> Int
forall a b. (a -> b) -> a -> b
$ ((SetId, DigitId, BlockId) -> SetId,
 (SetId, DigitId, BlockId) -> SetId)
-> ((SetId, DigitId, BlockId), (SetId, DigitId, BlockId))
-> (SetId, SetId)
forall a c b d. (a -> c, b -> d) -> (a, b) -> (c, d)
mapPair ((SetId, DigitId, BlockId) -> SetId
forall a b c. (a, b, c) -> a
fst3,(SetId, DigitId, BlockId) -> SetId
forall a b c. (a, b, c) -> a
fst3) (((SetId, DigitId, BlockId), (SetId, DigitId, BlockId))
 -> (SetId, SetId))
-> ((SetId, DigitId, BlockId), (SetId, DigitId, BlockId))
-> (SetId, SetId)
forall a b. (a -> b) -> a -> b
$ UArray (SetId, DigitId, BlockId) Block
-> ((SetId, DigitId, BlockId), (SetId, DigitId, BlockId))
forall i. Ix i => UArray i Block -> (i, i)
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> (i, i)
bounds UArray (SetId, DigitId, BlockId) Block
xs) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1
           then UArray (SetId, DigitId, BlockId) Block
-> UArray (DigitId, BlockId) Block
go (UArray (SetId, DigitId, BlockId) Block
 -> UArray (DigitId, BlockId) Block)
-> UArray (SetId, DigitId, BlockId) Block
-> UArray (DigitId, BlockId) Block
forall a b. (a -> b) -> a -> b
$ UArray (SetId, DigitId, BlockId) Block
-> UArray (SetId, DigitId, BlockId) Block
add2 UArray (SetId, DigitId, BlockId) Block
xs
           else ((DigitId, BlockId), (DigitId, BlockId))
-> ((DigitId, BlockId) -> (SetId, DigitId, BlockId))
-> UArray (SetId, DigitId, BlockId) Block
-> UArray (DigitId, BlockId) Block
forall (a :: * -> * -> *) e i j.
(IArray a e, Ix i, Ix j) =>
(i, i) -> (i -> j) -> a j e -> a i e
UArray.ixmap
                  (case UArray (SetId, DigitId, BlockId) Block
-> ((SetId, DigitId, BlockId), (SetId, DigitId, BlockId))
forall i. Ix i => UArray i Block -> (i, i)
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> (i, i)
bounds UArray (SetId, DigitId, BlockId) Block
xs of
                     ((SetId
_,DigitId
kl,BlockId
jl), (SetId
_,DigitId
ku,BlockId
ju)) -> ((DigitId
kl,BlockId
jl), (DigitId
ku,BlockId
ju)))
                  (\(DigitId
k,BlockId
j) -> (Int -> SetId
SetId Int
0, DigitId
k, BlockId
j)) UArray (SetId, DigitId, BlockId) Block
xs
   in  UArray (SetId, DigitId, BlockId) Block
-> UArray (DigitId, BlockId) Block
go (UArray (SetId, DigitId, BlockId) Block
 -> UArray (DigitId, BlockId) Block)
-> UArray (SetId, DigitId, BlockId) Block
-> UArray (DigitId, BlockId) Block
forall a b. (a -> b) -> a -> b
$
       ((SetId, DigitId, BlockId), (SetId, DigitId, BlockId))
-> ((SetId, DigitId, BlockId) -> (SetId, BlockId))
-> UArray (SetId, BlockId) Block
-> UArray (SetId, DigitId, BlockId) Block
forall (a :: * -> * -> *) e i j.
(IArray a e, Ix i, Ix j) =>
(i, i) -> (i -> j) -> a j e -> a i e
UArray.ixmap
         (case UArray (SetId, BlockId) Block
-> ((SetId, BlockId), (SetId, BlockId))
forall i. Ix i => UArray i Block -> (i, i)
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> (i, i)
bounds UArray (SetId, BlockId) Block
arr of
            ((SetId
nl,BlockId
jl), (SetId
nu,BlockId
ju)) -> ((SetId
nl, Int -> DigitId
DigitId Int
0, BlockId
jl), (SetId
nu, Int -> DigitId
DigitId Int
0, BlockId
ju)))
         (\(SetId
n,DigitId
_,BlockId
j) -> (SetId
n,BlockId
j)) UArray (SetId, BlockId) Block
arr

_sumBagsTransposed ::
   UArray (SetId,BlockId) Block -> UArray (DigitId,BlockId) Block
_sumBagsTransposed :: UArray (SetId, BlockId) Block -> UArray (DigitId, BlockId) Block
_sumBagsTransposed UArray (SetId, BlockId) Block
arr =
   let go :: UArray (SetId, BlockId, DigitId) Block
-> UArray (DigitId, BlockId) Block
go UArray (SetId, BlockId, DigitId) Block
xs =
         if ((SetId, SetId) -> Int
forall a. Ix a => (a, a) -> Int
UArray.rangeSize ((SetId, SetId) -> Int) -> (SetId, SetId) -> Int
forall a b. (a -> b) -> a -> b
$ ((SetId, BlockId, DigitId) -> SetId,
 (SetId, BlockId, DigitId) -> SetId)
-> ((SetId, BlockId, DigitId), (SetId, BlockId, DigitId))
-> (SetId, SetId)
forall a c b d. (a -> c, b -> d) -> (a, b) -> (c, d)
mapPair ((SetId, BlockId, DigitId) -> SetId
forall a b c. (a, b, c) -> a
fst3,(SetId, BlockId, DigitId) -> SetId
forall a b c. (a, b, c) -> a
fst3) (((SetId, BlockId, DigitId), (SetId, BlockId, DigitId))
 -> (SetId, SetId))
-> ((SetId, BlockId, DigitId), (SetId, BlockId, DigitId))
-> (SetId, SetId)
forall a b. (a -> b) -> a -> b
$ UArray (SetId, BlockId, DigitId) Block
-> ((SetId, BlockId, DigitId), (SetId, BlockId, DigitId))
forall i. Ix i => UArray i Block -> (i, i)
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> (i, i)
bounds UArray (SetId, BlockId, DigitId) Block
xs) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1
           then UArray (SetId, BlockId, DigitId) Block
-> UArray (DigitId, BlockId) Block
go (UArray (SetId, BlockId, DigitId) Block
 -> UArray (DigitId, BlockId) Block)
-> UArray (SetId, BlockId, DigitId) Block
-> UArray (DigitId, BlockId) Block
forall a b. (a -> b) -> a -> b
$ (forall s. ST s (STUArray s (SetId, BlockId, DigitId) Block))
-> UArray (SetId, BlockId, DigitId) Block
forall i e. (forall s. ST s (STUArray s i e)) -> UArray i e
runSTUArray (UArray (SetId, BlockId, DigitId) Block
-> ST s (STUArray s (SetId, BlockId, DigitId) Block)
forall s.
UArray (SetId, BlockId, DigitId) Block
-> ST s (STUArray s (SetId, BlockId, DigitId) Block)
add2TransposedST UArray (SetId, BlockId, DigitId) Block
xs)
           else ((DigitId, BlockId), (DigitId, BlockId))
-> ((DigitId, BlockId) -> (SetId, BlockId, DigitId))
-> UArray (SetId, BlockId, DigitId) Block
-> UArray (DigitId, BlockId) Block
forall (a :: * -> * -> *) e i j.
(IArray a e, Ix i, Ix j) =>
(i, i) -> (i -> j) -> a j e -> a i e
UArray.ixmap
                  (case UArray (SetId, BlockId, DigitId) Block
-> ((SetId, BlockId, DigitId), (SetId, BlockId, DigitId))
forall i. Ix i => UArray i Block -> (i, i)
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> (i, i)
bounds UArray (SetId, BlockId, DigitId) Block
xs of
                     ((SetId
_,BlockId
jl,DigitId
kl), (SetId
_,BlockId
ju,DigitId
ku)) -> ((DigitId
kl,BlockId
jl), (DigitId
ku,BlockId
ju)))
                  (\(DigitId
k,BlockId
j) -> (Int -> SetId
SetId Int
0, BlockId
j, DigitId
k)) UArray (SetId, BlockId, DigitId) Block
xs
   in  UArray (SetId, BlockId, DigitId) Block
-> UArray (DigitId, BlockId) Block
go (UArray (SetId, BlockId, DigitId) Block
 -> UArray (DigitId, BlockId) Block)
-> UArray (SetId, BlockId, DigitId) Block
-> UArray (DigitId, BlockId) Block
forall a b. (a -> b) -> a -> b
$
       ((SetId, BlockId, DigitId), (SetId, BlockId, DigitId))
-> ((SetId, BlockId, DigitId) -> (SetId, BlockId))
-> UArray (SetId, BlockId) Block
-> UArray (SetId, BlockId, DigitId) Block
forall (a :: * -> * -> *) e i j.
(IArray a e, Ix i, Ix j) =>
(i, i) -> (i -> j) -> a j e -> a i e
UArray.ixmap
         (case UArray (SetId, BlockId) Block
-> ((SetId, BlockId), (SetId, BlockId))
forall i. Ix i => UArray i Block -> (i, i)
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> (i, i)
bounds UArray (SetId, BlockId) Block
arr of
            ((SetId
nl,BlockId
jl), (SetId
nu,BlockId
ju)) -> ((SetId
nl, BlockId
jl, Int -> DigitId
DigitId Int
0), (SetId
nu, BlockId
ju, Int -> DigitId
DigitId Int
0)))
         (\(SetId
n,BlockId
j,DigitId
_) -> (SetId
n,BlockId
j)) UArray (SetId, BlockId) Block
arr


nullSet :: UArray BlockId Block -> Bool
nullSet :: UArray BlockId Block -> Bool
nullSet = (Block -> Bool) -> [Block] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Block
0Block -> Block -> Bool
forall a. Eq a => a -> a -> Bool
==) ([Block] -> Bool)
-> (UArray BlockId Block -> [Block])
-> UArray BlockId Block
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UArray BlockId Block -> [Block]
forall (a :: * -> * -> *) e i. (IArray a e, Ix i) => a i e -> [e]
UArray.elems

minimumSet ::
   UArray BlockId Block ->
   UArray (DigitId, BlockId) Block -> UArray BlockId Block
minimumSet :: UArray BlockId Block
-> UArray (DigitId, BlockId) Block -> UArray BlockId Block
minimumSet UArray BlockId Block
baseSet UArray (DigitId, BlockId) Block
bag =
   (DigitId -> UArray BlockId Block -> UArray BlockId Block)
-> UArray BlockId Block -> [DigitId] -> UArray BlockId Block
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
      (\DigitId
k UArray BlockId Block
mins ->
         case DifferenceWithRow DigitId
forall k. Ix k => DifferenceWithRow k
differenceWithRow UArray BlockId Block
mins DigitId
k UArray (DigitId, BlockId) Block
bag of
            UArray BlockId Block
newMins -> if UArray BlockId Block -> Bool
nullSet UArray BlockId Block
newMins then UArray BlockId Block
mins else UArray BlockId Block
newMins)
      UArray BlockId Block
baseSet
      ((DigitId, DigitId) -> [DigitId]
forall a. Ix a => (a, a) -> [a]
range ((DigitId, DigitId) -> [DigitId])
-> (DigitId, DigitId) -> [DigitId]
forall a b. (a -> b) -> a -> b
$ ((DigitId, BlockId) -> DigitId, (DigitId, BlockId) -> DigitId)
-> ((DigitId, BlockId), (DigitId, BlockId)) -> (DigitId, DigitId)
forall a c b d. (a -> c, b -> d) -> (a, b) -> (c, d)
mapPair ((DigitId, BlockId) -> DigitId
forall a b. (a, b) -> a
fst,(DigitId, BlockId) -> DigitId
forall a b. (a, b) -> a
fst) (((DigitId, BlockId), (DigitId, BlockId)) -> (DigitId, DigitId))
-> ((DigitId, BlockId), (DigitId, BlockId)) -> (DigitId, DigitId)
forall a b. (a -> b) -> a -> b
$ UArray (DigitId, BlockId) Block
-> ((DigitId, BlockId), (DigitId, BlockId))
forall i. Ix i => UArray i Block -> (i, i)
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> (i, i)
bounds UArray (DigitId, BlockId) Block
bag)

keepMinimum :: UArray BlockId Block -> (BlockId,Block)
keepMinimum :: UArray BlockId Block -> (BlockId, Block)
keepMinimum =
   (Block -> Block) -> (BlockId, Block) -> (BlockId, Block)
forall b c a. (b -> c) -> (a, b) -> (a, c)
mapSnd Block -> Block
forall bits. C bits => bits -> bits
Bit.keepMinimum ((BlockId, Block) -> (BlockId, Block))
-> (UArray BlockId Block -> (BlockId, Block))
-> UArray BlockId Block
-> (BlockId, Block)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(BlockId, Block)] -> (BlockId, Block)
forall a. HasCallStack => [a] -> a
head ([(BlockId, Block)] -> (BlockId, Block))
-> (UArray BlockId Block -> [(BlockId, Block)])
-> UArray BlockId Block
-> (BlockId, Block)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((BlockId, Block) -> Bool)
-> [(BlockId, Block)] -> [(BlockId, Block)]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile ((Block
0Block -> Block -> Bool
forall a. Eq a => a -> a -> Bool
==) (Block -> Bool)
-> ((BlockId, Block) -> Block) -> (BlockId, Block) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (BlockId, Block) -> Block
forall a b. (a, b) -> b
snd) ([(BlockId, Block)] -> [(BlockId, Block)])
-> (UArray BlockId Block -> [(BlockId, Block)])
-> UArray BlockId Block
-> [(BlockId, Block)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UArray BlockId Block -> [(BlockId, Block)]
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> [(i, e)]
UArray.assocs

affectedRows :: (Ix n) => UArray (n,BlockId) Block -> (BlockId,Block) -> [n]
affectedRows :: forall n.
Ix n =>
UArray (n, BlockId) Block -> (BlockId, Block) -> [n]
affectedRows UArray (n, BlockId) Block
arr (BlockId
j,Block
bit) =
   (n -> Bool) -> [n] -> [n]
forall a. (a -> Bool) -> [a] -> [a]
filter (\n
n -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Block -> Block -> Bool
disjoint Block
bit (Block -> Bool) -> Block -> Bool
forall a b. (a -> b) -> a -> b
$ UArray (n, BlockId) Block
arrUArray (n, BlockId) Block -> (n, BlockId) -> Block
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
!(n
n,BlockId
j)) ([n] -> [n]) -> [n] -> [n]
forall a b. (a -> b) -> a -> b
$
   (n, n) -> [n]
forall a. Ix a => (a, a) -> [a]
range ((n, n) -> [n]) -> (n, n) -> [n]
forall a b. (a -> b) -> a -> b
$ ((n, BlockId) -> n, (n, BlockId) -> n)
-> ((n, BlockId), (n, BlockId)) -> (n, n)
forall a c b d. (a -> c, b -> d) -> (a, b) -> (c, d)
mapPair ((n, BlockId) -> n
forall a b. (a, b) -> a
fst,(n, BlockId) -> n
forall a b. (a, b) -> a
fst) (((n, BlockId), (n, BlockId)) -> (n, n))
-> ((n, BlockId), (n, BlockId)) -> (n, n)
forall a b. (a -> b) -> a -> b
$ UArray (n, BlockId) Block -> ((n, BlockId), (n, BlockId))
forall i. Ix i => UArray i Block -> (i, i)
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> (i, i)
bounds UArray (n, BlockId) Block
arr

minimize :: UArray BlockId Block -> UArray (SetId,BlockId) Block -> [SetId]
minimize :: UArray BlockId Block -> UArray (SetId, BlockId) Block -> [SetId]
minimize UArray BlockId Block
free UArray (SetId, BlockId) Block
arr =
   UArray (SetId, BlockId) Block -> (BlockId, Block) -> [SetId]
forall n.
Ix n =>
UArray (n, BlockId) Block -> (BlockId, Block) -> [n]
affectedRows UArray (SetId, BlockId) Block
arr ((BlockId, Block) -> [SetId])
-> (UArray (DigitId, BlockId) Block -> (BlockId, Block))
-> UArray (DigitId, BlockId) Block
-> [SetId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UArray BlockId Block -> (BlockId, Block)
keepMinimum (UArray BlockId Block -> (BlockId, Block))
-> (UArray (DigitId, BlockId) Block -> UArray BlockId Block)
-> UArray (DigitId, BlockId) Block
-> (BlockId, Block)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UArray BlockId Block
-> UArray (DigitId, BlockId) Block -> UArray BlockId Block
minimumSet UArray BlockId Block
free (UArray (DigitId, BlockId) Block -> [SetId])
-> UArray (DigitId, BlockId) Block -> [SetId]
forall a b. (a -> b) -> a -> b
$ UArray (SetId, BlockId) Block -> UArray (DigitId, BlockId) Block
sumBags UArray (SetId, BlockId) Block
arr

step :: State label -> [State label]
step :: forall label. State label -> [State label]
step State label
s =
   (SetId -> State label) -> [SetId] -> [State label]
forall a b. (a -> b) -> [a] -> [b]
map ((SetId -> State label -> State label)
-> State label -> SetId -> State label
forall a b c. (a -> b -> c) -> b -> a -> c
flip SetId -> State label -> State label
forall label. SetId -> State label -> State label
updateState State label
s) ([SetId] -> [State label]) -> [SetId] -> [State label]
forall a b. (a -> b) -> a -> b
$
   UArray BlockId Block -> UArray (SetId, BlockId) Block -> [SetId]
minimize (State label -> UArray BlockId Block
forall label. State label -> UArray BlockId Block
freeElements State label
s) ((Array SetId label, UArray (SetId, BlockId) Block)
-> UArray (SetId, BlockId) Block
forall a b. (a, b) -> b
snd ((Array SetId label, UArray (SetId, BlockId) Block)
 -> UArray (SetId, BlockId) Block)
-> (Array SetId label, UArray (SetId, BlockId) Block)
-> UArray (SetId, BlockId) Block
forall a b. (a -> b) -> a -> b
$ State label -> (Array SetId label, UArray (SetId, BlockId) Block)
forall label.
State label -> (Array SetId label, UArray (SetId, BlockId) Block)
availableSubsets State label
s)

search :: State label -> [[label]]
search :: forall label. State label -> [[label]]
search State label
s =
   if UArray BlockId Block -> Bool
nullSet (State label -> UArray BlockId Block
forall label. State label -> UArray BlockId Block
freeElements State label
s)
     then [State label -> [label]
forall label. State label -> [label]
usedSubsets State label
s]
     else State label -> [[label]]
forall label. State label -> [[label]]
search (State label -> [[label]]) -> [State label] -> [[label]]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< State label -> [State label]
forall label. State label -> [State label]
step State label
s

partitions :: (Ord a) => [ESC.Assign label (Set a)] -> [[label]]
partitions :: forall a label. Ord a => [Assign label (Set a)] -> [[label]]
partitions = State label -> [[label]]
forall label. State label -> [[label]]
search (State label -> [[label]])
-> ([Assign label (Set a)] -> State label)
-> [Assign label (Set a)]
-> [[label]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Assign label (Set a)] -> State label
forall a label. Ord a => [Assign label (Set a)] -> State label
initState