├── .gitignore ├── LICENSE ├── README.md ├── backtracking.cabal ├── sample └── perm2.hs ├── src └── Control │ └── Monad │ └── Search.hs └── test ├── Spec.hs └── test.hs /.gitignore: -------------------------------------------------------------------------------- 1 | dist/ 2 | dist-newstyle/ 3 | .hsenv/ 4 | *.o 5 | *.hi 6 | cabal.project.local 7 | .cabal-sandbox/ 8 | cabal.sandbox.config 9 | .stack-work/ 10 | .ghc.environment.* 11 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright 2020 coord_e, Satoshi Egi 2 | 3 | Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 4 | 5 | 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 6 | 7 | 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. 8 | 9 | 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. 10 | 11 | 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. 12 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Backtracking Monad 2 | 3 | This library provides a backtracking monad following Spivey's paper "Algebras for combinatorial search". 4 | 5 | ## Getting Started 6 | 7 | The backtracking monad can be used in the similar way as the list monad. 8 | We only need to specify a seach stragety (`dfs` or `bfs`) for the initial value and insert `fromList` and `toList` for conversion. 9 | ``` 10 | take 10 (toList (dfs [1..] >>= \ns -> fromList ns >>= \x -> fromList ns >>= \y -> pure (x, y))) 11 | -- [(1,1),(1,2),(1,3),(1,4),(1,5),(1,6),(1,7),(1,8),(1,9),(1,10)] 12 | 13 | take 10 (toList (bfs [1..] >>= \ns -> fromList ns >>= \x -> fromList ns >>= \y -> pure (x, y))) 14 | -- [(1,1),(1,2),(2,1),(1,3),(2,2),(3,1),(1,4),(2,3),(3,2),(4,1)] 15 | ``` 16 | 17 | ## Relationship with Egison Pattern Matching 18 | 19 | We create this library for implementing [Sweet Egison](https://github.com/egison/sweet-egison), a shallow embedding Egison pattern matching. 20 | For example, the match clause `[mc| $x : #(x + 10) : _ -> (x, x + 10) |]` is transformed as follows: 21 | ```haskell 22 | \ (mat_a5sV, tgt_a5sW) 23 | -> let (tmpM_a5sX, tmpM_a5sY) = (consM mat_a5sV) tgt_a5sW 24 | in 25 | ((fromList (((cons (GP, GP)) mat_a5sV) tgt_a5sW)) 26 | >>= 27 | (\ (tmpT_a5sZ, tmpT_a5t0) 28 | -> let x = tmpT_a5sZ in 29 | let (tmpM_a5t1, tmpM_a5t2) = (consM tmpM_a5sY) tmpT_a5t0 30 | in 31 | ((fromList (((cons (GP, WC)) tmpM_a5sY) tmpT_a5t0)) 32 | >>= 33 | (\ (tmpT_a5t3, tmpT_a5t4) 34 | -> ((fromList ((((value (x + 10)) ()) tmpM_a5t1) tmpT_a5t3)) 35 | >>= (\ () -> pure (x, x + 10))))))) 36 | ``` 37 | -------------------------------------------------------------------------------- /backtracking.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: >=1.10 2 | -- Initial package description 'backtracking.cabal' generated by 'cabal 3 | -- init'. For further documentation, see 4 | -- http://haskell.org/cabal/users-guide/ 5 | 6 | name: backtracking 7 | version: 0.1.0 8 | synopsis: A backtracking monad 9 | description: This library provides a backtracking monad following Spivey's paper "Algebras for combinatorial search". 10 | -- bug-reports: 11 | license: BSD3 12 | license-file: LICENSE 13 | author: coord_e, Satoshi Egi 14 | maintainer: Satoshi Egi 15 | -- copyright: 16 | category: Control 17 | build-type: Simple 18 | extra-source-files: CHANGELOG.md 19 | 20 | library 21 | hs-source-dirs: src 22 | exposed-modules: 23 | Control.Monad.Search 24 | build-depends: 25 | build-depends: 26 | base >=4.8 && <5 27 | , transformers 28 | default-language: Haskell2010 29 | default-extensions: 30 | DataKinds 31 | DefaultSignatures 32 | DerivingStrategies 33 | ExplicitForAll 34 | FlexibleContexts 35 | FlexibleInstances 36 | GeneralizedNewtypeDeriving 37 | LambdaCase 38 | MultiParamTypeClasses 39 | NamedFieldPuns 40 | PolyKinds 41 | RankNTypes 42 | ScopedTypeVariables 43 | StandaloneDeriving 44 | TupleSections 45 | TypeFamilies 46 | TypeOperators 47 | ghc-options: 48 | -Wall -Wno-type-defaults 49 | 50 | test-suite test 51 | type: exitcode-stdio-1.0 52 | hs-source-dirs: test 53 | main-is: test.hs 54 | ghc-options: 55 | -Wall -threaded -rtsopts -with-rtsopts=-N -Wno-type-defaults 56 | default-language: Haskell2010 57 | build-depends: 58 | base 59 | , primes 60 | , backtracking 61 | , tasty 62 | , tasty-hunit 63 | default-extensions: 64 | GADTs 65 | QuasiQuotes 66 | TemplateHaskell 67 | TypeApplications 68 | -- cabal-fmt: expand test 69 | other-modules: Spec 70 | build-tool-depends: tasty-discover:tasty-discover -any 71 | -------------------------------------------------------------------------------- /sample/perm2.hs: -------------------------------------------------------------------------------- 1 | import Control.Monad.Search 2 | import Data.List 3 | import Data.Maybe 4 | import System.Environment 5 | 6 | 7 | perm2 :: [a] -> [(a, a)] 8 | perm2 xs = toList $ dfs xs >>= fromList . tails >>= (\xs' -> fromList (maybeToList (uncons xs'))) >>= \(x, ys) -> fromList (tails ys) >>= (\ys' -> fromList (maybeToList (uncons ys))) >>= \(y, _) -> pure (x, y) 9 | 10 | main = do 11 | [n] <- getArgs 12 | let n' = read n :: Int 13 | print $ length $ perm2 [1..n'] 14 | -------------------------------------------------------------------------------- /src/Control/Monad/Search.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- 3 | -- Module: Control.Monad.Search 4 | -- Description: Monad for backtracking 5 | -- Stability: experimental 6 | 7 | module Control.Monad.Search 8 | ( MonadSearch(..) 9 | , dfs 10 | , bfs 11 | ) 12 | where 13 | 14 | import Control.Applicative ( Alternative(..) ) 15 | import Control.Monad ( ap, MonadPlus(..) ) 16 | 17 | -- | 'MonadSearch' represents searches with backtracking. 18 | class MonadPlus m => MonadSearch m where 19 | fromList :: [a] -> m a 20 | toList :: m a -> [a] 21 | 22 | failure :: m a -> Bool 23 | default failure :: m a -> Bool 24 | failure m = null (toList m) 25 | lnot :: DFS a -> m () 26 | default lnot :: DFS a -> m () 27 | lnot m = if failure m then fromList [()] else mzero 28 | guard :: Bool -> m () 29 | default guard :: Bool -> m () 30 | guard t = if t then fromList [()] else mzero 31 | 32 | instance MonadSearch [] where 33 | {-# INLINE fromList #-} 34 | fromList = id 35 | {-# INLINE toList #-} 36 | toList = id 37 | 38 | type DFS a = [a] 39 | 40 | dfs :: a -> [a] 41 | dfs x = [x] 42 | 43 | -- | BFS implementation of 'MonadSearch'. 44 | newtype BFS a = BFS { unBFS :: [[a]] } 45 | 46 | instance Functor BFS where 47 | fmap f (BFS xss) = BFS $ map (\xs -> map f xs) xss 48 | 49 | instance Applicative BFS where 50 | pure = return 51 | (<*>) = ap 52 | 53 | instance Monad BFS where 54 | return x = BFS [[x]] 55 | BFS [] >>= _ = BFS [] 56 | BFS (xs:xss) >>= f = foldl mplus mzero (map f xs) `mplus` shift (BFS xss >>= f) 57 | where 58 | shift :: BFS a -> BFS a 59 | shift (BFS xss) = BFS ([] : xss) 60 | 61 | instance Alternative BFS where 62 | empty = mzero 63 | (<|>) = mplus 64 | 65 | instance MonadPlus BFS where 66 | mzero = BFS [] 67 | mplus (BFS xss) (BFS yss) = BFS (merge xss yss) 68 | where 69 | merge :: [[a]] -> [[a]] -> [[a]] 70 | merge [] [] = [] 71 | merge xss [] = xss 72 | merge [] yss = yss 73 | merge (xs:xss) (ys:yss) = (xs ++ ys) : merge xss yss 74 | 75 | instance MonadSearch BFS where 76 | fromList xs = BFS (map (\x -> [x]) xs) 77 | toList (BFS xss) = concat xss 78 | 79 | bfs :: a -> BFS a 80 | bfs x = BFS [[x]] 81 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | module Spec 2 | ( 3 | test_dfs 4 | , test_bfs 5 | ) 6 | where 7 | 8 | import Control.Monad.Search 9 | 10 | import Test.Tasty 11 | import Test.Tasty.HUnit 12 | 13 | 14 | splits :: [a] -> [([a], [a])] 15 | splits [] = [([], [])] 16 | splits (x:xs) = ([], x:xs) : map (\(as, ys) -> (x:as, ys)) (splits xs) 17 | 18 | 19 | get :: [a] -> [(a, [a])] 20 | get xs = map (\x -> (x, xs)) xs 21 | 22 | 23 | test_dfs :: [TestTree] 24 | test_dfs = 25 | [ 26 | testCase "splits" 27 | $ assertEqual "simple" [([], [1, 2]), ([1], [2]), ([1, 2], [])] 28 | $ toList $ dfs [1, 2] >>= fromList . splits >>= \(hs, ts) -> pure (hs, ts) 29 | , testCase "double cons" 30 | $ assertEqual "simple" [(1,1),(1,2),(1,3),(2,1),(2,2),(2,3),(3,1),(3,2),(3,3)] 31 | $ toList $ dfs [1, 2, 3] >>= fromList . get >>= \(x, xs) -> (fromList . get) xs >>= \(y, _) -> pure (x, y) 32 | ] 33 | 34 | test_bfs :: [TestTree] 35 | test_bfs = 36 | [ 37 | testCase "double cons" 38 | $ assertEqual "simple" [(1,1),(1,2),(2,1),(1,3),(2,2),(3,1),(2,3),(3,2),(3,3)] 39 | $ toList $ bfs [1, 2, 3] >>= fromList . get >>= \(x, xs) -> (fromList . get) xs >>= \(y, _) -> pure (x, y) 40 | , testCase "infinite double cons" 41 | $ assertEqual "simple" [(1,1),(1,2),(2,1),(1,3),(2,2),(3,1),(1,4),(2,3),(3,2)] 42 | $ take 9 $ toList $ bfs [1..] >>= fromList . get >>= \(x, xs) -> (fromList . get) xs >>= \(y, _) -> pure (x, y) 43 | , testCase "guard" 44 | $ assertEqual "simple" [(1,1),(2,2),(3,3),(4,4),(5,5),(6,6),(7,7),(8,8),(9,9)] 45 | $ take 9 $ toList $ bfs [1..] >>= fromList . get >>= \(x, xs) -> (fromList . get) xs >>= \(y, _) -> guard (x == y) >> pure (x, y) 46 | , testCase "not pattern" 47 | $ assertEqual "simple" [(1,2),(2,1),(1,3),(3,1),(1,4),(2,3),(3,2),(4,1),(1,5)] 48 | $ take 9 $ toList $ bfs [1..] >>= fromList . get >>= \(x, xs) -> (fromList . get) xs >>= \(y, _) -> lnot (guard (x == y) >> pure ()) >> pure (x, y) 49 | , testCase "not pattern in do notation" 50 | $ assertEqual "simple" [(1,2),(2,1),(1,3),(3,1),(1,4),(2,3),(3,2),(4,1),(1,5)] 51 | $ take 9 $ toList $ do 52 | (x, xs) <- bfs [1..] >>= fromList . get 53 | (y, _) <- (fromList . get) xs 54 | return () 55 | lnot (guard (x == y) >> pure ()) 56 | pure (x, y) 57 | ] 58 | 59 | -------------------------------------------------------------------------------- /test/test.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF tasty-discover #-} 2 | --------------------------------------------------------------------------------