{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DeriveFunctor #-}

{-|
Module: HyloDP.Base
Description: A solver for Dynamic Programming problems
Copyright: (c) David Llorens and Juan Miguel Vilar, 2020
License: BSD-3-Clause
Stability: experimental

This module implements the DP problem solver. Its input is an instance
of the type 'DPProblem'. This type holds two funcions:

* @isTrivial@ that is true when an instance can be trivially solved.

* @subproblems@ that decompose the instance in smaller subproblems.

It also holds @initial@, the initial instance of the problem, the one
that you want to solve.

An example is the problem of finding the longest common
subsequence of two lists (ie, the LCS of @xs@ and @ys@ is a list all whose
elements appear both in @xs@ and @ys@ in the same order):

* If both @xs@ and @ys@ are empty, the problem is trivial.

* If not, check the heads of @xs@ and @ys@. If they are
  equal, take it and find the lcs of the tails. If they are different,
  don't take the element and consider one list and the tail of the
  other.

In code:


> import HyloDP
>
> lcsDPProblem :: Eq a => [a] -> [a] -> DPProblem ([a], [a]) Int (Maybe a)
> lcsDPProblem xs ys = DPProblem (xs, ys) isTrivial subproblems
>   where isTrivial (xs, ys) = null xs || null ys
>         subproblems (l@(x:xs), r@(y:ys))
>           | x == y = [(1, Just x, (xs, ys))]
>           | otherwise = [ (0, Nothing, (xs, r))
>                         , (0, Nothing, (l, ys))
>                         ]
>


We use 'Nothing' to signal that the element is dropped and 'Just x' to
signal that it is taken. Also, when we take an element, the score for
that decision is one, while dropping the element scores zero.

Now, you can find the number of chars in common between @"train"@ and
@"raising"@ like this:


> print (dpSolve $ lcsDPProblem "train" "raising" :: TMax Int)

But you are probably more interesting in the best solution, so you can
do

> print (dpSolve $ lcsDPProblem "train" "raising" :: BestSolution Char (TMax Int))

As you can see, by choosing the appropriate semiring you decide what
result you get.

-}
module HyloDP.Base (
     -- ** The Types
     DPProblem(..),
     DPTypes(..),
     -- ** The Solver
     dpSolve
) where

import Data.List(foldl')
import Data.Maybe(maybeToList)
import Data.MemoTrie(HasTrie, memo)
import HyloDP.Semiring

{-|
A representation of the problem together with a description on how to
decompose it. It has three parameter types:

* @p@: the type of the instances of the problem.

* @sc@: the type of the score, the quantity that we want to maximize,
  minimize, etc.

* @d@: the type of the decisions.

-}

data DPProblem p sc d = DPProblem
     { forall p sc d. DPProblem p sc d -> p
initial :: p                     -- ^ The instance of the
                                        --   problem that has to be solved
     , forall p sc d. DPProblem p sc d -> p -> Bool
isTrivial :: p -> Bool           -- ^ True if a problem is trivial
     , forall p sc d. DPProblem p sc d -> p -> [(sc, d, p)]
subproblems :: p -> [(sc, d, p)] -- ^ Returns the decomposition of a problem
     }

{- | The class 'DPTypes' is used to associate scores, decisions, and
solutions. The idea is that the same score for a decision can be
in different solutions and 'combine' associates it. For instance,
the score of a decision can be an 'Int', but the solution for a
maximization problem will be a @TMax Int@ while for a minimization
problem it will be a @TMin Int@. In other cases, the solution also
needs the decisions made, so the best solution for a maximization
problem that picks chars and has integer scores is a @BestSolution
Char (TMax Int)@. So we have:

> combine 1 'a' :: TMin Int == TMin 1
> combine 1 'a' :: TMax Int == TMax 1
> combine 1 'a' :: BestSolution Char (TMax Int) == BestSolution "a" (TMax 1)

This is the mechanism used by 'DPSolve' to choose the result.
-}

class DPTypes sc d sol where
    combine :: sc -> d -> sol

-- trivial instance if the solution is just the score
instance DPTypes sc d sc where
    combine :: sc -> d -> sc
combine = sc -> d -> sc
forall sc d. sc -> d -> sc
const

instance DPTypes sc d (TMin sc) where
    combine :: sc -> d -> TMin sc
combine = TMin sc -> d -> TMin sc
forall sc d. sc -> d -> sc
const (TMin sc -> d -> TMin sc) -> (sc -> TMin sc) -> sc -> d -> TMin sc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. sc -> TMin sc
forall v. v -> TMin v
TMin

instance DPTypes sc d (TMax sc) where
    combine :: sc -> d -> TMax sc
combine = TMax sc -> d -> TMax sc
forall sc d. sc -> d -> sc
const (TMax sc -> d -> TMax sc) -> (sc -> TMax sc) -> sc -> d -> TMax sc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. sc -> TMax sc
forall v. v -> TMax v
TMax

instance DPTypes sc d (MaxProd sc) where
    combine :: sc -> d -> MaxProd sc
combine = MaxProd sc -> d -> MaxProd sc
forall sc d. sc -> d -> sc
const (MaxProd sc -> d -> MaxProd sc)
-> (sc -> MaxProd sc) -> sc -> d -> MaxProd sc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. sc -> MaxProd sc
forall v. v -> MaxProd v
MaxProd

instance DPTypes sc d Count where
    combine :: sc -> d -> Count
combine = (d -> Count) -> sc -> d -> Count
forall sc d. sc -> d -> sc
const ((d -> Count) -> sc -> d -> Count)
-> (Count -> d -> Count) -> Count -> sc -> d -> Count
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Count -> d -> Count
forall sc d. sc -> d -> sc
const (Count -> sc -> d -> Count) -> Count -> sc -> d -> Count
forall a b. (a -> b) -> a -> b
$ Integer -> Count
Count Integer
1

instance DPTypes sc d sol => DPTypes sc d (BestSolution d sol) where
    combine :: sc -> d -> BestSolution d sol
combine sc
sc d
d = Maybe [d] -> sol -> BestSolution d sol
forall d sc. Maybe [d] -> sc -> BestSolution d sc
BestSolution ([d] -> Maybe [d]
forall a. a -> Maybe a
Just [d
d]) (sc -> d -> sol
forall sc d sol. DPTypes sc d sol => sc -> d -> sol
combine sc
sc d
d)

instance DPTypes sc (Maybe d) sol => DPTypes sc (Maybe d) (BestSolution d sol) where
    combine :: sc -> Maybe d -> BestSolution d sol
combine sc
sc Maybe d
d = Maybe [d] -> sol -> BestSolution d sol
forall d sc. Maybe [d] -> sc -> BestSolution d sc
BestSolution ([d] -> Maybe [d]
forall a. a -> Maybe a
Just ([d] -> Maybe [d]) -> [d] -> Maybe [d]
forall a b. (a -> b) -> a -> b
$ Maybe d -> [d]
forall a. Maybe a -> [a]
maybeToList Maybe d
d) (sc -> Maybe d -> sol
forall sc d sol. DPTypes sc d sol => sc -> d -> sol
combine sc
sc Maybe d
d)

instance DPTypes sc d sol => DPTypes sc d (AllSolutions d sol) where
    combine :: sc -> d -> AllSolutions d sol
combine sc
sc d
d = [([d], sol)] -> AllSolutions d sol
forall d sc. [([d], sc)] -> AllSolutions d sc
AllSolutions [([d
d], sc -> d -> sol
forall sc d sol. DPTypes sc d sol => sc -> d -> sol
combine sc
sc d
d)]

instance DPTypes sc (Maybe d) sol => DPTypes sc (Maybe d) (AllSolutions d sol) where
    combine :: sc -> Maybe d -> AllSolutions d sol
combine sc
sc Maybe d
d = [([d], sol)] -> AllSolutions d sol
forall d sc. [([d], sc)] -> AllSolutions d sc
AllSolutions [(Maybe d -> [d]
forall a. Maybe a -> [a]
maybeToList Maybe d
d, sc -> Maybe d -> sol
forall sc d sol. DPTypes sc d sol => sc -> d -> sol
combine sc
sc Maybe d
d)]

instance DPTypes sc d sol => DPTypes sc d (AllBestSolutions d sol) where
    combine :: sc -> d -> AllBestSolutions d sol
combine sc
sc d
d = ([[d]], sol) -> AllBestSolutions d sol
forall d s. ([[d]], s) -> AllBestSolutions d s
AllBestSolutions ([[d
d]], sc -> d -> sol
forall sc d sol. DPTypes sc d sol => sc -> d -> sol
combine sc
sc d
d)

instance DPTypes sc (Maybe d) sol => DPTypes sc (Maybe d) (AllBestSolutions d sol) where
    combine :: sc -> Maybe d -> AllBestSolutions d sol
combine sc
sc Maybe d
d = ([[d]], sol) -> AllBestSolutions d sol
forall d s. ([[d]], s) -> AllBestSolutions d s
AllBestSolutions ([Maybe d -> [d]
forall a. Maybe a -> [a]
maybeToList Maybe d
d], sc -> Maybe d -> sol
forall sc d sol. DPTypes sc d sol => sc -> d -> sol
combine sc
sc Maybe d
d)

instance (DPTypes sc d sol, DPTypes sc d sol') => DPTypes sc d (sol, sol') where
    combine :: sc -> d -> (sol, sol')
combine sc
sc d
d = (sc -> d -> sol
forall sc d sol. DPTypes sc d sol => sc -> d -> sol
combine sc
sc d
d, sc -> d -> sol'
forall sc d sol. DPTypes sc d sol => sc -> d -> sol
combine sc
sc d
d)

-- Hylomorphisms

-- | The type used for decomposing the problem into subproblems
type Coalgebra f p = p -> f p

-- | The type used for componing the solution to the subproblems. f is a Functor
type Algebra f s = f s -> s

-- | The hylomorphism implementation (not used)
hylo :: Functor f => Algebra f s -> Coalgebra f p -> p -> s
hylo :: forall (f :: * -> *) s p.
Functor f =>
Algebra f s -> Coalgebra f p -> p -> s
hylo Algebra f s
alg Coalgebra f p
coalg = p -> s
h
     where h :: p -> s
h = Algebra f s
alg Algebra f s -> (p -> f s) -> p -> s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (p -> s) -> f p -> f s
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap p -> s
h (f p -> f s) -> Coalgebra f p -> p -> f s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coalgebra f p
coalg

-- | The hylomorphism implementation with memoization
hyloM :: (Functor f, HasTrie s) => Algebra f t -> Coalgebra f s -> s -> t
hyloM :: forall (f :: * -> *) s t.
(Functor f, HasTrie s) =>
Algebra f t -> Coalgebra f s -> s -> t
hyloM Algebra f t
alg Coalgebra f s
coalg = s -> t
h
     where h :: s -> t
h = (s -> t) -> s -> t
forall t a. HasTrie t => (t -> a) -> t -> a
memo ((s -> t) -> s -> t) -> (s -> t) -> s -> t
forall a b. (a -> b) -> a -> b
$ Algebra f t
alg Algebra f t -> (s -> f t) -> s -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (s -> t) -> f s -> f t
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap s -> t
h (f s -> f t) -> Coalgebra f s -> s -> f t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coalgebra f s
coalg

-- | The 'Functor' needed by our algebra and coalgebra
data DPF sc p = Trivial | Children [(sc, p)] deriving (forall a b. (a -> b) -> DPF sc a -> DPF sc b)
-> (forall a b. a -> DPF sc b -> DPF sc a) -> Functor (DPF sc)
forall a b. a -> DPF sc b -> DPF sc a
forall a b. (a -> b) -> DPF sc a -> DPF sc b
forall sc a b. a -> DPF sc b -> DPF sc a
forall sc a b. (a -> b) -> DPF sc a -> DPF sc b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall sc a b. (a -> b) -> DPF sc a -> DPF sc b
fmap :: forall a b. (a -> b) -> DPF sc a -> DPF sc b
$c<$ :: forall sc a b. a -> DPF sc b -> DPF sc a
<$ :: forall a b. a -> DPF sc b -> DPF sc a
Functor

{- |The function 'dpSolve' solves the 'initial' instance of a
'DPProblem'. The sol type is a semiring that determines what
kind of solution (the maximum, the minimum, etc.) is expected, it has
to be a 'Semiring' whose elements can be constructed from the
decisions as the scores, as determined by the 'DPTypes' constraint. The
'HasTrie' constraint ensures that memoization can be used.
-}

dpSolve :: ( HasTrie p, Semiring sol, DPTypes sc d sol)
     => DPProblem p sc d
     -> sol
dpSolve :: forall p sol sc d.
(HasTrie p, Semiring sol, DPTypes sc d sol) =>
DPProblem p sc d -> sol
dpSolve DPProblem p sc d
dp = Algebra (DPF sol) sol -> Coalgebra (DPF sol) p -> p -> sol
forall (f :: * -> *) s t.
(Functor f, HasTrie s) =>
Algebra f t -> Coalgebra f s -> s -> t
hyloM Algebra (DPF sol) sol
forall {a}. Semiring a => DPF a a -> a
solve Coalgebra (DPF sol) p
forall {sc}. DPTypes sc d sc => p -> DPF sc p
build (p -> sol) -> p -> sol
forall a b. (a -> b) -> a -> b
$ DPProblem p sc d -> p
forall p sc d. DPProblem p sc d -> p
initial DPProblem p sc d
dp
  where build :: p -> DPF sc p
build p
p | DPProblem p sc d -> p -> Bool
forall p sc d. DPProblem p sc d -> p -> Bool
isTrivial DPProblem p sc d
dp p
p = DPF sc p
forall sc p. DPF sc p
Trivial
                | Bool
otherwise = [(sc, p)] -> DPF sc p
forall sc p. [(sc, p)] -> DPF sc p
Children [(sc -> d -> sc
forall sc d sol. DPTypes sc d sol => sc -> d -> sol
combine sc
sc d
d, p
sp) |
                                        (sc
sc, d
d, p
sp) <- DPProblem p sc d -> p -> [(sc, d, p)]
forall p sc d. DPProblem p sc d -> p -> [(sc, d, p)]
subproblems DPProblem p sc d
dp p
p]
        solve :: DPF a a -> a
solve DPF a a
Trivial = a
forall s. Semiring s => s
one
        solve (Children [(a, a)]
sols) =
           (a -> a -> a) -> a -> [a] -> a
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' a -> a -> a
forall s. Semiring s => s -> s -> s
(<+>) a
forall s. Semiring s => s
zero [ a
sc a -> a -> a
forall s. Semiring s => s -> s -> s
<.> a
sol | (a
sc, a
sol) <- [(a, a)]
sols ]