{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DeriveFunctor #-}
module HyloDP.Base (
DPProblem(..),
DPTypes(..),
dpSolve
) where
import Data.List(foldl')
import Data.Maybe(maybeToList)
import Data.MemoTrie(HasTrie, memo)
import HyloDP.Semiring
data DPProblem p sc d = DPProblem
{ forall p sc d. DPProblem p sc d -> p
initial :: p
, forall p sc d. DPProblem p sc d -> p -> Bool
isTrivial :: p -> Bool
, forall p sc d. DPProblem p sc d -> p -> [(sc, d, p)]
subproblems :: p -> [(sc, d, p)]
}
class DPTypes sc d sol where
combine :: sc -> d -> sol
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)
type Coalgebra f p = p -> f p
type Algebra f s = f s -> s
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
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
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
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 ]