diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Changelog for [`HyloDP` package](https://github.com/DavidLlorens/HyloDP) + +## 1.0.0 + +* Initial version. diff --git a/HyloDP.cabal b/HyloDP.cabal new file mode 100644 --- /dev/null +++ b/HyloDP.cabal @@ -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 , Juan Miguel Vilar +maintainer: David Llorens +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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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). diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/examples/EditDistance.hs b/examples/EditDistance.hs new file mode 100644 --- /dev/null +++ b/examples/EditDistance.hs @@ -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) diff --git a/examples/EditDistanceMain.hs b/examples/EditDistanceMain.hs new file mode 100644 --- /dev/null +++ b/examples/EditDistanceMain.hs @@ -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 diff --git a/examples/Fibonacci.hs b/examples/Fibonacci.hs new file mode 100644 --- /dev/null +++ b/examples/Fibonacci.hs @@ -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 diff --git a/examples/FibonacciMain.hs b/examples/FibonacciMain.hs new file mode 100644 --- /dev/null +++ b/examples/FibonacciMain.hs @@ -0,0 +1,4 @@ +import Fibonacci + +main :: IO () +main = print $ fib 100 diff --git a/examples/Knapsack.hs b/examples/Knapsack.hs new file mode 100644 --- /dev/null +++ b/examples/Knapsack.hs @@ -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 diff --git a/examples/KnapsackMain.hs b/examples/KnapsackMain.hs new file mode 100644 --- /dev/null +++ b/examples/KnapsackMain.hs @@ -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 diff --git a/examples/LongestCommonSubsequence.hs b/examples/LongestCommonSubsequence.hs new file mode 100644 --- /dev/null +++ b/examples/LongestCommonSubsequence.hs @@ -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 diff --git a/examples/LongestCommonSubsequenceMain.hs b/examples/LongestCommonSubsequenceMain.hs new file mode 100644 --- /dev/null +++ b/examples/LongestCommonSubsequenceMain.hs @@ -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" diff --git a/examples/Probability.hs b/examples/Probability.hs new file mode 100644 --- /dev/null +++ b/examples/Probability.hs @@ -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 + + diff --git a/examples/RandomWalk.hs b/examples/RandomWalk.hs new file mode 100644 --- /dev/null +++ b/examples/RandomWalk.hs @@ -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 diff --git a/examples/RandomWalkMain.hs b/examples/RandomWalkMain.hs new file mode 100644 --- /dev/null +++ b/examples/RandomWalkMain.hs @@ -0,0 +1,7 @@ +import RandomWalk + +main :: IO () +main = print $ rw from to remaining + where from = 0 + to = 2 + remaining = 6 diff --git a/examples/TextSegmentation.hs b/examples/TextSegmentation.hs new file mode 100644 --- /dev/null +++ b/examples/TextSegmentation.hs @@ -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 diff --git a/examples/TextSegmentationMain.hs b/examples/TextSegmentationMain.hs new file mode 100644 --- /dev/null +++ b/examples/TextSegmentationMain.hs @@ -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" diff --git a/src/HyloDP.hs b/src/HyloDP.hs new file mode 100644 --- /dev/null +++ b/src/HyloDP.hs @@ -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 diff --git a/src/HyloDP/Base.hs b/src/HyloDP/Base.hs new file mode 100644 --- /dev/null +++ b/src/HyloDP/Base.hs @@ -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 ] diff --git a/src/HyloDP/Semiring.hs b/src/HyloDP/Semiring.hs new file mode 100644 --- /dev/null +++ b/src/HyloDP/Semiring.hs @@ -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) diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -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