DP (empty) → 0.1
raw patch · 16 files changed
+942/−0 lines, 16 filesdep +QuickCheckdep +arraydep +basesetup-changed
Dependencies added: QuickCheck, array, base, containers, list-tries, mtl, safe, semiring
Files
- DP.cabal +49/−0
- Data/DP.hs +169/−0
- Data/DP/Examples.hs +5/−0
- Data/DP/Examples/Bigram.hs +34/−0
- Data/DP/Examples/CheckerBoard.hs +61/−0
- Data/DP/Examples/Fibonacci.hs +72/−0
- Data/DP/Examples/HMM.hs +22/−0
- Data/DP/Internals.hs +112/−0
- Data/DP/SolverInternal.hs +52/−0
- Data/DP/Solvers.hs +15/−0
- Data/DP/Solvers/Beam.hs +40/−0
- Data/DP/Solvers/BottomUpLazy.hs +89/−0
- Data/DP/Solvers/BottomUpStrict.hs +97/−0
- Data/DP/Solvers/Recursive.hs +43/−0
- Data/DP/Solvers/TopDown.hs +80/−0
- Setup.hs +2/−0
+ DP.cabal view
@@ -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: <srush at mit dot edu>+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+
+ Data/DP.hs view
@@ -0,0 +1,169 @@++{-| A compact embedded language for specifying dynamic programs \(DPs\) for optimization.++<http://en.wikipedia.org/wiki/Dynamic_programming>++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)]
+ Data/DP/Examples.hs view
@@ -0,0 +1,5 @@+module Data.DP.Examples (+ module Data.DP.Examples.Fibonacci+) where ++import Data.DP.Examples.Fibonacci
+ Data/DP/Examples/Bigram.hs view
@@ -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
+ Data/DP/Examples/CheckerBoard.hs view
@@ -0,0 +1,61 @@+-- | Checkerboard problem from <http://en.wikipedia.org/wiki/Dynamic_programming>+-- 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)
+ Data/DP/Examples/Fibonacci.hs view
@@ -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 ++
+ Data/DP/Examples/HMM.hs view
@@ -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])
+ Data/DP/Internals.hs view
@@ -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
+ Data/DP/SolverInternal.hs view
@@ -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))
+ Data/DP/Solvers.hs view
@@ -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
+ Data/DP/Solvers/Beam.hs view
@@ -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
+ Data/DP/Solvers/BottomUpLazy.hs view
@@ -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++
+ Data/DP/Solvers/BottomUpStrict.hs view
@@ -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) +++
+ Data/DP/Solvers/Recursive.hs view
@@ -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
+ Data/DP/Solvers/TopDown.hs view
@@ -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
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain