module Math.SetCover.BitMap (
   Map(..),
   fromSet,
   add, inc,
   sub, dec,
   intersectionSet,
   differenceSet,
   minimumSet,
   ) where

import qualified Math.SetCover.BitSet as BitSet
import qualified Math.SetCover.Bit as Bit
import Math.SetCover.BitSet (Set(Set))
import Math.SetCover.Bit (difference, xor, (.|.), (.&.))

import qualified Data.List.Reverse.StrictSpine as ListRev
import qualified Data.List as List
import Data.Monoid (Monoid, mempty, mappend)
import Data.Semigroup (Semigroup, (<>))
import Data.Tuple.HT (mapSnd, swap)


{-
Sliced representation of Map [0..bitSize-1] Integer.
-}
newtype Map bits = Map {forall bits. Map bits -> [bits]
unMap :: [bits]} deriving (Int -> Map bits -> ShowS
[Map bits] -> ShowS
Map bits -> String
(Int -> Map bits -> ShowS)
-> (Map bits -> String) -> ([Map bits] -> ShowS) -> Show (Map bits)
forall bits. Show bits => Int -> Map bits -> ShowS
forall bits. Show bits => [Map bits] -> ShowS
forall bits. Show bits => Map bits -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall bits. Show bits => Int -> Map bits -> ShowS
showsPrec :: Int -> Map bits -> ShowS
$cshow :: forall bits. Show bits => Map bits -> String
show :: Map bits -> String
$cshowList :: forall bits. Show bits => [Map bits] -> ShowS
showList :: [Map bits] -> ShowS
Show)

instance (Bit.C bits) => Semigroup (Map bits) where
   <> :: Map bits -> Map bits -> Map bits
(<>) = Map bits -> Map bits -> Map bits
forall bits. C bits => Map bits -> Map bits -> Map bits
add

instance (Bit.C bits) => Monoid (Map bits) where
   mempty :: Map bits
mempty = [bits] -> Map bits
forall bits. [bits] -> Map bits
Map []
   mappend :: Map bits -> Map bits -> Map bits
mappend = Map bits -> Map bits -> Map bits
forall bits. C bits => Map bits -> Map bits -> Map bits
add


fromSet :: Bit.C bits => Set bits -> Map bits
fromSet :: forall bits. C bits => Set bits -> Map bits
fromSet (Set bits
x) = [bits] -> Map bits
forall bits. [bits] -> Map bits
Map [bits
x]

add :: Bit.C bits => Map bits -> Map bits -> Map bits
add :: forall bits. C bits => Map bits -> Map bits -> Map bits
add (Map [bits]
xs0) (Map [bits]
ys0) =
   let go :: t -> [t] -> [t] -> [t]
go t
c [t]
xs [] = Map t -> [t]
forall bits. Map bits -> [bits]
unMap (Map t -> [t]) -> Map t -> [t]
forall a b. (a -> b) -> a -> b
$ Set t -> Map t -> Map t
forall bits. C bits => Set bits -> Map bits -> Map bits
inc (t -> Set t
forall bits. bits -> Set bits
Set t
c) ([t] -> Map t
forall bits. [bits] -> Map bits
Map [t]
xs)
       go t
c [] [t]
ys = Map t -> [t]
forall bits. Map bits -> [bits]
unMap (Map t -> [t]) -> Map t -> [t]
forall a b. (a -> b) -> a -> b
$ Set t -> Map t -> Map t
forall bits. C bits => Set bits -> Map bits -> Map bits
inc (t -> Set t
forall bits. bits -> Set bits
Set t
c) ([t] -> Map t
forall bits. [bits] -> Map bits
Map [t]
ys)
       go t
c (t
x:[t]
xs) (t
y:[t]
ys) =
          t -> t -> t
forall bits. C bits => bits -> bits -> bits
xor t
c (t -> t -> t
forall bits. C bits => bits -> bits -> bits
xor t
x t
y)  t -> [t] -> [t]
forall a. a -> [a] -> [a]
:  t -> [t] -> [t] -> [t]
go (t
ct -> t -> t
forall bits. C bits => bits -> bits -> bits
.&.(t
xt -> t -> t
forall bits. C bits => bits -> bits -> bits
.|.t
y) t -> t -> t
forall bits. C bits => bits -> bits -> bits
.|. t
xt -> t -> t
forall bits. C bits => bits -> bits -> bits
.&.t
y) [t]
xs [t]
ys
   in  [bits] -> Map bits
forall bits. [bits] -> Map bits
Map ([bits] -> Map bits) -> [bits] -> Map bits
forall a b. (a -> b) -> a -> b
$ bits -> [bits] -> [bits] -> [bits]
forall {t}. C t => t -> [t] -> [t] -> [t]
go bits
forall bits. C bits => bits
Bit.empty [bits]
xs0 [bits]
ys0

inc :: Bit.C bits => Set bits -> Map bits -> Map bits
inc :: forall bits. C bits => Set bits -> Map bits -> Map bits
inc (Set bits
xs0) (Map [bits]
ys0) =
   [bits] -> Map bits
forall bits. [bits] -> Map bits
Map ([bits] -> Map bits) -> [bits] -> Map bits
forall a b. (a -> b) -> a -> b
$
   (bits -> [bits])
-> (bits -> bits -> (bits, bits)) -> bits -> [bits] -> [bits]
forall acc y x.
(acc -> [y]) -> (acc -> x -> (acc, y)) -> acc -> [x] -> [y]
mapAccumAffix
      (\bits
c -> if bits
cbits -> bits -> Bool
forall a. Eq a => a -> a -> Bool
==bits
forall bits. C bits => bits
Bit.empty then [] else [bits
c])
      (\bits
c bits
x -> (bits
c bits -> bits -> bits
forall bits. C bits => bits -> bits -> bits
.&. bits
x, bits -> bits -> bits
forall bits. C bits => bits -> bits -> bits
xor bits
c bits
x))
      bits
xs0 [bits]
ys0


sub :: Bit.C bits => Map bits -> Map bits -> Map bits
sub :: forall bits. C bits => Map bits -> Map bits -> Map bits
sub (Map [bits]
xs0) (Map [bits]
ys0) =
   let go :: t -> [t] -> [t] -> [t]
go t
c [t]
xs [] = [t] -> [t]
forall bits. C bits => [bits] -> [bits]
normalize ([t] -> [t]) -> [t] -> [t]
forall a b. (a -> b) -> a -> b
$ Map t -> [t]
forall bits. Map bits -> [bits]
unMap (Map t -> [t]) -> Map t -> [t]
forall a b. (a -> b) -> a -> b
$ Set t -> Map t -> Map t
forall bits. C bits => Set bits -> Map bits -> Map bits
dec (t -> Set t
forall bits. bits -> Set bits
Set t
c) ([t] -> Map t
forall bits. [bits] -> Map bits
Map [t]
xs)
       go t
c [] [t]
ys =
          if t
ct -> t -> Bool
forall a. Eq a => a -> a -> Bool
==t
forall bits. C bits => bits
Bit.empty Bool -> Bool -> Bool
&& (t -> Bool) -> [t] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (t -> t -> Bool
forall a. Eq a => a -> a -> Bool
==t
forall bits. C bits => bits
Bit.empty) [t]
ys
            then []
            else String -> [t]
forall a. HasCallStack => String -> a
error String
"sub: underflow"
       go t
c (t
x:[t]
xs) (t
y:[t]
ys) =
          t -> t -> t
forall bits. C bits => bits -> bits -> bits
xor t
c (t -> t -> t
forall bits. C bits => bits -> bits -> bits
xor t
x t
y) t -> [t] -> [t]
forall a. a -> [a] -> [a]
: t -> [t] -> [t] -> [t]
go (t -> t -> t
forall bits. C bits => bits -> bits -> bits
difference (t
ct -> t -> t
forall bits. C bits => bits -> bits -> bits
.|.t
y) t
x t -> t -> t
forall bits. C bits => bits -> bits -> bits
.|. t
ct -> t -> t
forall bits. C bits => bits -> bits -> bits
.&.t
y) [t]
xs [t]
ys
   in  [bits] -> Map bits
forall bits. [bits] -> Map bits
Map ([bits] -> Map bits) -> [bits] -> Map bits
forall a b. (a -> b) -> a -> b
$ bits -> [bits] -> [bits] -> [bits]
forall {t}. C t => t -> [t] -> [t] -> [t]
go bits
forall bits. C bits => bits
Bit.empty [bits]
xs0 [bits]
ys0

dec :: Bit.C bits => Set bits -> Map bits -> Map bits
dec :: forall bits. C bits => Set bits -> Map bits -> Map bits
dec (Set bits
xs0) (Map [bits]
ys0) =
   [bits] -> Map bits
forall bits. [bits] -> Map bits
Map ([bits] -> Map bits) -> [bits] -> Map bits
forall a b. (a -> b) -> a -> b
$
   (bits -> [bits])
-> (bits -> bits -> (bits, bits)) -> bits -> [bits] -> [bits]
forall acc y x.
(acc -> [y]) -> (acc -> x -> (acc, y)) -> acc -> [x] -> [y]
mapAccumAffix
      (\bits
c -> if bits
cbits -> bits -> Bool
forall a. Eq a => a -> a -> Bool
==bits
forall bits. C bits => bits
Bit.empty then [] else String -> [bits]
forall a. HasCallStack => String -> a
error String
"dec: underflow")
      (\bits
c bits
x -> (bits -> bits -> bits
forall bits. C bits => bits -> bits -> bits
difference bits
c bits
x, bits -> bits -> bits
forall bits. C bits => bits -> bits -> bits
xor bits
c bits
x))
      bits
xs0 [bits]
ys0

{-# INLINE mapAccumAffix #-}
mapAccumAffix, _mapAccumAffix ::
   (acc -> [y]) -> (acc -> x -> (acc, y)) -> acc -> [x] -> [y]
mapAccumAffix :: forall acc y x.
(acc -> [y]) -> (acc -> x -> (acc, y)) -> acc -> [x] -> [y]
mapAccumAffix acc -> [y]
affix acc -> x -> (acc, y)
f =
   let go :: acc -> [x] -> [y]
go acc
acc0 (x
x:[x]
xs) = let (acc
acc1, y
y) = acc -> x -> (acc, y)
f acc
acc0 x
x in  y
y y -> [y] -> [y]
forall a. a -> [a] -> [a]
: acc -> [x] -> [y]
go acc
acc1 [x]
xs
       go acc
acc [] = acc -> [y]
affix acc
acc
   in  acc -> [x] -> [y]
go

_mapAccumAffix :: forall acc y x.
(acc -> [y]) -> (acc -> x -> (acc, y)) -> acc -> [x] -> [y]
_mapAccumAffix acc -> [y]
affix acc -> x -> (acc, y)
f acc
acc =
   ([y] -> [y] -> [y]) -> ([y], [y]) -> [y]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [y] -> [y] -> [y]
forall a. [a] -> [a] -> [a]
(++) (([y], [y]) -> [y]) -> ([x] -> ([y], [y])) -> [x] -> [y]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (acc -> [y]) -> ([y], acc) -> ([y], [y])
forall b c a. (b -> c) -> (a, b) -> (a, c)
mapSnd acc -> [y]
affix (([y], acc) -> ([y], [y]))
-> ([x] -> ([y], acc)) -> [x] -> ([y], [y])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (acc, [y]) -> ([y], acc)
forall a b. (a, b) -> (b, a)
swap ((acc, [y]) -> ([y], acc))
-> ([x] -> (acc, [y])) -> [x] -> ([y], acc)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (acc -> x -> (acc, y)) -> acc -> [x] -> (acc, [y])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
List.mapAccumL acc -> x -> (acc, y)
f acc
acc

intersectionSet :: (Bit.C bits) => Map bits -> Set bits -> Map bits
intersectionSet :: forall bits. C bits => Map bits -> Set bits -> Map bits
intersectionSet (Map [bits]
xs) (Set bits
y) = [bits] -> Map bits
forall bits. [bits] -> Map bits
Map ([bits] -> Map bits) -> [bits] -> Map bits
forall a b. (a -> b) -> a -> b
$ [bits] -> [bits]
forall bits. C bits => [bits] -> [bits]
normalize ([bits] -> [bits]) -> [bits] -> [bits]
forall a b. (a -> b) -> a -> b
$ (bits -> bits) -> [bits] -> [bits]
forall a b. (a -> b) -> [a] -> [b]
map (bits
ybits -> bits -> bits
forall bits. C bits => bits -> bits -> bits
.&.) [bits]
xs

differenceSet :: (Bit.C bits) => Map bits -> Set bits -> Map bits
differenceSet :: forall bits. C bits => Map bits -> Set bits -> Map bits
differenceSet (Map [bits]
xs) (Set bits
y) = [bits] -> Map bits
forall bits. [bits] -> Map bits
Map ([bits] -> Map bits) -> [bits] -> Map bits
forall a b. (a -> b) -> a -> b
$ [bits] -> [bits]
forall bits. C bits => [bits] -> [bits]
normalize ([bits] -> [bits]) -> [bits] -> [bits]
forall a b. (a -> b) -> a -> b
$ (bits -> bits) -> [bits] -> [bits]
forall a b. (a -> b) -> [a] -> [b]
map ((bits -> bits -> bits) -> bits -> bits -> bits
forall a b c. (a -> b -> c) -> b -> a -> c
flip bits -> bits -> bits
forall bits. C bits => bits -> bits -> bits
difference bits
y) [bits]
xs

normalize :: (Bit.C bits) => [bits] -> [bits]
normalize :: forall bits. C bits => [bits] -> [bits]
normalize = (bits -> Bool) -> [bits] -> [bits]
forall a. (a -> Bool) -> [a] -> [a]
ListRev.dropWhile (bits
forall bits. C bits => bits
Bit.emptybits -> bits -> Bool
forall a. Eq a => a -> a -> Bool
==)


{-
Only elements from the base set are considered.
This way we can distinguish between non-members and members with count zero.
-}
minimumSet :: Bit.C bits => Set bits -> Map bits -> Set bits
minimumSet :: forall bits. C bits => Set bits -> Map bits -> Set bits
minimumSet Set bits
baseSet (Map [bits]
xs) =
   (bits -> Set bits -> Set bits) -> Set bits -> [bits] -> Set bits
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
      (\bits
x Set bits
mins ->
         case Set bits -> Set bits -> Set bits
forall bits. C bits => Set bits -> Set bits -> Set bits
BitSet.difference Set bits
mins (Set bits -> Set bits) -> Set bits -> Set bits
forall a b. (a -> b) -> a -> b
$ bits -> Set bits
forall bits. bits -> Set bits
Set bits
x of
            Set bits
newMins ->
               if Set bits -> Bool
forall bits. C bits => Set bits -> Bool
BitSet.null Set bits
newMins
                 then Set bits
mins
                 else Set bits
newMins)
      Set bits
baseSet [bits]
xs