diff --git a/DP.cabal b/DP.cabal new file mode 100644 --- /dev/null +++ b/DP.cabal @@ -0,0 +1,49 @@ +name: DP +version: 0.1 +synopsis: Pragmatic framework for dynamic programming +description: This module provides a simple declarative framework for dynamic programming optimization. + Users specify a dynamic programming problem as a simple haskell function that looks very similar to + mathematical recursion used in texts. The specification is then translated into a form that can be + solved efficiently by a modular solver. Includes solvers using memoization, + strict and lazy ordered tables, and recursion with a range of data structures for the underlying table. + This method also separates processing steps like pruning and debugging from the recursion itself, and + this package contains preliminary tools for beam search and tracing. + +category: Algorithms, Math, Natural Language Processing +author: Sasha Rush +maintainer: +build-Type: Simple +cabal-version: >= 1.2 +homepage: http://github.com/srush/SemiRings/tree/master +license: BSD3 + +library + exposed-modules: Data.DP, + Data.DP.Solvers, + Data.DP.Solvers.BottomUpLazy, + Data.DP.Solvers.TopDown, + Data.DP.Solvers.BottomUpStrict, + Data.DP.Solvers.Recursive, + Data.DP.Solvers.Beam, + Data.DP.Examples, + Data.DP.Examples.Fibonacci, + Data.DP.Examples.CheckerBoard, + Data.DP.Examples.HMM, + Data.DP.Examples.Bigram + + + other-modules : + Data.DP.Internals, + Data.DP.SolverInternal + + ghc-options: -O2 + + build-Depends: base <= 4.0, + containers, + safe, + QuickCheck > 2.0, + array, + list-tries, + semiring >= 0.3, + mtl > 1.1 + diff --git a/Data/DP.hs b/Data/DP.hs new file mode 100644 --- /dev/null +++ b/Data/DP.hs @@ -0,0 +1,169 @@ + +{-| A compact embedded language for specifying dynamic programs \(DPs\) for optimization. + + + +The style of the language is meant to invoke the formal mathematical +recursions common in CLRS and other algorithm texts, while still providing +the flexibility for several styles of solver. + +For solvers, see "Data.DP.Solvers". For example DPs, see "Data.DP.Examples". + +-} + +module Data.DP ( + +-- * Terminology +{-| + +[Dynamic Program] an optimization problem where each subsolution is a recursive combination of subsolutions. This property is known as optimal substructure. + +[Chart/Table] - A data structure for memoizing the results of subproblems. For simple DPs, the chart is indexed by the subproblem and holds its solution. + +[Item] A pair of (subproblem key, value). + +[Cell] A further division of the chart into sets of items. Useful when there is sparsity of relevant items. Implemented in chart-cell DPs. + +[Semiring] Informally, a type paired with a (+) and (*) operation. In Haskell, this is expressed with the 'Semiring' class, we use 'monoid' for plus, and 'multiplicative' for times, thus (+) -> 'mappend', 0 -> 'mempty', (*) -> 'times', 1 -> @'one'@. See the semiring library for a collection of useful semirings. + +This library provides a specification language for DPs defined using arbitrary semirings. It's +goal is to abstract the details of the solver from the mathematical specification of the DP. + +There are currently two types of DPs covered by the specification language - +simple and chart-cell. +-} + + module Data.Semiring, + +-- * Simple + +{-| +Simple DPs can be represented entirely by arrays +where each index represents a subproblem and its contents the result of +the subproblem. In addition to a semiring, simple DPs only have two operations, @f@ and @constant@. +@f@ references value in the DP chart and @constant@ lifts a semiring value into the DP. + +Perhaps the simplest example is the fibonacci sequence. First, a naive recusive definition - + +> fibNaive 0 = 1 +> fibNaive 1 = 1 +> fibNaive i = (fibNaive (i-2)) + (fibNaive (i-1)) + +Now as a DP - + +> fib 0 = one +> fib 1 = one +> fib i = (f (i-2)) `mappend` (f (i-1)) + +Since our definition is not recursive, we replace fib with @f@ so that it can be intercepted by a solver and memoized (or perhaps not) +Other changes are just cosmetic. Notice that we replace the num literals and + with their semiring counterparts. + +If we wanted, add some other literal say. + +> fibNaive i = (fibNaive (i-2)) + (fibNaive (i-1)) + i + +We would write - + +> fib i = (fib (i-2)) `mappend` (fib (i-1)) `mappend` (constant i) + +The final type is @fib :: SimpleDP Int Counting@, this means that we are indexing on Int and using the Counting semiring +(where + and * are defined as is). Fib can then be used with a solver to produce the final value. + +-} + DPSubValue, + f, + constant, + SimpleDP, + +-- * Chart-Cell +{-| +Chart-Cell DPs are a generalization of simple DPs, and are slightly more complicated, +but can be much efficient in practice when there is sparsity in the sub-structure of the DP. + +For instance, assume that we have a DP for an HMM, indexed on the current position and its current state. +If we represent this with a simple DP we get a chart of size /O(|pos| * |state|)/. In practice, though |state| +may be very large and very sparse for a given problem. So instead of having a cell for each (pos,state) pair, +we instead want a cell for each pos containing a set of states. + +Chart-Cell DPs give this kind of representation. They allow you to specify a chart containing +cells containing sets of items. Each item represents an answer to a sub-problem. + +Here's the HMM example. First, we write it in its Simple form- + +> hmmSimple trans (0, Start) = one +> hmmSimple trans (i, State curState) = +> mconcat $ +> [ f (i-1, trans ) `times` +> constant (lastState `trans` curState) | +> lastState <- states] + +Notice how the chart is indexed by position and state, at each index we look back at all possible incoming states. +So /O(|pos|*|state|)/ indices and /O(|state|)/ at each index. + +Here's the Chart-Cell version - + +> hmmCC allTrans 0 = mkItem Start one +> hmmCC allTrans i = +> getCell (i-1) (\(lastState, lastScore) -> +> mkCell $ [ mkItem (State newState) +> (lastScore `times` constant score) | +> (newState, score) <- allTrans lastState]) + +We now index the chart by just position, and index each cell by the state. This method has the same worst-case complexity, +but in practice can be much faster since there can be sparsity (either natural or introduced by pruning) at certain states. +-} + DPItem, + DPCell, + mkItem, + mkCell, + Item, + getCell, + DP, + -- * Conversion + fromSimple + + ) where + +--{{{ Imports +import qualified Data.Map as M +import Data.Semiring +import Data.DP.Internals +import Control.Monad.Identity +--}}} + +type SimpleDP ind val = ind -> DPSubValue ind (Identity val) + +-- | Retrieve the solution of subproblem of the DP for a given index. +-- Note: The ordering and storage of this retrieval is determined by the +-- solver used. +f :: ind -> DPSubValue ind (Identity val) +f = DPNode () + +-- | Lift a semiring value into a DPSubValue. +constant :: CellVal cell -> DPSubValue index cell +constant = Constant + + +-- | A dynamic program. +type DP index cell = index -> DPCell index cell + +-- | Groups several items into a cell. Items with the same key are combined with @mappend@ +mkCell :: [DPItem index cell] -> DPCell index cell +mkCell = Many + +-- | Create a new item. (@'mkItem' key val@) will create an item subindexed by key with value val.mkItem :: CellKey cell -> DPSubValue index cell -> DPItem index cell +mkItem = DPItem + +-- | Lookup a cell from the chart. @'getCell' ind fn@ will lookup index @ind@ and then call @fn@ +-- repeatedly with each item in the cell. It then concats the resulting items, combining +-- similarly keyed items with @mappend@ +-- Use instead of @f@ for Chart-Cell DPs +getCell + :: index + -> (Item index cell -> DPCell index cell) + -> DPCell index cell +getCell = Request + +-- | Convert a Simple DP to a General DP +fromSimple :: SimpleDP a b -> DP a (Identity b) +fromSimple simple i = mkCell [mkItem () (simple i)] diff --git a/Data/DP/Examples.hs b/Data/DP/Examples.hs new file mode 100644 --- /dev/null +++ b/Data/DP/Examples.hs @@ -0,0 +1,5 @@ +module Data.DP.Examples ( + module Data.DP.Examples.Fibonacci +) where + +import Data.DP.Examples.Fibonacci diff --git a/Data/DP/Examples/Bigram.hs b/Data/DP/Examples/Bigram.hs new file mode 100644 --- /dev/null +++ b/Data/DP/Examples/Bigram.hs @@ -0,0 +1,34 @@ +module Data.DP.Examples.Bigram where +import Data.DP +import Data.DP.Solvers.TopDown +import Data.DP.SolverAPI +import Data.Semiring.Viterbi +import Data.Semiring.Derivation +import Data.Semiring.Prob +import Data.Semiring.ViterbiNBestDerivation +import Control.Monad.Identity +import qualified Data.Map as M +type Bigram = (String, String) + +bigrams = + [(("a", "b"), 0.5), + (("b", "b"), 0.4), + (("b", "a"), 0.3), + (("c", "d"), 0.2), + (("d", "c"), 0.1), + (("SOS", "a"), 0.2) + ] + +bigramsStartWith word = + filter ((== word) . fst. fst ) bigrams + +ngram :: DP Int (M.Map String (ViterbiDerivation Prob [Bigram])) +ngram 0 = mkCell $ [mkItem "SOS" one] +ngram i = + getCell (i-1) (\(word, lastScore) -> + mkCell $ do + (bigram,score) <- bigramsStartWith word + return $ mkItem (snd bigram) $ + (lastScore `times` (constant $ mkViterbi $ Weighted (Prob score, mkDerivation [bigram])))) + +runNgram = getResult $ runIdentity $ solveDP topDownMap 5 ngram diff --git a/Data/DP/Examples/CheckerBoard.hs b/Data/DP/Examples/CheckerBoard.hs new file mode 100644 --- /dev/null +++ b/Data/DP/Examples/CheckerBoard.hs @@ -0,0 +1,61 @@ +-- | Checkerboard problem from +-- This example gives an implementation that matches the wikipedia example in +-- speed, with a third as much code and much more generality. + +module Data.DP.Examples.CheckerBoard where + +import Data.DP +import Data.DP.Solvers.TopDown +import Data.DP.Solvers.Recursive +import Data.DP.SolverAPI +import Data.Semiring.Max +import Data.Semiring.ViterbiNBestDerivation +import Data.Semiring.Derivation +import Data.Semiring.Viterbi +import Control.Monad.Identity + +checkerScore :: [[Int]] +checkerScore = + reverse $ [[6, 7, 4, 7, 8], + [7, 6, 1, 1, 4], + [3, 5, 7, 8, 2], + [0, 6, 7, 0, 0], + [0, 0, 5, 0, 0]] + +getScore (i,j) = (checkerScore !! (i-1)) !! (j-1) + +n = 5 + +data CheckerState = Finish | Middle (Int, Int) + deriving (Eq, Ord) + + +checkerBoard ind = + case ind of + Finish -> mconcat $ map (\j-> f' (n,j)) [1..n] + (Middle (i,j)) -> + if j < 1 || j > n then mempty + else if i == 1 then constant $ Max $ getScore (i,j) + else (mconcat $ [f' (i-1,j-1), f' (i-1,j), f' (i-1,j+1)]) + `times` (constant $ Max $ getScore (i,j)) + where f' = f . Middle + +runCheckerboard = getSimpleResult $ runIdentity $ solveSimpleDP topDownMap Finish checkerBoard + +checkerBoardGen mkSemi ind = + case ind of + Finish -> mconcat $ map (\j-> f' (n,j)) [1..n] + (Middle (i,j)) -> + if j < 1 || j > n then mempty + else if i == 1 then constant $ mkSemi (i,j) + else (mconcat $ [f' (i-1,j-1), f' (i-1,j), f' (i-1,j+1)]) + `times` (constant $ mkSemi (i,j)) + where f' = f . Middle + +maxSemi :: (Int, Int) -> Max Int +maxSemi = Max . getScore + +maxSemiViterbi :: (Int, Int) -> ViterbiDerivation (Max Int) [(Int,Int)] +maxSemiViterbi pos = mkViterbi $ Weighted (Max $ getScore pos, mkDerivation [pos]) + +runCheckerboardGen semi = getSimpleResult $ runIdentity $ solveSimpleDP recursive Finish (checkerBoardGen semi) diff --git a/Data/DP/Examples/Fibonacci.hs b/Data/DP/Examples/Fibonacci.hs new file mode 100644 --- /dev/null +++ b/Data/DP/Examples/Fibonacci.hs @@ -0,0 +1,72 @@ +-- | This example encodes the Fibonacci sequence as a dynamic program, and explores +-- using several different solvers to compute the result. + +module Data.DP.Examples.Fibonacci where + +--{{{ Imports +import Data.DP +import Data.DP.Solvers +import Data.Array.Unboxed +import Data.Semiring +import Data.Semiring.Counting +import Data.Array.ST +import qualified Data.Map as M +import Control.Monad.ST +import Control.Monad +import Control.Monad.Identity +import Data.Int +import Safe +--}}} + + +fib :: SimpleDP Int Counting +fib 0 = one +fib 1 = one +fib i = (f (i-2)) `mappend` (f (i-1)) + +runRecursive :: Int -> Counting +runRecursive i = getSimpleResult $ runIdentity $ solveSimpleDP recursive i fib + +-- | Run top down using a map +runMemo :: Int -> Counting +runMemo i = getSimpleResult $ runIdentity $ solveSimpleDP topDownMap i fib + +-- | Run bottom up using a map +runOrderedMap :: Int -> Counting +runOrderedMap i = getSimpleResult $ runIdentity $ solveSimpleDP bottomUpLazyMap [0..i] fib + +-- | Run bottom up using an Array +runOrdered :: Int -> Counting +runOrdered i = getSimpleResult $ runIdentity $ solveSimpleDP (bottomUpLazyArray (0,i)) [0..i] fib + + +-- | Shows one way to run using an impure data structure like @'STUArray'@. +runOrderedUnboxed :: Int -> IO Counting +runOrderedUnboxed i = (runIdentity . getResult) `liftM` (stToIO $ + solveSimpleDP (bottomUpStrictSTUArray + (fromIntegral::Counting -> Int64) + (fromIntegral::Int64 -> Counting) (0,i)) + [0..i] fib) + + + +data NMap key val = NMap Int (M.Map key val) + deriving (Show) + +nmapInsert :: (Ord key) => key -> val -> NMap key val -> Identity (NMap key val) +nmapInsert a v (NMap n m) = + return $ NMap n $ M.insert a v (if M.size m == n then M.delete (fst $ M.findMin m) m else m) + +nmapSolver n = mkSolver $ BottomUpStrict { + bus_insert = nmapInsert, + bus_empty = return $ NMap n M.empty, + bus_lookup = (\ i (NMap _ m) -> return ((M.!) m i)) + } + +-- | An NMap is a Map that only keeps track of the last n values seen. +-- For fibonacci there is no need to keep more than the last two value in +-- memory, so we can easily code up a 2-Map to use as our chart. +runNMap :: Int -> Counting +runNMap i = getSimpleResult $ runIdentity $ solveSimpleDP (nmapSolver 2) [0..i] fib + + diff --git a/Data/DP/Examples/HMM.hs b/Data/DP/Examples/HMM.hs new file mode 100644 --- /dev/null +++ b/Data/DP/Examples/HMM.hs @@ -0,0 +1,22 @@ +module Data.DP.Examples.HMM where +import Data.DP +import Data.Semiring + +data HMMState = Start | State Int + +states = Start : map State [0..100] + +hmmSimple trans (0, Start) = one +hmmSimple trans (i, State curState) = + mconcat $ + [ f (i-1, trans ) `times` + constant (lastState `trans` curState) | + lastState <- states] + + +hmmCC allTrans 0 = mkCell [mkItem Start one] +hmmCC allTrans i = + getCell (i-1) (\(lastState, lastScore) -> + mkCell $ [ mkItem (State newState) + (lastScore `times` constant score) | + (newState, score) <- allTrans lastState]) diff --git a/Data/DP/Internals.hs b/Data/DP/Internals.hs new file mode 100644 --- /dev/null +++ b/Data/DP/Internals.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleContexts, FlexibleInstances, TypeFamilies, KindSignatures, ExistentialQuantification #-} +module Data.DP.Internals +where +import Control.Monad.State.Strict +import Control.Monad.State.Class +import Control.Monad +import Data.Semiring +import qualified Data.Map as M +import Safe +import Control.Applicative +import Control.Monad.Identity + +class (Ord (CellKey c), Semiring (CellVal c)) => Cell (c:: *) where + type CellKey c :: * + type CellVal c :: * + fromList :: [(CellKey c, CellVal c)] -> c + toList :: c -> [(CellKey c, CellVal c)] + cellLookup :: CellKey c -> c -> CellVal c + +instance (Ord k, Semiring v) => Cell (M.Map k v) where + type CellKey (M.Map k v) = k + type CellVal (M.Map k v) = v + + fromList = M.fromListWith mappend + toList = M.toList + cellLookup n cells = fromJustNote "Key not found in cell" $ M.lookup n cells + +instance (Semiring v) => Cell (Identity v) where + type CellKey (Identity v) = () + type CellVal (Identity v) = v + fromList = Identity . snd . head + toList (Identity v) = [((), v)] + cellLookup _ (Identity a) = a + +data DPOpt = Plus | Times + +optFunc Plus = mappend +optFunc Times = times + +-- | Explicit representation for items retrieved from a DP +type Item index cell= (CellKey cell, DPSubValue index cell) + +data DPCell index cell = + Request index (Item index cell -> DPCell index cell ) | + Many [DPItem index cell] + +data DPItem index cell = + DPItem (CellKey cell) (DPSubValue index cell) + + +-- | Represents the solution to a subproblem of the DP. +-- Introduced by @constant@, used through the "Semiring" interface. +data DPSubValue index cell = + DPNode (CellKey cell) index | + Constant (CellVal cell) | + Opt DPOpt (DPSubValue index cell) (DPSubValue index cell) + +instance (Monoid (CellVal cell)) => Monoid (DPSubValue index cell ) where + mappend = Opt Plus + mempty = Constant mempty + +instance (Multiplicative (CellVal cell)) => Multiplicative (DPSubValue index cell ) where + times = Opt Times + one = Constant one +instance Semiring (CellVal cell) => Semiring (DPSubValue index cell) + +data DPState m chart ind cell = DPState { + dpLookup :: ind -> StateT (DPState m chart ind cell) m cell, + dpData :: chart +} + +findCells :: (Monad m, Cell cell) => ind -> StateT (DPState m chart ind cell) m cell +findCells ind = do + state <- get + dpLookup state ind + +reduceBase :: (Cell cell, Monad m) => + (cell -> m cell) -> + DPCell ind cell -> + (ind -> m cell) -> m cell +reduceBase o r fn = reduceBaseWrite o r (lift. fn) () + +reduceBaseWrite :: (Cell cell, Monad m) => + (cell -> m cell) -> + DPCell ind cell -> + (ind -> StateT (DPState m chart ind cell) m cell) -> chart -> m cell +reduceBaseWrite o r fn chart = do + res <- evalStateT (reduceComplex $ r) (DPState fn chart) + o $ fromList res + + +reduceComplex :: (Monad m, Cell cell) => DPCell ind cell -> StateT (DPState m chart ind cell) m [(CellKey cell, CellVal cell)] +reduceComplex (Many a) = do + rs <- mapM reduceItem a + return $ rs +reduceComplex (Request ind fn) = do + cells <- findCells ind + res <- mapM reduceComplex $ map fn $ map (\(a,b) -> (a, Constant b)) $ toList cells + return $ concat res + +reduceItem :: (Monad m, Cell cell) => DPItem ind cell -> StateT (DPState m chart ind cell) m (CellKey cell, CellVal cell) +reduceItem (DPItem n a) = do + ared <- reduce a + return $ (n, ared) + +reduce :: (Monad m, Cell cell) => DPSubValue ind cell -> StateT (DPState m chart ind cell) m (CellVal cell) +reduce (Constant a) = return a +reduce (Opt opt a b) = (liftM2 $ optFunc opt) (reduce a) (reduce b) +reduce (DPNode n i) = do + state <- get + cell <- dpLookup state i + return $ cellLookup n cell diff --git a/Data/DP/SolverInternal.hs b/Data/DP/SolverInternal.hs new file mode 100644 --- /dev/null +++ b/Data/DP/SolverInternal.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleContexts, FlexibleInstances, TypeFamilies, KindSignatures #-} +module Data.DP.SolverInternal where + +--{{{ +import Data.DP +import qualified Data.Map as M +import Data.Semiring +import Safe +import Control.Monad.Identity +--}}} + +newtype DPSolver (monad :: * -> *) solver (chart :: * -> * -> *) ind cell internal = DPSolver (solver monad chart ind cell internal) + +type DPSolverSame m solver chart ind cell = DPSolver m solver chart ind cell cell + +data SolveState = SolveState + +class DPSolveBase s where + type Chart s :: * -> * -> * + type DCell s + type Ind s + type Internal s + type DPMonad s :: * -> * + +instance (Monad m) => DPSolveBase (DPSolver m s ch ind cell int) where + type Chart (DPSolver m s ch ind cell int) = ch + type DCell (DPSolver m s ch ind cell int) = cell + type Ind (DPSolver m s ch ind cell int) = ind + type Internal (DPSolver m s ch ind cell int) = int + type DPMonad (DPSolver m s ch ind cell int) = m + + +class (DPSolveBase s, Monad (DPMonad s)) => SolveDP s where + type Frame s + startSolver :: + (DCell s -> (DPMonad s) (DCell s)) -> + SolveFn s + +data DPSolution chart ind cell internal = DPSolution { + -- | The solution of the full dynamic program, i.e. the value at the last index computed + getResult :: cell, + -- | The entire DP chart. The type is defined by the solver used. + getChart :: chart ind internal +} + +type DPSimpleSolution chart ind val = DPSolution chart ind (Identity val) + +type SolveSimpleFn s b = + s -> Frame s -> DP (Ind s) b -> DPMonad s (DPSolution (Chart s) (Ind s) (DCell s) (Internal s)) + +type SolveFn s = + s -> Frame s -> DP (Ind s) (DCell s) -> DPMonad s (DPSolution (Chart s) (Ind s) (DCell s) (Internal s)) diff --git a/Data/DP/Solvers.hs b/Data/DP/Solvers.hs new file mode 100644 --- /dev/null +++ b/Data/DP/Solvers.hs @@ -0,0 +1,15 @@ +module Data.DP.Solvers ( +-- * Solvers +module Data.DP.Solvers.TopDown, +module Data.DP.Solvers.BottomUpStrict, +module Data.DP.Solvers.BottomUpLazy, +module Data.DP.Solvers.Recursive, +-- * Solver Interface +module Data.DP.SolverAPI +) where + +import Data.DP.Solvers.TopDown +import Data.DP.Solvers.BottomUpStrict +import Data.DP.Solvers.BottomUpLazy +import Data.DP.Solvers.Recursive +import Data.DP.SolverAPI diff --git a/Data/DP/Solvers/Beam.hs b/Data/DP/Solvers/Beam.hs new file mode 100644 --- /dev/null +++ b/Data/DP/Solvers/Beam.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE FlexibleContexts, TypeFamilies #-} +-- | Beam Search is a pruning technique where low scoring items are filtered out +-- of a cell. It is not a solver itself, but it can be combined with other solvers +-- to improve the efficiency at the cost of some accuracy. + +module Data.DP.Solvers.Beam ( + -- * Filters + BeamFilter, + topK, + topWindow, + -- * Solver + solveDPBeam) where + +import Data.DP.SolverInternal +import Data.DP.Internals +import Data.Semiring +import Data.Function (on) +import Data.List (sortBy, maximumBy) +import Data.DP + + +type BeamFilter cell = cell -> cell + +-- | @'topK' k cell@ - Keep only the top @k@ items in @cell@. +topK :: (Cell cell, WeightedSemiring (CellVal cell)) => Int -> BeamFilter cell +topK k cell = fromList $ take k $ sortBy (compare `on` snd) $ toList cell + + +-- | @'topWindow' delta cell@ - Keep only the items within a @delta@ of the top @cell@. +topWindow :: (Cell cell, WeightedSemiring (CellVal cell)) => CellVal cell -> BeamFilter cell +topWindow delta cell = fromList $ filter ((> cutoff ) . snd ) ls + where ls = toList cell + max = maximumBy (compare `on` snd) ls + cutoff = (snd max) `mappend` delta + +solveDPBeam + :: (SolveDP s) => + (BeamFilter (DCell s)) + -> SolveFn s +solveDPBeam beam solver frame dp = startSolver (return . beam) solver frame dp diff --git a/Data/DP/Solvers/BottomUpLazy.hs b/Data/DP/Solvers/BottomUpLazy.hs new file mode 100644 --- /dev/null +++ b/Data/DP/Solvers/BottomUpLazy.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleContexts, FlexibleInstances, TypeFamilies, KindSignatures #-} + +{-| + +Bottom-Up Lazy Solver. Solve the DP in an ordered bottom up fashion, but compute values lazily. + +/Advantages/ + + * Some of the laziness benefits of a top-down method. + + * Lets you use efficient, pure data structures, in particular "Data.Array". + + +/Disadvantages/ + + * No threaded monad (uses identity). + + * Cannot use UArrays (not lazy) + + * Requires an ordering of indices +-} + +module Data.DP.Solvers.BottomUpLazy ( + -- * Predefined Solvers + bottomUpLazyGenMap, + bottomUpLazyMap, + bottomUpLazyIntMap, + bottomUpLazyIArray, + bottomUpLazyArray, + -- * Custom Solvers + -- | You can define a custom BottomUpLazy solver by implementing + -- the @'BottomUpLazy'@ strategy and calling @mkSolver@ + BottomUpLazy (..) + ) where + + +--{{{ Imports +import Data.DP.Internals +import Data.DP.SolverInternal +import Data.Array.IArray +import Data.Array.Unboxed +import qualified Data.Map as M +import qualified Data.ListTrie.Base.Map as GM +import Data.Semiring +import Safe +import Control.Monad.Identity +import Control.Monad.State.Strict +import Data.DP.SolverAPI +--}}} + +data BottomUpLazy m chart ind cell internal = BottomUpLazy { + bul_lookup :: ind -> chart ind internal -> cell, + bul_create :: [(ind, cell)] -> (chart ind internal) + } + +type LazyOrderedSolver m chart ind cell = DPSolverSame m BottomUpLazy chart ind cell + +instance ( Cell cell) => SolveDP (DPSolver Identity BottomUpLazy chart ind cell internal ) where + type Frame (DPSolver Identity BottomUpLazy chart ind cell internal) = [ind] + startSolver o (DPSolver solver) ordering dp = do + let chart = (bul_create solver) $ map (\i -> (i, runIdentity $ reduceBase o (dp i) (\a -> return ((bul_lookup solver) a chart)))) ordering + let res = (bul_lookup solver) (last ordering) chart + return $ DPSolution res chart + + +bottomUpLazyGenMap :: (GM.Map map ind) => DPSolverSame m BottomUpLazy map ind cell +bottomUpLazyGenMap = mkSolver $ BottomUpLazy { + bul_create = GM.fromList, + bul_lookup = (\a b-> fromJustNote "lookup failed" $ GM.lookup a b) + } + +bottomUpLazyMap :: (Ord ind) => DPSolverSame m BottomUpLazy M.Map ind cell +bottomUpLazyMap = bottomUpLazyGenMap + +bottomUpLazyIntMap :: (Enum ind) => DPSolverSame m BottomUpLazy GM.WrappedIntMap ind cell +bottomUpLazyIntMap = bottomUpLazyGenMap + +bottomUpLazyIArray :: (Cell cell, IArray array int, Ix ind) => + (cell -> int) -> (int -> cell) -> (ind, ind) -> + DPSolver m BottomUpLazy array ind cell int +bottomUpLazyIArray toInternal fromInternal bounds = mkSolver $ BottomUpLazy { + bul_create = array bounds . map (\(a,b)-> (a,toInternal b)) , + bul_lookup = (\a b -> fromInternal (b ! a)) + } + +bottomUpLazyArray :: (Ix ind, Cell cell) => (ind, ind) -> DPSolverSame m BottomUpLazy Array ind cell +bottomUpLazyArray = bottomUpLazyIArray id id + + diff --git a/Data/DP/Solvers/BottomUpStrict.hs b/Data/DP/Solvers/BottomUpStrict.hs new file mode 100644 --- /dev/null +++ b/Data/DP/Solvers/BottomUpStrict.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleContexts, FlexibleInstances, TypeFamilies, KindSignatures, Rank2Types #-} + +{-| + +Bottom-Up Strict Solver. Solve the DP the way they do it in imperative languages, bottom-up and strict. + +/Advantages/ + + * Can use imperative data structures like STArray's and STUArray's which are very fast and + have low memory overhead + +/Disadvantages/ + + * Not lazy, not pure (although you can use maps instead). + + * Requires an ordering of indices + +-} + +module Data.DP.Solvers.BottomUpStrict ( + -- * Predefined Solvers + bottomUpStrictGenMap, + bottomUpStrictMap, + bottomUpStrictMArray, + bottomUpStrictSTUArray, + -- * Custom Solvers + -- | You can define a custom BottomUpStrict strategy by implementing + -- the @'BottomUpStrict'@ type and calling @mkSolver@ + BottomUpStrict(..) + ) where + +--{{{ Imports +import Data.DP.Internals +import Data.DP.SolverInternal +import Data.Array.IArray +import qualified Data.Map as M +import qualified Data.ListTrie.Base.Map as GM +import Data.Semiring +import Safe +import Control.Monad.State.Strict +import Control.Monad.Identity +import Data.Array.MArray +import Data.Array.ST +import Data.Array.Unboxed +import Control.Monad.ST +import Data.DP.SolverAPI +--}}} + + + +data BottomUpStrict m chart ind cell internal = BottomUpStrict { + bus_lookup :: ind -> chart ind internal -> m (cell), + bus_insert :: ind -> cell -> chart ind internal -> m (chart ind internal), + bus_empty :: m (chart ind internal) + } + +instance (Cell cell, Monad m) => SolveDP (DPSolver m BottomUpStrict ch ind cell int) where + type Frame (DPSolver m BottomUpStrict ch ind cell int) = [ind] + startSolver o (DPSolver solver) order dp = do + init <- bus_empty solver + (val, chart) <- runStateT (last `liftM` mapM manage order) init + return $ DPSolution val chart + where + manage i = do + chart <- get + res <- lift $ reduceBase o (dp i) (\a -> bus_lookup solver a chart) + newchart <- lift $ bus_insert solver i res chart + put $ newchart + return $! res + + +bottomUpStrictGenMap :: (GM.Map map ind) => DPSolverSame Identity (BottomUpStrict ) map ind cell +bottomUpStrictGenMap = mkSolver $ BottomUpStrict { + bus_empty = return GM.empty, + bus_lookup = (\a b -> return $ fromJustNote "" $ GM.lookup a b), + bus_insert = (\a b c-> return $ GM.insert a b c) + } + +bottomUpStrictMap :: (Ord ind) => DPSolverSame Identity (BottomUpStrict ) M.Map ind cell +bottomUpStrictMap = bottomUpStrictGenMap + +bottomUpStrictMArray :: (Ix ind, MArray array int m) => (cell -> int) -> (int -> cell) -> (ind, ind) -> + DPSolver m BottomUpStrict array ind cell int +bottomUpStrictMArray toInternal fromInternal bounds = mkSolver $ BottomUpStrict { + bus_empty = newArray_ bounds, + bus_lookup = (\a b -> fromInternal `liftM` readArray b a), + bus_insert = (\i cell chart -> do {writeArray chart i (toInternal cell); return chart}) + } + + +bottomUpStrictSTUArray :: (MArray (STUArray s) int (ST s), Ix ind, Cell (Identity cell)) => + (cell -> int) -> (int -> cell) -> (ind, ind) -> + DPSolver (ST s) BottomUpStrict (STUArray s) ind (Identity cell) int +bottomUpStrictSTUArray toInternal fromInternal = bottomUpStrictMArray (\ (Identity a) -> toInternal a) (Identity . fromInternal) + + + diff --git a/Data/DP/Solvers/Recursive.hs b/Data/DP/Solvers/Recursive.hs new file mode 100644 --- /dev/null +++ b/Data/DP/Solvers/Recursive.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleContexts, FlexibleInstances, TypeFamilies, KindSignatures #-} + + +{-| + +Top-Down Recursive Solver. Solve the DP brute-force, no-frills by doing it recursively, i.e. without using a chart. + +/Advantages/ + + * Don't need to specify an ordering. + + * Useful for debugging, can compare directly to recursive function. + +/Disadvantages/ + + * A ridiculous way to solve a DP. For most non-trivial DPs, this will have exponential complexity. + +-} + +module Data.DP.Solvers.Recursive (recursive) where + +--{{{ +import Data.DP.Internals +import Data.DP.SolverInternal +import Data.Semiring +import qualified Data.Map as M +import Control.Monad.Identity +import Data.DP.SolverAPI +--}}} + +newtype Recursive (m :: * -> *) (ch :: * -> * -> *) i c int = Recursive { + empty :: (ch i int) + } + +recursive :: DPSolverSame monad Recursive M.Map index cell +recursive = mkSolver $ Recursive M.empty + +instance (Monad m, Cell cell) => SolveDP (DPSolver m Recursive ch ind cell internal) where + type Frame (DPSolver m Recursive ch ind cell internal) = ind + startSolver o (DPSolver (Recursive e)) last dp = do + res <- solveNaive last + return $ DPSolution res e + where solveNaive i = reduceBase o (dp i) solveNaive diff --git a/Data/DP/Solvers/TopDown.hs b/Data/DP/Solvers/TopDown.hs new file mode 100644 --- /dev/null +++ b/Data/DP/Solvers/TopDown.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleContexts, FlexibleInstances, TypeFamilies, KindSignatures #-} + +{-| + +Top-Down Memoization Solver. Solve the DP by doing it recursively, but save the intermediate results so they do not need to be recomputed. + +/Advantages/ + + * Lazy, both in a programming sense and in exploring the chart. + + * Don't need to specify an ordering. + +/Disadvantages/ + + * Hard to debug and profile, no specific ordering. + +-} + + +module Data.DP.Solvers.TopDown ( + -- * Predefined Solvers + topDownMap, + topDownGenMap, + -- * Custom Solvers + -- | You can define a custom TopDown solver by implementing + -- the @'TopDown'@ strategy and calling @mkSolver@ + + TopDown(..) + ) + +where + +--{{{ Imports +import Data.DP.Internals +import Data.DP.SolverInternal +import Data.Array.IArray +import qualified Data.Map as M +import qualified Data.ListTrie.Base.Map as GM +import Data.Semiring +import Safe +import Control.Monad.State.Strict +import Control.Monad.Identity +import Data.DP.SolverAPI +--}}} + +data TopDown m chart ind cell internal = TopDown { + td_lookupMaybe :: ind -> chart ind internal -> m (Maybe cell), + td_insert :: ind -> cell -> chart ind internal -> m (chart ind internal), + td_empty :: m (chart ind internal) + } + +instance (Monad m, Cell cell) => SolveDP (DPSolver m TopDown ch ind cell int) where + type Frame (DPSolver m TopDown ch ind cell int) = ind + startSolver o (DPSolver solver) last dp = do + init <- td_empty solver + res <- solveNaive last init + return $ DPSolution res init + where solveNaive i chart = reduceBaseWrite o (dp i) mylookup chart + mylookup i = do + dat <- get + let chart = dpData dat + look <- lift $ td_lookupMaybe solver i chart + case look of + Just a -> return a + Nothing -> + do + res <- lift $ solveNaive i chart + newchart <- lift $ td_insert solver i res chart + put $ dat{dpData = newchart} + return res + +topDownGenMap :: (GM.Map map ind, Monad m) => DPSolver m TopDown map ind cell cell +topDownGenMap = mkSolver $ TopDown { + td_empty = return $ GM.empty, + td_lookupMaybe = (\a b -> return $ GM.lookup a b), + td_insert = (\a b c -> return $ GM.insert a b c) + } + +topDownMap :: (Ord ind, Monad m) => DPSolver m TopDown M.Map ind cell cell +topDownMap = topDownGenMap diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain