summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndreiBarbu <>2015-10-19 22:49:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2015-10-19 22:49:00 (GMT)
commitefaf249ef0ef0c11612d54489e4c1e520132a825 (patch)
treef9d04e34cdb975fdad80d9fff1b7e282ca932cee
parenta6267d1b1b823fb571614323cd160991e29af86d (diff)
version 1.31.3
-rw-r--r--README.md71
-rw-r--r--csp.cabal20
-rw-r--r--src/Control/Monad/CSP.hs (renamed from Control/Monad/CSP.hs)11
-rw-r--r--tests/test.hs98
4 files changed, 163 insertions, 37 deletions
diff --git a/README.md b/README.md
index 6866268..a696b05 100644
--- a/README.md
+++ b/README.md
@@ -1,40 +1,51 @@
# CSP
-A simple example which solves Sudoku puzzles, project Euler problem 96.
-
- solveSudoku :: (Enum a, Eq a, Num a) => [[a]] -> [[a]]
- solveSudoku puzzle = oneCSPSolution $ do
- dvs <- mapM (mapM (\a -> mkDV $ if a == 0 then [1 .. 9] else [a])) puzzle
- mapM_ assertRowConstraints dvs
- mapM_ assertRowConstraints $ transpose dvs
- sequence_ [assertSquareConstraints dvs x y | x <- [0,3,6], y <- [0,3,6]]
- return dvs
- where assertRowConstraints = mapAllPairsM_ (constraint2 (/=))
- assertSquareConstraints dvs i j =
- mapAllPairsM_ (constraint2 (/=)) [(dvs !! x) !! y | x <- [i..i+2], y <- [j..j+2]]
-
- sudoku3 = [[0,0,0,0,0,0,9,0,7],
- [0,0,0,4,2,0,1,8,0],
- [0,0,0,7,0,5,0,2,6],
- [1,0,0,9,0,4,0,0,0],
- [0,5,0,0,0,0,0,4,0],
- [0,0,0,5,0,7,0,0,9],
- [9,2,0,1,0,8,0,0,0],
- [0,3,4,0,5,9,0,0,0],
- [5,0,7,0,0,0,0,0,0]]
-
- mapAllPairsM_ :: Monad m => (a -> a -> m b) -> [a] -> m ()
- mapAllPairsM_ f [] = return ()
- mapAllPairsM_ f (_:[]) = return ()
- mapAllPairsM_ f (a:l) = mapM_ (f a) l >> mapAllPairsM_ f l
-
- solveSudoku sudoku3
+This package is available via
+[Hackage where its documentation resides](https://hackage.haskell.org/package/csp). It
+provides a solver for constraint satisfaction problems by implementing
+a `CSP` monad. Currently it only implements arc consistency but other
+kinds of constraints will be added.
+Below is a Sudoku solver, project Euler problem 96.
+
+```haskell
+import Data.List
+import Control.Monad.CSP
+
+mapAllPairsM_ :: Monad m => (a -> a -> m b) -> [a] -> m ()
+mapAllPairsM_ f [] = return ()
+mapAllPairsM_ f (_:[]) = return ()
+mapAllPairsM_ f (a:l) = mapM_ (f a) l >> mapAllPairsM_ f l
+
+solveSudoku :: (Enum a, Eq a, Num a) => [[a]] -> [[a]]
+solveSudoku puzzle = oneCSPSolution $ do
+ dvs <- mapM (mapM (\a -> mkDV $ if a == 0 then [1 .. 9] else [a])) puzzle
+ mapM_ assertRowConstraints dvs
+ mapM_ assertRowConstraints $ transpose dvs
+ sequence_ [assertSquareConstraints dvs x y | x <- [0,3,6], y <- [0,3,6]]
+ return dvs
+ where assertRowConstraints = mapAllPairsM_ (constraint2 (/=))
+ assertSquareConstraints dvs i j =
+ mapAllPairsM_ (constraint2 (/=)) [(dvs !! x) !! y | x <- [i..i+2], y <- [j..j+2]]
+
+sudoku3 = [[0,0,0,0,0,0,9,0,7],
+ [0,0,0,4,2,0,1,8,0],
+ [0,0,0,7,0,5,0,2,6],
+ [1,0,0,9,0,4,0,0,0],
+ [0,5,0,0,0,0,0,4,0],
+ [0,0,0,5,0,7,0,0,9],
+ [9,2,0,1,0,8,0,0,0],
+ [0,3,4,0,5,9,0,0,0],
+ [5,0,7,0,0,0,0,0,0]]
+
+solveSudoku sudoku3
+```
+
## Future
- Docs!
- Allow a randomized execution order for CSPs
- - CSPs don't need use IO internally. ST is enough.
+ - CSPs don't need to use IO internally. ST is enough.
- Constraint synthesis. Already facilitated by the fact that
constraints are internally nondeterministic
- Other constraint types for CSPs, right now only AC is implemented
diff --git a/csp.cabal b/csp.cabal
index 97592d5..7d93a86 100644
--- a/csp.cabal
+++ b/csp.cabal
@@ -1,5 +1,5 @@
Name: csp
-Version: 1.0
+Version: 1.3
Description: Constraint satisfaction problem (CSP) solvers
License: LGPL
License-file: LICENSE
@@ -7,17 +7,27 @@ Author: Andrei Barbu <andrei@0xab.com>
Maintainer: Andrei Barbu <andrei@0xab.com>
Category: Control, AI, Constraints, Failure, Monads
Build-Type: Simple
-cabal-version: >= 1.6
+cabal-version: >= 1.10
synopsis:
- Discrete constraint satisfaction problem (CSP) solvers.
+ Discrete constraint satisfaction problem (CSP) solver.
extra-source-files: README.md
source-repository head
type: git
- location: git://github.com/abarbu/csp-haskell.git
+ location: http://github.com/abarbu/csp-haskell
Library
- Build-Depends: base >= 3 && < 5, mtl >= 2, containers, nondeterminism
+ Build-Depends: base >= 3 && < 5, mtl >= 2, containers, nondeterminism >= 1.4
Exposed-modules:
Control.Monad.CSP
ghc-options: -Wall
+ Hs-Source-Dirs: src
+ default-extensions: CPP
+ default-language: Haskell2010
+
+test-suite tests
+ type: exitcode-stdio-1.0
+ hs-source-dirs: tests
+ main-is: test.hs
+ build-depends: base >= 4 && < 5, tasty, tasty-hunit, nondeterminism, csp
+ default-language: Haskell2010
diff --git a/Control/Monad/CSP.hs b/src/Control/Monad/CSP.hs
index e611287..270df4c 100644
--- a/Control/Monad/CSP.hs
+++ b/src/Control/Monad/CSP.hs
@@ -99,6 +99,13 @@ data CSP r x = CSP { unCSP :: IORef [DVContainer r] -> IO x }
csp :: IO x -> CSP r x
csp x = CSP (\_ -> x)
+instance Functor (CSP r) where
+ fmap = liftM
+
+instance Applicative (CSP r) where
+ pure = return
+ (<*>) = ap
+
instance Monad (CSP r) where
CSP x >>= y = CSP (\s -> x s >>= (\(CSP z) -> z s) . y)
return a = CSP (\_ -> return a)
@@ -148,7 +155,7 @@ localWriteIORef ref new = do
restrictDomain :: DV r a -> ([a] -> IO [a]) -> AmbT r IO ()
restrictDomain dv f = do
l' <- lift (domain dv >>= f)
- when (null l') fail'
+ when (null l') empty
size <- lift $ domainSize dv
when (length l' < size) $ do
localWriteIORef (dvDomain dv) l'
@@ -193,7 +200,7 @@ constraint f dvl =
let loop [] es _ = f (reverse es)
loop (d:ds) es j | i == j = loop ds (d2e:es) (j + 1)
| otherwise = any (\e -> loop ds (e : es) (j + 1)) d
- in loop ddvl [] 0) d2))
+ in loop ddvl [] 1) d2))
$ zip dvl ([1..] :: [Int])))
$ zip dvl ([1..] :: [Int])
diff --git a/tests/test.hs b/tests/test.hs
new file mode 100644
index 0000000..80b5e34
--- /dev/null
+++ b/tests/test.hs
@@ -0,0 +1,98 @@
+import Test.Tasty
+import Test.Tasty.HUnit
+
+import Control.Monad.Amb
+import Control.Monad.CSP
+import Control.Monad
+import Data.List
+
+import System.IO.Unsafe
+
+main = defaultMain tests
+
+tests :: TestTree
+tests = testGroup "Tests" [unitTests]
+
+unitTests = testGroup "Unit tests"
+ [ testCase "constraint1" $
+ oneCSPSolution testC0 @?= 2
+ , testCase "constraint2 same type" $
+ oneCSPSolution testC1 @?= (5,4)
+ , testCase "constraint2 different types" $
+ oneCSPSolution testC2 @?= ("2",2)
+ , testCase "sudoku1" $
+ solveSudoku sudoku1 @?= [[4,8,3,9,2,1,6,5,7],[9,6,7,3,4,5,8,2,1],[2,5,1,8,7,6,4,9,3],[5,4,8,1,3,2,9,7,6],[7,2,9,5,6,4,1,3,8],[1,3,6,7,9,8,2,4,5],[3,7,2,6,8,9,5,1,4],[8,1,4,2,5,3,7,6,9],[6,9,5,4,1,7,3,8,2]]
+ , testCase "sudoku3" $
+ solveSudoku sudoku3 @?= [[4,6,2,8,3,1,9,5,7],[7,9,5,4,2,6,1,8,3],[3,8,1,7,9,5,4,2,6],[1,7,3,9,8,4,2,6,5],[6,5,9,3,1,2,7,4,8],[2,4,8,5,6,7,3,1,9],[9,2,6,1,7,8,5,3,4],[8,3,4,2,5,9,6,7,1],[5,1,7,6,4,3,8,9,2]]
+ , testCase "Euler p96" $
+ length p96 @?= 50
+ , testCase "Dinesman's dwellings" $
+ dinesmanDwellings @?= [[3,2,4,5,1]]
+ ]
+
+testC0 = do
+ a <- mkDV [1,2,5]
+ constraint1 (==2) a
+ return a
+
+testC1 = do
+ a <- mkDV [1,2,5]
+ b <- mkDV [10,4,7]
+ constraint2 (>) a b
+ return (a,b)
+
+testC2 = do
+ a <- mkDV ["1","2","5"]
+ b <- mkDV [3,2,7]
+ constraint2 (\a b -> read a == b) a b
+ return (a,b)
+
+-- Project Euler problem 96
+
+mapAllPairsM_ :: Monad m => (a -> a -> m b) -> [a] -> m ()
+mapAllPairsM_ f [] = return ()
+mapAllPairsM_ f (_:[]) = return ()
+mapAllPairsM_ f (a:l) = mapM_ (f a) l >> mapAllPairsM_ f l
+
+solveSudoku :: (Enum a, Eq a, Num a) => [[a]] -> [[a]]
+solveSudoku puzzle = oneCSPSolution $ do
+ dvs <- mapM (mapM (\a -> mkDV $ if a == 0 then [1 .. 9] else [a])) puzzle
+ mapM_ assertRowConstraints dvs
+ mapM_ assertRowConstraints $ transpose dvs
+ sequence_ [assertSquareConstraints dvs x y | x <- [0,3,6], y <- [0,3,6]]
+ return dvs
+ where assertRowConstraints = mapAllPairsM_ (constraint2 (/=))
+ assertSquareConstraints dvs i j =
+ mapAllPairsM_ (constraint2 (/=)) [(dvs !! x) !! y | x <- [i..i+2], y <- [j..j+2]]
+
+sudoku1 = [[0,0,3,0,2,0,6,0,0],[9,0,0,3,0,5,0,0,1],[0,0,1,8,0,6,4,0,0],[0,0,8,1,0,2,9,0,0],[7,0,0,0,0,0,0,0,8],[0,0,6,7,0,8,2,0,0],[0,0,2,6,0,9,5,0,0],[8,0,0,2,0,3,0,0,9],[0,0,5,0,1,0,3,0,0]]
+
+sudoku3 = [[0,0,0,0,0,0,9,0,7],[0,0,0,4,2,0,1,8,0],[0,0,0,7,0,5,0,2,6],[1,0,0,9,0,4,0,0,0],[0,5,0,0,0,0,0,4,0],[0,0,0,5,0,7,0,0,9],[9,2,0,1,0,8,0,0,0],[0,3,4,0,5,9,0,0,0],[5,0,7,0,0,0,0,0,0]]
+
+p96 :: [(Int, [[Int]])]
+p96 = let f = unsafePerformIO $ readFile "sudoku.txt"
+ in map (\(g:gs) -> (read $ drop 5 g, solveSudoku $ map (\g -> map (read . (:[])) g) gs))
+ $ groupBy (\a b -> not $ isPrefixOf "Grid" b) $ lines f
+
+dinesmanDwellings = allCSPSolutions $ do
+ baker <- mkDV [1..5]
+ cooper <- mkDV [1..5]
+ fletcher <- mkDV [1..5]
+ miller <- mkDV [1..5]
+ smith <- mkDV [1..5]
+ constraint1 (/= 5) baker
+ constraint1 (/= 1) cooper
+ constraint1 (\x -> x/=1 && x/=5) fletcher
+ constraint2 (>) miller cooper
+ notAdjacent smith fletcher
+ notAdjacent fletcher cooper
+ constraint allDistinct [baker,cooper,fletcher,miller,smith]
+ return [baker,cooper,fletcher,miller,smith]
+
+notAdjacent a b = constraint2 (\x y -> abs (x - y) /= 1) a b
+
+allDistinct x = go x []
+ where go [] _ = True
+ go (x:xs) y
+ | x `elem` y = False
+ | otherwise = go xs (x:y)