-- | Combine Heuristics for solving the MCSP problem.
module MCSP.Heuristics.Combine (
    UseSingletons (..),
    combine,
    combineP,
) where

import Prelude hiding (String, concat, (++))

import Data.Set (Set)

import MCSP.Data.Meta (Meta, MetaInputVariable (..), getOrDefine)
import MCSP.Data.Pair (Pair, both, first, second)
import MCSP.Data.String (String (..), Unbox, concat, (++))
import MCSP.Data.String.Extra (Partition, chars, hasOneOf, singletons)

-- | Applies a function until the result converges.
converge :: Eq a => (a -> a) -> a -> a
converge :: forall a. Eq a => (a -> a) -> a -> a
converge = (a -> Bool) -> (a -> a) -> a -> a
forall a. (a -> Bool) -> (a -> a) -> a -> a
until ((a -> Bool) -> (a -> a) -> a -> a)
-> ((a -> a) -> a -> Bool) -> (a -> a) -> a -> a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
(==) =<<)

-- | Algorithm used in @combineAll@ to decide whether to combine to matching blocks.
class CombineDecision h a where
    -- | Given two matching blocks, decide if they should be combined.
    shouldCombine :: h a -> String a -> String a -> Bool

-- | Always combine two matching blocks.
data AlwaysCombine a = AlwaysCombine

instance CombineDecision AlwaysCombine a where
    shouldCombine :: AlwaysCombine a -> String a -> String a -> Bool
shouldCombine AlwaysCombine a
AlwaysCombine String a
_ String a
_ = Bool
True
    {-# INLINE shouldCombine #-}

-- | Combine blocks if both of them have a singleton.
newtype BothHaveSingleton a = BothHaveSingleton (Set a)

instance Ord a => CombineDecision BothHaveSingleton a where
    shouldCombine :: BothHaveSingleton a -> String a -> String a -> Bool
shouldCombine (BothHaveSingleton Set a
singles) String a
xs String a
ys =
        String a
xs String a -> Set a -> Bool
forall a. Ord a => String a -> Set a -> Bool
`hasOneOf` Set a
singles Bool -> Bool -> Bool
&& String a
ys String a -> Set a -> Bool
forall a. Ord a => String a -> Set a -> Bool
`hasOneOf` Set a
singles
    {-# INLINE shouldCombine #-}

-- | Combine blocks if either one of them have a singleton.
newtype EitherHasSingleton a = EitherHasSingleton (Set a)

instance Ord a => CombineDecision EitherHasSingleton a where
    shouldCombine :: EitherHasSingleton a -> String a -> String a -> Bool
shouldCombine (EitherHasSingleton Set a
singles) String a
xs String a
ys =
        String a
xs String a -> Set a -> Bool
forall a. Ord a => String a -> Set a -> Bool
`hasOneOf` Set a
singles Bool -> Bool -> Bool
|| String a
ys String a -> Set a -> Bool
forall a. Ord a => String a -> Set a -> Bool
`hasOneOf` Set a
singles
    {-# INLINE shouldCombine #-}

-- | /O(n^2)/ If possible, combines the first 2 blocks of a string and the first identical pair of
-- another.
combineOne :: (CombineDecision h a, Eq a) => h a -> Pair (Partition a) -> Maybe (Pair (Partition a))
combineOne :: forall (h :: * -> *) a.
(CombineDecision h a, Eq a) =>
h a -> Pair (Partition a) -> Maybe (Pair (Partition a))
combineOne h a
deicision (String a
x1 : String a
x2 : Partition a
xs, String a
y1 : String a
y2 : Partition a
ys)
    | (String a
x1, String a
x2) (String a, String a) -> (String a, String a) -> Bool
forall a. Eq a => a -> a -> Bool
== (String a
y1, String a
y2) Bool -> Bool -> Bool
&& h a -> String a -> String a -> Bool
forall (h :: * -> *) a.
CombineDecision h a =>
h a -> String a -> String a -> Bool
shouldCombine h a
deicision String a
x1 String a
x2 = (Partition a, Partition a) -> Maybe (Partition a, Partition a)
forall a. a -> Maybe a
Just ((String a
x1 String a -> String a -> String a
forall a. String a -> String a -> String a
++ String a
x2) String a -> Partition a -> Partition a
forall a. a -> [a] -> [a]
: Partition a
xs, (String a
y1 String a -> String a -> String a
forall a. String a -> String a -> String a
++ String a
y2) String a -> Partition a -> Partition a
forall a. a -> [a] -> [a]
: Partition a
ys)
    | Bool
otherwise = (Partition a -> Partition a)
-> (Partition a, Partition a) -> (Partition a, Partition a)
forall b b' a. (b -> b') -> (a, b) -> (a, b')
second (String a
y1 :) ((Partition a, Partition a) -> (Partition a, Partition a))
-> Maybe (Partition a, Partition a)
-> Maybe (Partition a, Partition a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> h a
-> (Partition a, Partition a) -> Maybe (Partition a, Partition a)
forall (h :: * -> *) a.
(CombineDecision h a, Eq a) =>
h a -> Pair (Partition a) -> Maybe (Pair (Partition a))
combineOne h a
deicision (String a
x1 String a -> Partition a -> Partition a
forall a. a -> [a] -> [a]
: String a
x2 String a -> Partition a -> Partition a
forall a. a -> [a] -> [a]
: Partition a
xs, String a
y2 String a -> Partition a -> Partition a
forall a. a -> [a] -> [a]
: Partition a
ys)
combineOne h a
_ (Partition a, Partition a)
_ = Maybe (Partition a, Partition a)
forall a. Maybe a
Nothing
-- Specilization for each `CombineDecision` possible.
{-# SPECIALIZE combineOne ::
    Eq a => AlwaysCombine a -> Pair (Partition a) -> Maybe (Pair (Partition a))
    #-}
{-# SPECIALIZE combineOne ::
    Ord a => BothHaveSingleton a -> Pair (Partition a) -> Maybe (Pair (Partition a))
    #-}
{-# SPECIALIZE combineOne ::
    Ord a => EitherHasSingleton a -> Pair (Partition a) -> Maybe (Pair (Partition a))
    #-}

-- | Combines pairs of blocks from left to right in 2 strings.
combineAll :: (CombineDecision h a, Eq a) => h a -> Pair (Partition a) -> Pair (Partition a)
combineAll :: forall (h :: * -> *) a.
(CombineDecision h a, Eq a) =>
h a -> Pair (Partition a) -> Pair (Partition a)
combineAll h a
_ ([], Partition a
ys) = ([], Partition a
ys)
combineAll h a
_ (Partition a
xs, []) = (Partition a
xs, [])
combineAll h a
decision (String a
x : Partition a
xs, Partition a
ys) =
    (Partition a, Partition a)
-> ((Partition a, Partition a) -> (Partition a, Partition a))
-> Maybe (Partition a, Partition a)
-> (Partition a, Partition a)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
        (Partition a, Partition a)
combineXs
        (h a -> (Partition a, Partition a) -> (Partition a, Partition a)
forall (h :: * -> *) a.
(CombineDecision h a, Eq a) =>
h a -> Pair (Partition a) -> Pair (Partition a)
combineAll h a
decision)
        (h a
-> (Partition a, Partition a) -> Maybe (Partition a, Partition a)
forall (h :: * -> *) a.
(CombineDecision h a, Eq a) =>
h a -> Pair (Partition a) -> Maybe (Pair (Partition a))
combineOne h a
decision (String a
x String a -> Partition a -> Partition a
forall a. a -> [a] -> [a]
: Partition a
xs, Partition a
ys))
  where
    combineXs :: (Partition a, Partition a)
combineXs = (Partition a -> Partition a)
-> (Partition a, Partition a) -> (Partition a, Partition a)
forall a a' b. (a -> a') -> (a, b) -> (a', b)
first (String a
x :) ((Partition a, Partition a) -> (Partition a, Partition a))
-> (Partition a, Partition a) -> (Partition a, Partition a)
forall a b. (a -> b) -> a -> b
$ h a -> (Partition a, Partition a) -> (Partition a, Partition a)
forall (h :: * -> *) a.
(CombineDecision h a, Eq a) =>
h a -> Pair (Partition a) -> Pair (Partition a)
combineAll h a
decision (Partition a
xs, Partition a
ys)
-- Specilization for each `CombineDecision` possible.
{-# SPECIALIZE combineAll :: Eq a => AlwaysCombine a -> Pair (Partition a) -> Pair (Partition a) #-}
{-# SPECIALIZE combineAll ::
    Ord a => BothHaveSingleton a -> Pair (Partition a) -> Pair (Partition a)
    #-}
{-# SPECIALIZE combineAll ::
    Ord a => EitherHasSingleton a -> Pair (Partition a) -> Pair (Partition a)
    #-}

-- | MCSP combine heuristic.
--
-- Applies combination of blocks from left to right until a maximal solution is reached.
combineSimple :: Eq a => Pair (Partition a) -> Pair (Partition a)
combineSimple :: forall a. Eq a => Pair (Partition a) -> Pair (Partition a)
combineSimple = (Pair (Partition a) -> Pair (Partition a))
-> Pair (Partition a) -> Pair (Partition a)
forall a. Eq a => (a -> a) -> a -> a
converge (AlwaysCombine a -> Pair (Partition a) -> Pair (Partition a)
forall (h :: * -> *) a.
(CombineDecision h a, Eq a) =>
h a -> Pair (Partition a) -> Pair (Partition a)
combineAll AlwaysCombine a
forall {k} (a :: k). AlwaysCombine a
AlwaysCombine)

-- | MSCP combine heuristic considering singleton analysis.
--
-- Applies combination of blocks from left to right until a maximal solution is reached,
-- combining first pairs in which both blocks have singletons, then pairs in which either
-- block has singletons and finally all other possible pairs.
combineWithSingletons :: (Unbox a, Ord a) => Pair (Partition a) -> Pair (Partition a)
combineWithSingletons :: forall a.
(Unbox a, Ord a) =>
Pair (Partition a) -> Pair (Partition a)
combineWithSingletons (Partition a
x, Partition a
y)
    | Set a -> Bool
forall a. Set a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Set a
singles = (Pair (Partition a) -> Pair (Partition a))
-> Pair (Partition a) -> Pair (Partition a)
forall a. Eq a => (a -> a) -> a -> a
converge (AlwaysCombine a -> Pair (Partition a) -> Pair (Partition a)
forall (h :: * -> *) a.
(CombineDecision h a, Eq a) =>
h a -> Pair (Partition a) -> Pair (Partition a)
combineAll AlwaysCombine a
forall {k} (a :: k). AlwaysCombine a
AlwaysCombine) (Partition a
x, Partition a
y)
    | Bool
otherwise = (Pair (Partition a) -> Pair (Partition a))
-> Pair (Partition a) -> Pair (Partition a)
forall a. Eq a => (a -> a) -> a -> a
converge (AlwaysCombine a -> Pair (Partition a) -> Pair (Partition a)
forall (h :: * -> *) a.
(CombineDecision h a, Eq a) =>
h a -> Pair (Partition a) -> Pair (Partition a)
combineAll AlwaysCombine a
forall {k} (a :: k). AlwaysCombine a
AlwaysCombine) (Pair (Partition a) -> Pair (Partition a))
-> Pair (Partition a) -> Pair (Partition a)
forall a b. (a -> b) -> a -> b
$ Pair (Partition a) -> Pair (Partition a)
combineSingletons (Partition a
x, Partition a
y)
  where
    singles :: Set a
singles = String a -> Set a
forall a. Ord a => String a -> Set a
singletons (Partition a -> String a
forall a. Unbox a => [String a] -> String a
concat Partition a
x)
    combineSingletons :: Pair (Partition a) -> Pair (Partition a)
combineSingletons =
        (Pair (Partition a) -> Pair (Partition a))
-> Pair (Partition a) -> Pair (Partition a)
forall a. Eq a => (a -> a) -> a -> a
converge (EitherHasSingleton a -> Pair (Partition a) -> Pair (Partition a)
forall (h :: * -> *) a.
(CombineDecision h a, Eq a) =>
h a -> Pair (Partition a) -> Pair (Partition a)
combineAll (EitherHasSingleton a -> Pair (Partition a) -> Pair (Partition a))
-> EitherHasSingleton a -> Pair (Partition a) -> Pair (Partition a)
forall a b. (a -> b) -> a -> b
$ Set a -> EitherHasSingleton a
forall a. Set a -> EitherHasSingleton a
EitherHasSingleton Set a
singles)
            (Pair (Partition a) -> Pair (Partition a))
-> (Pair (Partition a) -> Pair (Partition a))
-> Pair (Partition a)
-> Pair (Partition a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Pair (Partition a) -> Pair (Partition a))
-> Pair (Partition a) -> Pair (Partition a)
forall a. Eq a => (a -> a) -> a -> a
converge (BothHaveSingleton a -> Pair (Partition a) -> Pair (Partition a)
forall (h :: * -> *) a.
(CombineDecision h a, Eq a) =>
h a -> Pair (Partition a) -> Pair (Partition a)
combineAll (BothHaveSingleton a -> Pair (Partition a) -> Pair (Partition a))
-> BothHaveSingleton a -> Pair (Partition a) -> Pair (Partition a)
forall a b. (a -> b) -> a -> b
$ Set a -> BothHaveSingleton a
forall a. Set a -> BothHaveSingleton a
BothHaveSingleton Set a
singles)

-- | Enable or disable singleton analysis in `combine`.
newtype UseSingletons = UseSingletons Bool
    deriving newtype (UseSingletons -> UseSingletons -> Bool
(UseSingletons -> UseSingletons -> Bool)
-> (UseSingletons -> UseSingletons -> Bool) -> Eq UseSingletons
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: UseSingletons -> UseSingletons -> Bool
== :: UseSingletons -> UseSingletons -> Bool
$c/= :: UseSingletons -> UseSingletons -> Bool
/= :: UseSingletons -> UseSingletons -> Bool
Eq, Eq UseSingletons
Eq UseSingletons =>
(UseSingletons -> UseSingletons -> Ordering)
-> (UseSingletons -> UseSingletons -> Bool)
-> (UseSingletons -> UseSingletons -> Bool)
-> (UseSingletons -> UseSingletons -> Bool)
-> (UseSingletons -> UseSingletons -> Bool)
-> (UseSingletons -> UseSingletons -> UseSingletons)
-> (UseSingletons -> UseSingletons -> UseSingletons)
-> Ord UseSingletons
UseSingletons -> UseSingletons -> Bool
UseSingletons -> UseSingletons -> Ordering
UseSingletons -> UseSingletons -> UseSingletons
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 :: UseSingletons -> UseSingletons -> Ordering
compare :: UseSingletons -> UseSingletons -> Ordering
$c< :: UseSingletons -> UseSingletons -> Bool
< :: UseSingletons -> UseSingletons -> Bool
$c<= :: UseSingletons -> UseSingletons -> Bool
<= :: UseSingletons -> UseSingletons -> Bool
$c> :: UseSingletons -> UseSingletons -> Bool
> :: UseSingletons -> UseSingletons -> Bool
$c>= :: UseSingletons -> UseSingletons -> Bool
>= :: UseSingletons -> UseSingletons -> Bool
$cmax :: UseSingletons -> UseSingletons -> UseSingletons
max :: UseSingletons -> UseSingletons -> UseSingletons
$cmin :: UseSingletons -> UseSingletons -> UseSingletons
min :: UseSingletons -> UseSingletons -> UseSingletons
Ord, Int -> UseSingletons -> ShowS
[UseSingletons] -> ShowS
UseSingletons -> String
(Int -> UseSingletons -> ShowS)
-> (UseSingletons -> String)
-> ([UseSingletons] -> ShowS)
-> Show UseSingletons
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> UseSingletons -> ShowS
showsPrec :: Int -> UseSingletons -> ShowS
$cshow :: UseSingletons -> String
show :: UseSingletons -> String
$cshowList :: [UseSingletons] -> ShowS
showList :: [UseSingletons] -> ShowS
Show)

instance MetaInputVariable UseSingletons where
    getVar :: Meta UseSingletons
getVar = UseSingletons -> Meta UseSingletons
forall v. MetaInputVariable v => v -> Meta v
getOrDefine (Bool -> UseSingletons
UseSingletons Bool
True)

-- | MSCP combine heuristic.
--
-- Applies singleton analysis depending on the value of `UseSingletons`.
combine :: Ord a => Pair (String a) -> Meta (Pair (Partition a))
combine :: forall a. Ord a => Pair (String a) -> Meta (Pair (Partition a))
combine strs :: Pair (String a)
strs@(String a
Unboxed, String a
_) = Pair (Partition a) -> Meta (Pair (Partition a))
forall a.
(Unbox a, Ord a) =>
Pair (Partition a) -> Meta (Pair (Partition a))
combineP (String a -> Partition a
forall a. String a -> Partition a
chars (String a -> Partition a) -> Pair (String a) -> Pair (Partition a)
forall a b. (a -> b) -> (a, a) -> (b, b)
`both` Pair (String a)
strs)

-- | Lifted MSCP combine heuristic.
combineP :: (Unbox a, Ord a) => Pair (Partition a) -> Meta (Pair (Partition a))
combineP :: forall a.
(Unbox a, Ord a) =>
Pair (Partition a) -> Meta (Pair (Partition a))
combineP Pair (Partition a)
parts = do
    UseSingletons Bool
withSingletons <- Meta UseSingletons
forall v. MetaInputVariable v => Meta v
getVar
    Pair (Partition a) -> Meta (Pair (Partition a))
forall a. a -> Meta a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pair (Partition a) -> Meta (Pair (Partition a)))
-> Pair (Partition a) -> Meta (Pair (Partition a))
forall a b. (a -> b) -> a -> b
$
        if Bool
withSingletons
            then Pair (Partition a) -> Pair (Partition a)
forall a.
(Unbox a, Ord a) =>
Pair (Partition a) -> Pair (Partition a)
combineWithSingletons Pair (Partition a)
parts
            else Pair (Partition a) -> Pair (Partition a)
forall a. Eq a => Pair (Partition a) -> Pair (Partition a)
combineSimple Pair (Partition a)
parts