HyloDP (empty) → 1.0.0

raw patch · 22 files changed

+1086/−0 lines, 22 filesdep +HyloDPdep +MemoTriedep +basesetup-changed

Dependencies added: HyloDP, MemoTrie, base, containers, hspec

Files

• CHANGELOG.md +5/−0
• HyloDP.cabal +109/−0
• LICENSE +29/−0
• README.md +34/−0
• Setup.lhs +3/−0
• examples/EditDistance.hs +39/−0
• examples/EditDistanceMain.hs +8/−0
• examples/Fibonacci.hs +15/−0
• examples/FibonacciMain.hs +4/−0
• examples/Knapsack.hs +74/−0
• examples/KnapsackMain.hs +10/−0
• examples/LongestCommonSubsequence.hs +21/−0
• examples/LongestCommonSubsequenceMain.hs +10/−0
• examples/Probability.hs +19/−0
• examples/RandomWalk.hs +45/−0
• examples/RandomWalkMain.hs +7/−0
• examples/TextSegmentation.hs +31/−0
• examples/TextSegmentationMain.hs +38/−0
• src/HyloDP.hs +43/−0
• src/HyloDP/Base.hs +197/−0
• src/HyloDP/Semiring.hs +240/−0
• test/Spec.hs +105/−0

@@ -0,0 +1,5 @@+# Changelog for [`HyloDP` package](https://github.com/DavidLlorens/HyloDP)++## 1.0.0++* Initial version.

@@ -0,0 +1,109 @@+cabal-version:       2.4++name:                HyloDP+version:             1.0.0+synopsis:            A package for  solving dynamic programming problems in Haskell+description:+      This package contains the library HyloDP for solving dynamic programming problems in Haskell, and six solved DP problems: Edit Distance, Fibonacci, Knapsack, Longest Common Subsequence, Random Walk and Text Segmentation.+      .+      The library HyloDP implements the code of the research article:+      .+      ['Easily solving dynamic programming problems in Haskell by memoization of hylomorphisms'](https://doi.org/10.1002/spe.2887) by D.Llorens and J.M. Vilar. Software: Practice and Experience (ISSN:1097-024X). 2020; 50: 2193–2211.+      .+      A preliminary version of the article can be downloaded from [here](https://repositori.uji.es/xmlui/bitstream/handle/10234/191226/71752.pdf?sequence=1).+homepage:            https://github.com/DavidLlorens/HyloDP+-- bug-reports:+license:             BSD-3-Clause+license-file:        LICENSE+author:              David Llorens <dllorens@uji.es>, Juan Miguel Vilar <jvilar@uji.es>+maintainer:          David Llorens <dllorens@uji.es>+copyright:           David Llorens and Juan Miguel Vilar, 2020+category:            Recursion, Dynamic Programming+extra-source-files:  README.md+stability:           experimental+build-type:          Simple+extra-source-files:+    CHANGELOG.md++source-repository head+  type:     git+  location: https://github.com/DavidLlorens/HyloDP.git++common shared-properties+  default-language: Haskell2010+  build-depends:+    base >= 4.7 && < 5,+    MemoTrie >= 0.6.11 && < 0.7+  -- ghc-options: -Wall++library+    import: shared-properties+    exposed-modules:+        HyloDP.Base+        HyloDP.Semiring+        HyloDP+    hs-source-dirs: src++executable EditDistanceMain+    import: shared-properties+    main-is: EditDistanceMain.hs+    other-modules: EditDistance+    build-depends: HyloDP -any+    hs-source-dirs: examples++executable FibonacciMain+    import: shared-properties+    main-is: FibonacciMain.hs+    other-modules: Fibonacci+    build-depends: HyloDP -any+    hs-source-dirs: examples++executable TextSegmentationMain+    import: shared-properties+    main-is: TextSegmentationMain.hs+    other-modules: TextSegmentation, Probability+    build-depends:+        containers >= 0.6 && < 0.7,+        HyloDP -any+    hs-source-dirs: examples++executable KnapsackMain+    import: shared-properties+    main-is: KnapsackMain.hs+    other-modules: Knapsack+    build-depends: HyloDP -any+    hs-source-dirs: examples++executable RandomWalkMain+    import: shared-properties+    main-is: RandomWalkMain.hs+    other-modules: RandomWalk, Probability+    build-depends: HyloDP -any+    hs-source-dirs: examples++executable LongestCommonSubsequenceMain+    import: shared-properties+    main-is: LongestCommonSubsequenceMain.hs+    other-modules: LongestCommonSubsequence+    build-depends: HyloDP -any+    hs-source-dirs: examples++test-suite spec+  import: shared-properties+  type: exitcode-stdio-1.0+  other-modules:+    Fibonacci,+    Knapsack,+    EditDistance,+    LongestCommonSubsequence,+    Probability+    RandomWalk,+    TextSegmentation+  hs-source-dirs:+    test,+    examples+  main-is: Spec.hs+  build-depends:+    containers >= 0.6 && < 0.7,+    hspec >= 2.0 && < 3.0,+    HyloDP

@@ -0,0 +1,29 @@+BSD 3-Clause License++Copyright (c) 2020, Universitat Jaume I de Castelló, Spain+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this+   list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright notice,+   this list of conditions and the following disclaimer in the documentation+   and/or other materials provided with the distribution.++3. Neither the name of the copyright holder nor the names of its+   contributors may be used to endorse or promote products derived from+   this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,34 @@+# HyloDP+A package for  solving dynamic programming problems in Haskell++## Introduction+This package contains the library HyloDP and six solved DP problems: Edit Distance, Fibonacci, Knapsack, Longest Common Subsequence, Random Walk and Text Segmentation.++This package contains the code of the research article:+Software: Practice and Experience (ISSN:1097-024X)+>"Easily solving dynamic programming problems in Haskell by memoization of hylomorphisms" by D.Llorens and J.M. Vilar. Software: Practice and Experience (ISSN:1097-024X). 2020; 50: 2193–2211. [https://doi.org/10.1002/spe.2887](https://doi.org/10.1002/spe.2887).++A preliminary version of the paper can be downloaded from [here](https://repositori.uji.es/xmlui/bitstream/handle/10234/191226/71752.pdf?sequence=1).++The core ideas are:++* Using hylomorphisms as generic control flow mechanism.++* Adding memoization to avoid recomputation of intermediate results.++* Modelling the composition of solutions by means of semirings.++* Using dispatch by result type as a simple way to decide the+kind of answer desired (e.g. the best+solution, the score of that solution, or the total number of+solutions.)++A problem is described by an instance of `DPProblem` and solved by+using `dpSolve`. See the documentation of `HyloDP.Base` for an+example.+## Contents+* The library is contained in the [src](https://github.com/DavidLlorens/HyloDP/tree/master/src) directory.+* The [test](https://github.com/DavidLlorens/HyloDP/tree/master/test) directory contains several HSpec tests.+* There are six examples in the [examples](https://github.com/DavidLlorens/HyloDP/tree/master/examples) directory.+* The  `run-examples.sh` script runs all the examples.+* This library is implemented as a package [on Hackage](https://hackage.haskell.org/package/HyloDP-1.0.0/candidate).

@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain

@@ -0,0 +1,39 @@+module EditDistance where++-- * A classical Dynamic Programing problem.+--+-- $EditDistance+-- Edit distance is a way of quantifying how dissimilar two strings (e.g., words)+-- are to one another by counting the minimum number of operations required to+-- transform one string into the other.++import HyloDP+import Data.Maybe(fromJust)++type EDProblem = (String, String)+type Distance = Int++data EDOperation = Ins Char | Del Char | Replace Char Char | Keep Char deriving (Eq, Show)++-- Create DPProblem++edDPProblem :: EDProblem -> DPProblem EDProblem (TMin Distance) EDOperation+edDPProblem p = DPProblem p isTrivial subproblems+  where+    isTrivial = ( == ([], []))+    subproblems (x:xs, []) = [(TMin 1, Del x, (xs, []))]+    subproblems ([], y:ys) = [(TMin 1, Ins y, ([], ys))]+    subproblems (x:xs, y:ys) = [ (s, op, (xs, ys))+                               , (TMin 1, Del x, (x:xs, ys))+                               , (TMin 1, Ins y, (xs, y:ys))]+      where+        s = TMin $ if x == y then 0 else 1+        op = if x == y then Keep x else Replace x y++-- solvers++ed :: String -> String -> Distance+ed xs ys = let (TMin sol) = dpSolve $ edDPProblem (xs, ys) in sol++edOps :: String -> String -> ([EDOperation], Distance)+edOps xs ys = let (BestSolution ops (TMin score)) = dpSolve $ edDPProblem (xs, ys) in (fromJust ops, score)

@@ -0,0 +1,8 @@+import EditDistance++main :: IO ()+main = do+  let x = "train"+      y = "basin"+  print $ ed x y     -- just the distance+  print $ edOps x y  -- the seq. of edition operations and the distance

@@ -0,0 +1,15 @@+module Fibonacci where++import HyloDP++data Fib a = Base | Pair a a++instance Functor Fib where+  fmap _ Base = Base+  fmap f (Pair a b) = Pair (f a) (f b)++fibDPProblem :: Int -> DPProblem Int Integer ()+fibDPProblem n = DPProblem n (<= 2) (\n -> [(1, (), n-1), (1, (), n-2)])++fib :: Int -> Integer+fib n = dpSolve $ fibDPProblem n

@@ -0,0 +1,4 @@+import Fibonacci++main :: IO ()+main = print $ fib 100

@@ -0,0 +1,74 @@+-- For HasTrie:+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++module Knapsack where++import Data.MemoTrie+import GHC.Generics(Generic)+import Data.Maybe(fromJust)++import HyloDP++type Capacity = Int+type Value = Int+type Weight = Int+data Item = Item { value :: Value, weight :: Weight } deriving (Eq, Show)+data KSProblem = KSP { capacity :: Capacity, items :: [Item] }++-- HasTrie instances for Item and KSProblem++deriving instance Generic Item++instance HasTrie Item where+  newtype (Item :->: b) = ItemTrie { unItemTrie :: Reg Item :->: b }+  trie = trieGeneric ItemTrie+  untrie = untrieGeneric unItemTrie+  enumerate = enumerateGeneric unItemTrie++deriving instance Generic KSProblem++instance HasTrie KSProblem where+  newtype (KSProblem :->: b) = KSTrie { unKSTrie :: Reg KSProblem :->: b }+  trie = trieGeneric KSTrie+  untrie = untrieGeneric unKSTrie+  enumerate = enumerateGeneric unKSTrie++-- Create DPProblem++ksDPProblem :: KSProblem -> DPProblem KSProblem Value (Maybe Item)+ksDPProblem p = DPProblem p isTrivial subproblems+  where+    isTrivial = null . items+    subproblems (KSP c (i:is))+      | value i <= c = [(0, Nothing, KSP c is) , (value i, Just i, (KSP (c-weight i) is))]+      | otherwise = [(0, Nothing, KSP c is)]+++-- solvers++ks :: Capacity -> [Item] -> Value+ks capacity items = let (TMax v) = dpSolve problem  in v+  where+    kpDPP = KSP capacity items+    problem = ksDPProblem kpDPP++ksItems :: Capacity -> [Item] -> ([Item], Value)+ksItems capacity items = let (BestSolution sol (TMax v)) = dpSolve problem  in (fromJust sol, v)+  where+    kpDPP = KSP capacity items+    problem = ksDPProblem kpDPP++ksCount :: Capacity -> [Item] -> Integer+ksCount capacity items = let Count n = dpSolve problem in n+  where+    kpDPP = KSP capacity items+    problem = ksDPProblem kpDPP++ksAllSols :: Capacity -> [Item] -> [([Item], TMax Value)]+ksAllSols capacity items = let AllSolutions sols = dpSolve problem in sols+  where+    kpDPP = KSP capacity items+    problem = ksDPProblem kpDPP

@@ -0,0 +1,10 @@+import Knapsack++main :: IO ()+main = do+  let capacity = 100+      items = [Item 20 40, Item 30 20, Item 40 50, Item 50 60, Item 20 10]+  print $ ks capacity items+  print $ ksItems capacity items+  print $ ksCount capacity items+  print $ ksAllSols capacity items

@@ -0,0 +1,21 @@+module LongestCommonSubsequence where++import HyloDP++-- Create DPProblem++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))+                        ]++-- solver++lcs :: String -> String -> String+lcs xs ys = let+       sol = dpSolve $ lcsDPProblem xs ys :: BestSolution Char (TMax Int)+    in decisions sol

@@ -0,0 +1,10 @@+import LongestCommonSubsequence+import HyloDP++main :: IO ()+main = do+  print (dpSolve $ lcsDPProblem "train" "raising" :: BestSolution Char (TMax Int))+  print (dpSolve $ lcsDPProblem "train" "raising" :: TMax Int)+  print $ lcs "train" "rain"+  print $ lcs "aliada" "alada"+  print $ lcs "abcd" "efg"

@@ -0,0 +1,19 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Probability where++import HyloDP.Semiring++newtype Probability = Probability Double deriving(Show, Eq, Ord, Fractional, Num)++instance Semiring Probability where+  (<+>) = (+)+  (<.>) = (*)+  zero = 0+  one = 1++instance Bounded Probability where+  maxBound = 1+  minBound = 0++

@@ -0,0 +1,45 @@+-- For HasTrie:+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++module RandomWalk where++import Data.MemoTrie+import GHC.Generics(Generic)++import HyloDP+import Probability++type Position = Int+type Step = Int++data RWProblem = RW { from :: Position, to :: Position, remaining :: Step } deriving Show++-- HasTrie instance for RWProblem++deriving instance Generic RWProblem++instance HasTrie RWProblem where+  newtype (RWProblem :->: b) = RWTrie { unRWTrie :: Reg RWProblem :->: b }+  trie = trieGeneric RWTrie+  untrie = untrieGeneric unRWTrie+  enumerate = enumerateGeneric unRWTrie++-- Create DPProblem++rwDPProblem :: RWProblem -> DPProblem RWProblem Probability ()+rwDPProblem p = DPProblem p isTrivial subproblems+  where isTrivial p = from p >= to p+        subproblems (RW _ _ 0) = []+        subproblems (RW p f s) = [ (0.5, (), RW (p + 1) f (s - 1))+                                 , (0.5, (), RW (p - 1) f (s - 1))+                                 ]++-- solver++rw :: Position -> Position -> Step -> Probability+rw from to rem = dpSolve problem+  where rwDPP = (RW from to rem)+        problem = rwDPProblem rwDPP

@@ -0,0 +1,7 @@+import RandomWalk++main :: IO ()+main = print $ rw from to remaining+  where from = 0+        to = 2+        remaining = 6

@@ -0,0 +1,31 @@+module TextSegmentation where++import Data.Map(Map)+import qualified Data.Map.Strict as M+import Data.List(inits, tails)++import HyloDP+import Probability++type Dictionary = Map String Probability++tsDPProblem :: Dictionary -> String -> DPProblem String Probability String+tsDPProblem d s = DPProblem s isTrivial subproblems+  where+    isTrivial = null+    subproblems s = [ (p, w, s')+                    | (w, s') <- tail $ zip (inits s) (tails s)+                    , Just p <- [M.lookup w d]+                    ]++ts :: Dictionary -> String -> (Maybe [String], Probability)+ts d s = (m, p)+  where BestSolution m (MaxProd p) = dpSolve $ tsDPProblem d s++tsCount :: Dictionary -> String -> Integer+tsCount d s = n+  where Count n = dpSolve $ tsDPProblem d s++tsAllSolutions :: Dictionary -> String -> [([String], Probability)]+tsAllSolutions d s = ls+  where AllSolutions ls = dpSolve $ tsDPProblem d s

@@ -0,0 +1,38 @@+import TextSegmentation+import Data.Map(fromList)++main :: IO ()+main = do+  let dictionary = fromList [ ("a", 0.05)+                          , ("acas", 0.01)+                          , ("as", 0.03)+                          , ("ca", 0.01)+                          , ("cas", 0.05)+                          , ("casaca", 0.05)+                          , ("de", 0.05)+                          , ("e", 0.02)+                          , ("la", 0.12)+                          , ("lacas", 0.05)+                          , ("nada", 0.07)+                          , ("sacad", 0.02)+                          , ("aca", 0.01)+                          , ("ad", 0.01)+                          , ("asa", 0.02)+                          , ("cadena", 0.06)+                          , ("casa", 0.08)+                          , ("da", 0.05)+                          , ("den", 0.02)+                          , ("en", 0.11)+                          , ("laca", 0.05)+                          , ("na", 0.01)+                          , ("saca", 0.05)+                          ]++  putStrLn "For 'ended':"+  print $ ts dictionary "ended"+  print $ tsCount dictionary "ended"++  putStrLn "For 'lacasacadenada':"+  print $ ts dictionary "lacasacadenada"+  print $ tsCount dictionary "lacasacadenada"+  print $ tsAllSolutions dictionary "lacasacadenada"

@@ -0,0 +1,43 @@+{-|+Module: HyloDP+Description: A simple and efficient solver for Dynamic Programming problems.+Copyright: (c) David Llorens and Juan Miguel Vilar, 2020+License: BSD-3-Clause+Stability: experimental++Practical implementation of a solver for Dynamic Programning problems.++This package contains the implementation of the research article:++* "Easily solving dynamic programming problems in Haskell by memoization of hylomorphisms" by D.Llorens and J.M. Vilar. Software: Practice and Experience (ISSN:1097-024X). 2020; 50: 2193– 2211. https://doi.org/10.1002/spe.2887++The core ideas are:++* Using hylomorphisms as generic control flow mechanism.++* Adding memoization to avoid recomputation of intermediate results.++* Modelling the composition of solutions by means of semirings.++* Using dispatch by result type as a simple way to decide the+kind of answer desired (e.g. the best+solution, the score of that solution, or the total number of+solutions.)++A problem is described by an instance of 'DPProblem' and solved by+using 'dpSolve'. See the documentation of 'HyloDP.Base' for an+example.+-}++module HyloDP+(+  -- * Exported modules+  -- **The DP problem solver+  module HyloDP.Base,+  -- **Semirings for different solution types+  module HyloDP.Semiring+)+where++import HyloDP.Base+import HyloDP.Semiring

@@ -0,0 +1,197 @@+{-# 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+     { initial :: p                     -- ^ The instance of the+                                        --   problem that has to be solved+     , isTrivial :: p -> Bool           -- ^ True if a problem is trivial+     , 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 = const++instance DPTypes sc d (TMin sc) where+    combine = const . TMin++instance DPTypes sc d (TMax sc) where+    combine = const . TMax++instance DPTypes sc d (MaxProd sc) where+    combine = const . MaxProd++instance DPTypes sc d Count where+    combine = const . const $ Count 1++instance DPTypes sc d sol => DPTypes sc d (BestSolution d sol) where+    combine sc d = BestSolution (Just [d]) (combine sc d)++instance DPTypes sc (Maybe d) sol => DPTypes sc (Maybe d) (BestSolution d sol) where+    combine sc d = BestSolution (Just $ maybeToList d) (combine sc d)++instance DPTypes sc d sol => DPTypes sc d (AllSolutions d sol) where+    combine sc d = AllSolutions [([d], combine sc d)]++instance DPTypes sc (Maybe d) sol => DPTypes sc (Maybe d) (AllSolutions d sol) where+    combine sc d = AllSolutions [(maybeToList d, combine sc d)]++instance DPTypes sc d sol => DPTypes sc d (AllBestSolutions d sol) where+    combine sc d = AllBestSolutions ([[d]], combine sc d)++instance DPTypes sc (Maybe d) sol => DPTypes sc (Maybe d) (AllBestSolutions d sol) where+    combine sc d = AllBestSolutions ([maybeToList d], combine sc d)++instance (DPTypes sc d sol, DPTypes sc d sol') => DPTypes sc d (sol, sol') where+    combine sc d = (combine sc d, combine sc 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 alg coalg = h+     where h = alg . fmap h . coalg++-- | The hylomorphism implementation with memoization+hyloM :: (Functor f, HasTrie s) => Algebra f t -> Coalgebra f s -> s -> t+hyloM alg coalg = h+     where h = memo $ alg . fmap h . coalg++-- | The 'Functor' needed by our algebra and coalgebra+data DPF sc p = Trivial | Children [(sc, p)] deriving 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 dp = hyloM solve build $ initial dp+  where build p | isTrivial dp p = Trivial+                | otherwise = Children [(combine sc d, sp) |+                                        (sc, d, sp) <- subproblems dp p]+        solve Trivial = one+        solve (Children sols) =+           foldl' (<+>) zero [ sc <.> sol | (sc, sol) <- sols ]

@@ -0,0 +1,240 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++{-|+Module: HyloDP.Semiring+Description: Declaration of the Semiring class and various instances+Copyright: (c) David Llorens and Juan Miguel Vilar, 2020+License: BSD-3-Clause+Stability: experimental++This module declares the 'Semiring' class and various instances.+-}+module HyloDP.Semiring (+  -- *Type Classes+  Semiring(..),+  Opt(..),+  -- *Semiring Helpers+  -- ** Min tropical semiring+  TMin(..),+  -- ** Max tropical semiring+  TMax(..),+  -- ** Min product semiring+  MinProd(..),+  -- ** Max product semiring+  MaxProd(..),+  -- ** Count semiring+  Count(..),+  -- ** Best solution semiring+  BestSolution(..),+  -- ** All solutions semiring+  AllSolutions(..),+  -- ** All best solutions semiring+  AllBestSolutions(..),+  -- * Other functions+  decisions+) where++import Data.Maybe(fromJust)++-- ----------------------+-- Typeclass definitions+-- ----------------------++{- | A 'Semiring' is a type with two operations '<+>' and '<.>' and two+distinguished elements, 'zero' and 'one', which satisfy the following+axioms:++* Conmutativity:++> a <+> b == b <+> a+> a <.> b == b <.> a++* Associativity:++> a <+> (b <+> c) == (a <+> b) <+> c+> a <.> (b <.> c) == (a <.> b) <.> c++* Identity:++> a <+> zero = zero <+> a == a+> a <.> one = one <.> a == a++* Distributive property:++> a <.> (b<+>c) == (a<.>b) <+> (a<.>c)+> (a<+>b) <.>c == (a<.>c) <+> (b<.>c)++* Anhiliation of multiplication by zero:++> a <.> zero = zero <.> a = zero+-}+class Semiring s where+    infixl 6 <+>+    (<+>) :: s -> s -> s+    infixl 7 <.>+    (<.>) :: s -> s -> s+    -- |Neutral element for '<+>'.+    zero  :: s+    -- |Neutral element for '<.>'.+    one   :: s++-- | This typeclass is used in optimization semirings. It is expected+-- that @optimum a b@ returns either @a@ or @b@.+class Opt t where+  optimum :: t -> t -> t++-- --------------------+-- Semiring definitions+-- --------------------++-- Number instances++instance Semiring Int  where+  (<+>) = (+)+  (<.>) = (*)+  zero = 0+  one = 1++instance Semiring Integer  where+  (<+>) = (+)+  (<.>) = (*)+  zero = 0+  one = 1++instance Semiring Float  where+  (<+>) = (+)+  (<.>) = (*)+  zero = 0+  one = 1++instance Semiring Double  where+  (<+>) = (+)+  (<.>) = (*)+  zero = 0+  one = 1++-- |The tropical min semiring, a semiring that uses 'min' as '<+>' and+-- sum as '<.>'. It is used in problems that ask for minimizing a sum of+-- values.+newtype TMin v = TMin v deriving (Eq, Ord, Show)++-- |The tropical max semiring, a semiring that uses 'max' as '<+>' and+-- sum as '<.>'. It is used in problems that ask for maximizing a sum of+-- values.+newtype TMax v = TMax v deriving (Eq, Ord, Show)++instance (Num v, Ord v, Bounded v) => Semiring (TMin v) where+  t1 <+> t2 = min t1 t2+  t1@(TMin v1) <.> t2@(TMin v2)+    | t1 == zero = zero+    | t2 == zero = zero+    | otherwise = TMin (v1 + v2)+  zero = TMin maxBound+  one = TMin 0++instance (Num v, Ord v, Bounded v) => Semiring (TMax v) where+  t1 <+> t2 = max t1 t2+  t1@(TMax v1) <.> t2@(TMax v2)+    | t1 == zero = zero+    | t2 == zero = zero+    | otherwise = TMax (v1 + v2)+  zero = TMax minBound+  one = TMax 0++instance Ord v => Opt (TMin v) where+  optimum = min++instance Ord v => Opt (TMax v) where+  optimum = max++-- | The 'MinProd' semiring is the analogous to the 'TMin' semiring+-- for minimizing products.+newtype MinProd v = MinProd v deriving (Eq, Ord, Show)++instance (Num v, Ord v, Bounded v) => Semiring (MinProd v) where+  t1 <+> t2 = max t1 t2+  t1@(MinProd v1) <.> t2@(MinProd v2)+    | t1 == zero = zero+    | t2 == zero = zero+    | otherwise = MinProd (v1 * v2)+  zero = MinProd maxBound+  one = MinProd 1++instance Ord v => Opt (MinProd v) where+  optimum = min++-- | The 'MaxProd' semiring is the analogous to the 'TMax' semiring+-- for maximizing products.+newtype MaxProd v = MaxProd v deriving (Eq, Ord, Show)++instance (Num v, Ord v, Bounded v) => Semiring (MaxProd v) where+  t1 <+> t2 = max t1 t2+  t1@(MaxProd v1) <.> t2@(MaxProd v2)+    | t1 == zero = zero+    | t2 == zero = zero+    | otherwise = MaxProd (v1 * v2)+  zero = MaxProd minBound+  one = MaxProd 1++instance Ord v => Opt (MaxProd v) where+  optimum = max++-- |The 'Count' semiring is used for counting the number of different+-- solutions.+newtype Count = Count Integer deriving Show++instance Semiring Count where+  Count n <+> Count n' = Count $ n + n'+  Count n <.> Count n' = Count $ n * n'+  zero = Count 0+  one = Count 1++-- |The `BestSolution` semiring is used for recovering the best sequence+-- of decisions together with its score. The score must be an instance of+-- 'Opt' to be able to decide which is the best of two scores.+data BestSolution d sc = BestSolution (Maybe [d]) sc deriving (Eq, Show)++instance (Semiring sc, Opt sc, Eq sc) => Semiring (BestSolution d sc) where+    sol1@(BestSolution _ sc1) <+> sol2@(BestSolution _ sc2)+       | optimum sc1 sc2 == sc1 = sol1+       | otherwise = sol2+    BestSolution ds1 sc1 <.> BestSolution ds2 sc2 =+       BestSolution ((++) <$> ds1 <*> ds2) (sc1 <.> sc2)+    zero = BestSolution Nothing zero+    one = BestSolution (Just []) one++-- |Auxiliary function to recover the sequence of decisions from a `BestSolution`+decisions :: BestSolution d sc -> [d]+decisions (BestSolution s _) = fromJust s++-- |With the 'AllSolutions' semiring it is possible to recover all possible+-- solutions to a problem, regardless of their scores.+newtype AllSolutions d sc = AllSolutions [([d], sc)] deriving Show++instance Semiring sc => Semiring (AllSolutions d sc) where+  AllSolutions sols1 <+> AllSolutions sols2 = AllSolutions (sols1 ++ sols2)+  AllSolutions sols1 <.> AllSolutions sols2 =+    AllSolutions [ (ds1 ++ ds2, sc1 <.> sc2) +                 | (ds1, sc1) <- sols1, (ds2, sc2) <- sols2]+  zero = AllSolutions []+  one = AllSolutions [([], one)]++-- |With the 'AllBestSolutions' semiring it is possible to recover all the+-- solutions to a problem that reach the optimum score.+newtype AllBestSolutions d s = AllBestSolutions ([[d]], s) deriving Show++instance (Semiring sc, Opt sc, Eq sc) => Semiring (AllBestSolutions d sc) where+  a1@(AllBestSolutions (sols1, sc1)) <+> a2@(AllBestSolutions (sols2, sc2))+    | sc1 == sc2 = AllBestSolutions (sols1 ++ sols2, sc1)+    | optimum sc1 sc2 == sc1 = a1+    | otherwise = a2+  AllBestSolutions (sols1, sc1) <.> AllBestSolutions (sols2, sc2) =+    AllBestSolutions ((++) <$> sols1 <*> sols2, sc1 <.> sc2)+  zero = AllBestSolutions ([], zero)+  one = AllBestSolutions ([[]], one)++instance (Semiring s1, Semiring s2) => Semiring (s1, s2) where+  (s1, s2) <+> (s1', s2') = (s1 <+> s1', s2 <+> s2')+  (s1, s2) <.> (s1', s2') = (s1 <.> s1', s2 <.> s2')+  zero = (zero, zero)+  one = (one, one)

@@ -0,0 +1,105 @@+import Test.Hspec+import Control.Exception (evaluate)+import Control.Monad (forM_)++-- For TextSegmentation+import Data.Map(fromList)++import Probability++import HyloDP+import Fibonacci+import Knapsack+import EditDistance+import LongestCommonSubsequence+import RandomWalk+import TextSegmentation++testFibonacci =+  describe "Fibonacci" $ do+    let problem = fibDPProblem 100+    it "returns 100th Fibonacci number" $ do+        (dpSolve problem :: Integer) `shouldBe` (354224848179261915075 :: Integer)++testKnapsack=+  describe "Knapsack" $ do+    let capacity = 100+        items = [Item 20 40, Item 30 20, Item 40 50, Item 50 60, Item 20 10]+        kpDPP = KSP capacity items+        problem = ksDPProblem kpDPP+    it "best score" $ do+        (dpSolve problem :: TMax Value) `shouldBe` (TMax 100)+    it "best solution" $ do+        (dpSolve problem :: BestSolution Item (TMax Value)) `shouldBe`+            (BestSolution (Just [Item {value = 30, weight = 20},Item {value = 50, weight = 60},Item {value = 20, weight = 10}]) (TMax 100))++testEditDistance =+  describe "EditDistance" $ do+    let x = "train"+        y = "basin"+        edDPP = (x, y)+        problem = edDPProblem edDPP+    it "ed \"train\" \"basin\"" $ do+        (ed x y) `shouldBe` 3+    it "dpSolve problem :: TMin Int" $ do+        (dpSolve problem :: TMin Int) `shouldBe` (TMin 3)+    it "dpSolve problem :: BestSolution EDOperation (TMin Int)" $ do+        (dpSolve problem :: BestSolution EDOperation (TMin Int)) `shouldBe`+            (BestSolution (Just [Replace 't' 'b',Replace 'r' 'a',Replace 'a' 's',Keep 'i',Keep 'n']) (TMin 3))++testLongestCommonSubsequence =+  describe "LongestCommonSubsequence" $ do+    forM_ [("train", "rain", "rain"), ("aliada", "alada", "alada"), ("abcd", "efg", "")] $ \(xs, ys, sol) ->+      it ("For: " ++ show xs ++ " " ++ show ys) $ do+        (dpSolve $ lcsDPProblem xs ys :: BestSolution Char (TMax Int)) `shouldBe` (BestSolution (Just sol) (TMax $ length sol))++testRandomWalk =+  describe "RandomWalk" $ do+    let rwDPP = (RW 0 2 6)+        problem = rwDPProblem rwDPP+    it "Probability" $ do+        (dpSolve problem :: Probability) `shouldBe` (Probability 0.453125)++testTextSegmentation =+  describe "TextSegmentation" $ do+    let dictionary = fromList [ ("a", 0.05)+                          , ("acas", 0.01)+                          , ("as", 0.03)+                          , ("ca", 0.01)+                          , ("cas", 0.05)+                          , ("casaca", 0.05)+                          , ("de", 0.05)+                          , ("e", 0.02)+                          , ("la", 0.12)+                          , ("lacas", 0.05)+                          , ("nada", 0.07)+                          , ("sacad", 0.02)+                          , ("aca", 0.01)+                          , ("ad", 0.01)+                          , ("asa", 0.02)+                          , ("cadena", 0.06)+                          , ("casa", 0.08)+                          , ("da", 0.05)+                          , ("den", 0.02)+                          , ("en", 0.11)+                          , ("laca", 0.05)+                          , ("na", 0.01)+                          , ("saca", 0.05)+                          ]+    it "best sol for 'lacasacadenada'" $ do+        let problem = tsDPProblem dictionary "lacasacadenada"+        (dpSolve problem :: BestSolution String (MaxProd Probability)) `shouldBe`+            (BestSolution (Just ["la","casa","cadena","da"]) (MaxProd (Probability 2.88e-5)))+    it "best sol for 'ended'" $ do+        let problem = tsDPProblem dictionary "ended"+        (dpSolve problem :: BestSolution String (MaxProd Probability)) `shouldBe`+            (BestSolution Nothing (MaxProd (Probability 0.0)))++main :: IO ()+main = hspec $ do+    testFibonacci+    testKnapsack+    testEditDistance+    testLongestCommonSubsequence+    testRandomWalk+    testTextSegmentation