├── LICENSE
├── README.md
├── Setup.lhs
├── csp.cabal
├── src
└── Control
│ └── Monad
│ └── CSP.hs
├── stack.yaml
├── sudoku.txt
└── tests
└── test.hs
/LICENSE:
--------------------------------------------------------------------------------
1 | GNU LESSER GENERAL PUBLIC LICENSE
2 | Version 3, 29 June 2007
3 |
4 | Copyright (C) 2007 Free Software Foundation, Inc.
5 | Everyone is permitted to copy and distribute verbatim copies
6 | of this license document, but changing it is not allowed.
7 |
8 |
9 | This version of the GNU Lesser General Public License incorporates
10 | the terms and conditions of version 3 of the GNU General Public
11 | License, supplemented by the additional permissions listed below.
12 |
13 | 0. Additional Definitions.
14 |
15 | As used herein, "this License" refers to version 3 of the GNU Lesser
16 | General Public License, and the "GNU GPL" refers to version 3 of the GNU
17 | General Public License.
18 |
19 | "The Library" refers to a covered work governed by this License,
20 | other than an Application or a Combined Work as defined below.
21 |
22 | An "Application" is any work that makes use of an interface provided
23 | by the Library, but which is not otherwise based on the Library.
24 | Defining a subclass of a class defined by the Library is deemed a mode
25 | of using an interface provided by the Library.
26 |
27 | A "Combined Work" is a work produced by combining or linking an
28 | Application with the Library. The particular version of the Library
29 | with which the Combined Work was made is also called the "Linked
30 | Version".
31 |
32 | The "Minimal Corresponding Source" for a Combined Work means the
33 | Corresponding Source for the Combined Work, excluding any source code
34 | for portions of the Combined Work that, considered in isolation, are
35 | based on the Application, and not on the Linked Version.
36 |
37 | The "Corresponding Application Code" for a Combined Work means the
38 | object code and/or source code for the Application, including any data
39 | and utility programs needed for reproducing the Combined Work from the
40 | Application, but excluding the System Libraries of the Combined Work.
41 |
42 | 1. Exception to Section 3 of the GNU GPL.
43 |
44 | You may convey a covered work under sections 3 and 4 of this License
45 | without being bound by section 3 of the GNU GPL.
46 |
47 | 2. Conveying Modified Versions.
48 |
49 | If you modify a copy of the Library, and, in your modifications, a
50 | facility refers to a function or data to be supplied by an Application
51 | that uses the facility (other than as an argument passed when the
52 | facility is invoked), then you may convey a copy of the modified
53 | version:
54 |
55 | a) under this License, provided that you make a good faith effort to
56 | ensure that, in the event an Application does not supply the
57 | function or data, the facility still operates, and performs
58 | whatever part of its purpose remains meaningful, or
59 |
60 | b) under the GNU GPL, with none of the additional permissions of
61 | this License applicable to that copy.
62 |
63 | 3. Object Code Incorporating Material from Library Header Files.
64 |
65 | The object code form of an Application may incorporate material from
66 | a header file that is part of the Library. You may convey such object
67 | code under terms of your choice, provided that, if the incorporated
68 | material is not limited to numerical parameters, data structure
69 | layouts and accessors, or small macros, inline functions and templates
70 | (ten or fewer lines in length), you do both of the following:
71 |
72 | a) Give prominent notice with each copy of the object code that the
73 | Library is used in it and that the Library and its use are
74 | covered by this License.
75 |
76 | b) Accompany the object code with a copy of the GNU GPL and this license
77 | document.
78 |
79 | 4. Combined Works.
80 |
81 | You may convey a Combined Work under terms of your choice that,
82 | taken together, effectively do not restrict modification of the
83 | portions of the Library contained in the Combined Work and reverse
84 | engineering for debugging such modifications, if you also do each of
85 | the following:
86 |
87 | a) Give prominent notice with each copy of the Combined Work that
88 | the Library is used in it and that the Library and its use are
89 | covered by this License.
90 |
91 | b) Accompany the Combined Work with a copy of the GNU GPL and this license
92 | document.
93 |
94 | c) For a Combined Work that displays copyright notices during
95 | execution, include the copyright notice for the Library among
96 | these notices, as well as a reference directing the user to the
97 | copies of the GNU GPL and this license document.
98 |
99 | d) Do one of the following:
100 |
101 | 0) Convey the Minimal Corresponding Source under the terms of this
102 | License, and the Corresponding Application Code in a form
103 | suitable for, and under terms that permit, the user to
104 | recombine or relink the Application with a modified version of
105 | the Linked Version to produce a modified Combined Work, in the
106 | manner specified by section 6 of the GNU GPL for conveying
107 | Corresponding Source.
108 |
109 | 1) Use a suitable shared library mechanism for linking with the
110 | Library. A suitable mechanism is one that (a) uses at run time
111 | a copy of the Library already present on the user's computer
112 | system, and (b) will operate properly with a modified version
113 | of the Library that is interface-compatible with the Linked
114 | Version.
115 |
116 | e) Provide Installation Information, but only if you would otherwise
117 | be required to provide such information under section 6 of the
118 | GNU GPL, and only to the extent that such information is
119 | necessary to install and execute a modified version of the
120 | Combined Work produced by recombining or relinking the
121 | Application with a modified version of the Linked Version. (If
122 | you use option 4d0, the Installation Information must accompany
123 | the Minimal Corresponding Source and Corresponding Application
124 | Code. If you use option 4d1, you must provide the Installation
125 | Information in the manner specified by section 6 of the GNU GPL
126 | for conveying Corresponding Source.)
127 |
128 | 5. Combined Libraries.
129 |
130 | You may place library facilities that are a work based on the
131 | Library side by side in a single library together with other library
132 | facilities that are not Applications and are not covered by this
133 | License, and convey such a combined library under terms of your
134 | choice, if you do both of the following:
135 |
136 | a) Accompany the combined library with a copy of the same work based
137 | on the Library, uncombined with any other library facilities,
138 | conveyed under the terms of this License.
139 |
140 | b) Give prominent notice with the combined library that part of it
141 | is a work based on the Library, and explaining where to find the
142 | accompanying uncombined form of the same work.
143 |
144 | 6. Revised Versions of the GNU Lesser General Public License.
145 |
146 | The Free Software Foundation may publish revised and/or new versions
147 | of the GNU Lesser General Public License from time to time. Such new
148 | versions will be similar in spirit to the present version, but may
149 | differ in detail to address new problems or concerns.
150 |
151 | Each version is given a distinguishing version number. If the
152 | Library as you received it specifies that a certain numbered version
153 | of the GNU Lesser General Public License "or any later version"
154 | applies to it, you have the option of following the terms and
155 | conditions either of that published version or of any later version
156 | published by the Free Software Foundation. If the Library as you
157 | received it does not specify a version number of the GNU Lesser
158 | General Public License, you may choose any version of the GNU Lesser
159 | General Public License ever published by the Free Software Foundation.
160 |
161 | If the Library as you received it specifies that a proxy can decide
162 | whether future versions of the GNU Lesser General Public License shall
163 | apply, that proxy's public statement of acceptance of any version is
164 | permanent authorization for you to choose that version for the
165 | Library.
166 |
--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
1 | # CSP
2 |
3 | [](https://circleci.com/gh/abarbu/csp-haskell/tree/master)
4 |
5 | This package is available via
6 | [Hackage where its documentation resides](https://hackage.haskell.org/package/csp). It
7 | provides a solver for constraint satisfaction problems by implementing
8 | a `CSP` monad. Currently it only implements arc consistency but other
9 | kinds of constraints will be added.
10 |
11 | Below is a Sudoku solver, project Euler problem 96.
12 |
13 | ```haskell
14 | import Data.List
15 | import Control.Monad.CSP
16 |
17 | mapAllPairsM_ :: Monad m => (a -> a -> m b) -> [a] -> m ()
18 | mapAllPairsM_ f [] = return ()
19 | mapAllPairsM_ f (_:[]) = return ()
20 | mapAllPairsM_ f (a:l) = mapM_ (f a) l >> mapAllPairsM_ f l
21 |
22 | solveSudoku :: (Enum a, Eq a, Num a) => [[a]] -> [[a]]
23 | solveSudoku puzzle = oneCSPSolution $ do
24 | dvs <- mapM (mapM (\a -> mkDV $ if a == 0 then [1 .. 9] else [a])) puzzle
25 | mapM_ assertRowConstraints dvs
26 | mapM_ assertRowConstraints $ transpose dvs
27 | sequence_ [assertSquareConstraints dvs x y | x <- [0,3,6], y <- [0,3,6]]
28 | return dvs
29 | where assertRowConstraints = mapAllPairsM_ (constraint2 (/=))
30 | assertSquareConstraints dvs i j =
31 | mapAllPairsM_ (constraint2 (/=)) [(dvs !! x) !! y | x <- [i..i+2], y <- [j..j+2]]
32 |
33 | sudoku3 = [[0,0,0,0,0,0,9,0,7],
34 | [0,0,0,4,2,0,1,8,0],
35 | [0,0,0,7,0,5,0,2,6],
36 | [1,0,0,9,0,4,0,0,0],
37 | [0,5,0,0,0,0,0,4,0],
38 | [0,0,0,5,0,7,0,0,9],
39 | [9,2,0,1,0,8,0,0,0],
40 | [0,3,4,0,5,9,0,0,0],
41 | [5,0,7,0,0,0,0,0,0]]
42 |
43 | solveSudoku sudoku3
44 | ```
45 |
46 | ## Future
47 |
48 | - Allow a randomized execution order for CSPs
49 | - CSPs don't need to use IO internally. ST is enough.
50 | - Constraint synthesis. Already facilitated by the fact that
51 | constraints are internally nondeterministic
52 | - Other constraint types for CSPs, right now only AC is implemented
53 | - n-ary heterogeneous constraints
54 |
--------------------------------------------------------------------------------
/Setup.lhs:
--------------------------------------------------------------------------------
1 | #! /usr/bin/env runhaskell
2 |
3 | > import Distribution.Simple
4 | > main = defaultMain
5 |
--------------------------------------------------------------------------------
/csp.cabal:
--------------------------------------------------------------------------------
1 | Name: csp
2 | Version: 1.4.0
3 | Description: Constraint satisfaction problem (CSP) solvers
4 | License: LGPL
5 | License-file: LICENSE
6 | Author: Andrei Barbu
7 | Maintainer: Andrei Barbu
8 | Category: Control, AI, Constraints, Failure, Monads
9 | Build-Type: Simple
10 | cabal-version: >= 1.10
11 | synopsis:
12 | Discrete constraint satisfaction problem (CSP) solver.
13 | extra-source-files: README.md
14 |
15 | source-repository head
16 | type: git
17 | location: http://github.com/abarbu/csp-haskell
18 |
19 | Library
20 | Build-Depends: base >= 3 && < 5, mtl >= 2, containers, nondeterminism >= 1.4
21 | Exposed-modules:
22 | Control.Monad.CSP
23 | ghc-options: -Wall
24 | Hs-Source-Dirs: src
25 | default-extensions: CPP
26 | default-language: Haskell2010
27 |
28 | test-suite tests
29 | type: exitcode-stdio-1.0
30 | hs-source-dirs: tests
31 | main-is: test.hs
32 | build-depends: base >= 4 && < 5, tasty, tasty-hunit, nondeterminism, csp
33 | default-language: Haskell2010
34 |
--------------------------------------------------------------------------------
/src/Control/Monad/CSP.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE TypeFamilies #-}
2 |
3 | module Control.Monad.CSP
4 | (
5 | -- * Overview
6 | -- $overview
7 |
8 | -- * Building CSPs
9 | mkDV,
10 | constraint1,
11 | constraint2,
12 | constraint3,
13 | constraint,
14 | -- * Solving CSPs
15 | oneCSPSolution,
16 | allCSPSolutions,
17 | solveCSP,
18 | CSPResult(..),
19 | -- * Low-level internal
20 | csp,
21 | domain,
22 | demons,
23 | isBound,
24 | domainSize,
25 | localWriteIORef,
26 | binding,
27 | addConstraint,
28 | restrictDomain,
29 | -- * Types
30 | DV(..),
31 | DVContainer(..),
32 | Constraint,
33 | CSP(..),
34 | ) where
35 | import Control.Monad.Amb
36 | import Control.Monad
37 | import Control.Monad.State.Strict
38 | import Data.IORef
39 | import System.IO.Unsafe
40 |
41 | -- $overview
42 | --
43 | -- This constructs a discrete constraint satisfaction problem (CSP)
44 | -- and then solves it. A discrete CSP consists of a number of
45 | -- variables each having a discrete domain along with a number of
46 | -- constraints between those variables. Solving a CSP searches for
47 | -- assignments to the variables which satisfy those constraints. At
48 | -- the moment the only constraint propagation technique available is
49 | -- arc consistency.
50 | --
51 | -- Here is a simple example which solves Sudoku
52 | -- puzzles, project Euler problem 96.
53 | --
54 | -- @
55 | --import Data.List
56 | --import Control.Monad.CSP
57 | --
58 | --solveSudoku :: (Enum a, Eq a, Num a) => [[a]] -> [[a]]
59 | --solveSudoku puzzle = oneCSPSolution $ do
60 | -- dvs \<- mapM (mapM (\\a -> mkDV $ if a == 0 then [1 .. 9] else [a])) puzzle
61 | -- mapM_ assertRowConstraints dvs
62 | -- mapM_ assertRowConstraints $ transpose dvs
63 | -- sequence_ [assertSquareConstraints dvs x y | x <- [0,3,6], y <- [0,3,6]]
64 | -- return dvs
65 | -- where assertRowConstraints = mapAllPairsM_ (constraint2 (/=))
66 | -- assertSquareConstraints dvs i j =
67 | -- mapAllPairsM_ (constraint2 (/=)) [(dvs !! x) !! y | x <- [i..i+2], y <- [j..j+2]]
68 | --
69 | -- mapAllPairsM_ :: Monad m => (a -> a -> m b) -> [a] -> m ()
70 | -- mapAllPairsM_ f [] = return ()
71 | -- mapAllPairsM_ f (_:[]) = return ()
72 | -- mapAllPairsM_ f (a:l) = mapM_ (f a) l >> mapAllPairsM_ f l
73 | --
74 | --sudoku3 = [[0,0,0,0,0,0,9,0,7],
75 | -- [0,0,0,4,2,0,1,8,0],
76 | -- [0,0,0,7,0,5,0,2,6],
77 | -- [1,0,0,9,0,4,0,0,0],
78 | -- [0,5,0,0,0,0,0,4,0],
79 | -- [0,0,0,5,0,7,0,0,9],
80 | -- [9,2,0,1,0,8,0,0,0],
81 | -- [0,3,4,0,5,9,0,0,0],
82 | -- [5,0,7,0,0,0,0,0,0]]
83 | -- @
84 | --
85 | -- >>> solveSudoku sudoku3
86 | -- [[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]]
87 |
88 |
89 | data DV r a = DV { dvDomain :: IORef [a], dvConstraints :: IORef [Constraint r] }
90 | type Constraint r = AmbT r IO ()
91 |
92 | data DVContainer r = DVContainer { dvcIsBound :: AmbT r IO Bool,
93 | dvcConstraints :: AmbT r IO (),
94 | dvcABinding :: AmbT r IO () }
95 |
96 | data CSP r x = CSP { unCSP :: IORef [DVContainer r] -> IO x }
97 |
98 | -- | Lift an IO computation into the CSP monad. CSPs are only in IO
99 | -- temporarily.
100 | csp :: IO x -> CSP r x
101 | csp x = CSP (\_ -> x)
102 |
103 | instance Functor (CSP r) where
104 | fmap = liftM
105 |
106 | instance Applicative (CSP r) where
107 | pure = return
108 | (<*>) = ap
109 |
110 | instance Monad (CSP r) where
111 | CSP x >>= y = CSP (\s -> x s >>= (\(CSP z) -> z s) . y)
112 | return a = CSP (\_ -> return a)
113 |
114 | -- | Extract the current domain of a variable.
115 | domain :: DV t t1 -> IO [t1]
116 | domain (DV d _) = readIORef d
117 |
118 | -- | Extract the current constraints of a variable.
119 | demons :: DV r a -> IO [Constraint r]
120 | demons dv = readIORef (dvConstraints dv)
121 |
122 | -- | Is the variable currently bound?
123 | isBound :: DV t t1 -> IO Bool
124 | isBound dv = domain dv >>= return . (== 1) . length
125 |
126 | -- | Compute the size of the current domain of variable.
127 | domainSize :: DV t t1 -> IO Int
128 | domainSize dv = domain dv >>= return . length
129 |
130 | -- | Create a variable with the given domain
131 | mkDV :: [a] -> CSP r (DV r a)
132 | mkDV xs = do
133 | d <- csp $ newIORef xs
134 | c <- csp $ newIORef []
135 | let dv = DV d c
136 | CSP (\x -> modifyIORef x $ ((DVContainer (lift $ isBound dv)
137 | (lift (demons dv) >>= sequence_)
138 | (do
139 | d' <- lift $ readIORef d
140 | e <- aMemberOf d'
141 | restrictDomain dv (\_ -> return [e])))
142 | :))
143 | return dv
144 |
145 | -- | This performs a side-effect, writing to the given IORef but
146 | -- records this in the nondeterministic computation so that it can be
147 | -- undone when backtracking.
148 | localWriteIORef :: IORef a -> a -> AmbT r IO ()
149 | localWriteIORef ref new = do
150 | previous <- lift $ readIORef ref
151 | uponFailure (lift $ writeIORef ref previous)
152 | lift $ writeIORef ref new
153 |
154 | -- | The low-level function out of which constraints are
155 | -- constructed. It modifies the domain of a variable.
156 | restrictDomain :: DV r a -> ([a] -> IO [a]) -> AmbT r IO ()
157 | restrictDomain dv f = do
158 | l' <- lift (domain dv >>= f)
159 | when (null l') empty
160 | size <- lift $ domainSize dv
161 | when (length l' < size) $ do
162 | localWriteIORef (dvDomain dv) l'
163 | constraints <- lift $ demons dv
164 | sequence_ constraints
165 |
166 | -- | Add a constraint to the given variable.
167 | addConstraint :: DV r1 a -> Constraint r1 -> CSP r ()
168 | addConstraint dv c = csp $ modifyIORef (dvConstraints dv) (c :)
169 |
170 | -- | Assert a unary constraint.
171 | constraint1 :: (a -> Bool) -> DV r1 a -> CSP r ()
172 | constraint1 f dv = addConstraint dv $ restrictDomain dv $ (return . filter f)
173 |
174 | -- | Assert a binary constraint with arc consistency.
175 | constraint2 :: (a -> t1 -> Bool) -> DV t a -> DV t t1 -> CSP r ()
176 | constraint2 f x y = do
177 | addConstraint x $
178 | restrictDomain y
179 | (\yd -> do
180 | xd <- (domain x)
181 | return $ filter (\ye -> any (\xe -> f xe ye) xd) yd)
182 | addConstraint y $
183 | restrictDomain x
184 | (\xd -> do
185 | yd <- (domain y)
186 | return $ filter (\xe -> any (\ye -> f xe ye) yd) xd)
187 |
188 | -- | Assert a trinary constraint with arc consistency.
189 | constraint3 :: (a -> t1 -> t2 -> Bool) -> DV t a -> DV t t1 -> DV t t2 -> CSP r ()
190 | constraint3 f x y z = do
191 | addConstraint x $
192 | restrictDomain y
193 | (\yd -> do
194 | xd <- (domain x)
195 | zd <- (domain z)
196 | return $ filter (\ye -> any (\xe -> any (\ze -> f xe ye ze) zd) xd) yd)
197 | addConstraint x $
198 | restrictDomain z
199 | (\zd -> do
200 | xd <- (domain x)
201 | yd <- (domain y)
202 | return $ filter (\ze -> any (\xe -> any (\ye -> f xe ye ze) yd) xd) zd)
203 | addConstraint y $
204 | restrictDomain x
205 | (\xd -> do
206 | yd <- (domain y)
207 | zd <- (domain z)
208 | return $ filter (\xe -> any (\ye -> any (\ze -> f xe ye ze) zd) yd) xd)
209 | addConstraint y $
210 | restrictDomain z
211 | (\zd -> do
212 | yd <- (domain y)
213 | xd <- (domain x)
214 | return $ filter (\ze -> any (\ye -> any (\xe -> f xe ye ze) xd) yd) zd)
215 | addConstraint z $
216 | restrictDomain x
217 | (\xd -> do
218 | yd <- (domain y)
219 | zd <- (domain z)
220 | return $ filter (\xe -> any (\ze -> any (\ye -> f xe ye ze) yd) zd) xd)
221 | addConstraint z $
222 | restrictDomain y
223 | (\yd -> do
224 | xd <- (domain x)
225 | zd <- (domain z)
226 | return $ filter (\ye -> any (\ze -> any (\xe -> f xe ye ze) xd) zd) yd)
227 |
228 | -- | Assert an n-ary constraint with arc consistency. One day this
229 | -- will allow for a heterogeneous list of variables, but at the moment
230 | -- they must all be of the same type.
231 | constraint :: ([a] -> Bool) -> [DV r1 a] -> CSP r ()
232 | constraint f dvl =
233 | mapM_ (\(dv1, k) ->
234 | addConstraint dv1 $
235 | (mapM_ (\(dv2, i) -> do
236 | unless (i == k) $
237 | restrictDomain dv2
238 | (\d2 -> do
239 | ddvl <- mapM domain dvl
240 | return $ filter (\d2e ->
241 | let loop [] es _ = f (reverse es)
242 | loop (d:ds) es j | i == j = loop ds (d2e:es) (j + 1)
243 | | otherwise = any (\e -> loop ds (e : es) (j + 1)) d
244 | in loop ddvl [] 1) d2))
245 | $ zip dvl ([1..] :: [Int])))
246 | $ zip dvl ([1..] :: [Int])
247 |
248 | -- | Retrieve the current binding of a variable.
249 | binding :: DV t b -> IO b
250 | binding d = domain d >>= return . head
251 |
252 | -- | This extracts results from a CSP.
253 | class CSPResult a where
254 | type Result a
255 | result :: a -> IO (Result a)
256 | instance CSPResult (DV r a) where
257 | type Result (DV r a) = a
258 | result = binding
259 | instance (CSPResult a, CSPResult b) => CSPResult (a,b) where
260 | type Result (a,b) = (Result a, Result b)
261 | result (a,b) = do
262 | a' <- result a
263 | b' <- result b
264 | return (a', b')
265 | instance (CSPResult a, CSPResult b, CSPResult c) => CSPResult (a,b,c) where
266 | type Result (a,b,c) = (Result a, Result b, Result c)
267 | result (a,b,c) = do
268 | a' <- result a
269 | b' <- result b
270 | c' <- result c
271 | return (a', b', c')
272 | instance (CSPResult a, CSPResult b, CSPResult c, CSPResult d) => CSPResult (a,b,c,d) where
273 | type Result (a,b,c,d) = (Result a, Result b, Result c, Result d)
274 | result (a,b,c,d) = do
275 | a' <- result a
276 | b' <- result b
277 | c' <- result c
278 | d' <- result d
279 | return (a', b', c', d')
280 | instance (CSPResult a, CSPResult b, CSPResult c, CSPResult d, CSPResult e) => CSPResult (a,b,c,d,e) where
281 | type Result (a,b,c,d,e) = (Result a, Result b, Result c, Result d, Result e)
282 | result (a,b,c,d,e) = do
283 | a' <- result a
284 | b' <- result b
285 | c' <- result c
286 | d' <- result d
287 | e' <- result e
288 | return (a', b', c', d', e')
289 | instance (CSPResult a, CSPResult b, CSPResult c, CSPResult d, CSPResult e, CSPResult f) => CSPResult (a,b,c,d,e,f) where
290 | type Result (a,b,c,d,e,f) = (Result a, Result b, Result c, Result d, Result e, Result f)
291 | result (a,b,c,d,e,f) = do
292 | a' <- result a
293 | b' <- result b
294 | c' <- result c
295 | d' <- result d
296 | e' <- result e
297 | f' <- result f
298 | return (a', b', c', d', e', f')
299 | instance (CSPResult a) => CSPResult [a] where
300 | type Result [a] = [Result a]
301 | result = mapM result
302 |
303 | -- | Solve the given CSP. The CSP solver is a nondeterministic
304 | -- function in IO and this is the generic interface which specifies
305 | -- how the nondeterministic computation should be carried out.
306 | solveCSP :: CSPResult a1 => (AmbT r IO (Result a1) -> IO a) -> CSP r a1 -> a
307 | solveCSP runAmb (CSP f) =
308 | (unsafePerformIO $ runAmb $ do
309 | dvcs <- lift $ newIORef []
310 | r <- lift $ f dvcs
311 | dvcs' <- lift $ readIORef dvcs
312 | -- One round of applying all constraints
313 | mapM_ dvcConstraints dvcs'
314 | let loop [] = return ()
315 | loop (d:ds) = do
316 | dvcABinding d
317 | filterM (liftM not . dvcIsBound) ds >>= loop
318 | in filterM (liftM not . dvcIsBound) dvcs' >>= loop
319 | lift $ result r >>= return)
320 |
321 | -- | Return a single solution to the CSP. 'solveCSP' running with 'oneValueT'
322 | oneCSPSolution :: CSPResult a1 => CSP (Result a1) a1 -> Result a1
323 | oneCSPSolution = solveCSP oneValueT
324 |
325 | -- | Return all solutions to the CSP. 'solveCSP' running with
326 | -- 'allValuesT'
327 | allCSPSolutions :: CSPResult a1 => CSP (Result a1) a1 -> [Result a1]
328 | allCSPSolutions = solveCSP allValuesT
329 |
--------------------------------------------------------------------------------
/stack.yaml:
--------------------------------------------------------------------------------
1 | # This file was automatically generated by 'stack init'
2 | #
3 | # Some commonly used options have been documented as comments in this file.
4 | # For advanced use and comprehensive documentation of the format, please see:
5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/
6 |
7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version.
8 | # A snapshot resolver dictates the compiler version and the set of packages
9 | # to be used for project dependencies. For example:
10 | #
11 | # resolver: lts-3.5
12 | # resolver: nightly-2015-09-21
13 | # resolver: ghc-7.10.2
14 | # resolver: ghcjs-0.1.0_ghc-7.10.2
15 | # resolver:
16 | # name: custom-snapshot
17 | # location: "./custom-snapshot.yaml"
18 | resolver: lts-10.1
19 |
20 | # User packages to be built.
21 | # Various formats can be used as shown in the example below.
22 | #
23 | # packages:
24 | # - some-directory
25 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz
26 | # - location:
27 | # git: https://github.com/commercialhaskell/stack.git
28 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
29 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a
30 | # extra-dep: true
31 | # subdirs:
32 | # - auto-update
33 | # - wai
34 | #
35 | # A package marked 'extra-dep: true' will only be built if demanded by a
36 | # non-dependency (i.e. a user package), and its test suites and benchmarks
37 | # will not be run. This is useful for tweaking upstream packages.
38 | packages:
39 | - .
40 | # Dependency packages to be pulled from upstream that are not in the resolver
41 | # (e.g., acme-missiles-0.3)
42 | # extra-deps: []
43 |
44 | # Override default flag values for local packages and extra-deps
45 | # flags: {}
46 |
47 | # Extra package databases containing global packages
48 | # extra-package-dbs: []
49 |
50 | # Control whether we use the GHC we find on the path
51 | # system-ghc: true
52 | #
53 | # Require a specific version of stack, using version ranges
54 | # require-stack-version: -any # Default
55 | # require-stack-version: ">=1.6"
56 | #
57 | # Override the architecture used by stack, especially useful on Windows
58 | # arch: i386
59 | # arch: x86_64
60 | #
61 | # Extra directories used by stack for building
62 | # extra-include-dirs: [/path/to/dir]
63 | # extra-lib-dirs: [/path/to/dir]
64 | #
65 | # Allow a newer minor version of GHC than the snapshot specifies
66 | # compiler-check: newer-minor
67 |
68 |
--------------------------------------------------------------------------------
/sudoku.txt:
--------------------------------------------------------------------------------
1 | Grid 01
2 | 003020600
3 | 900305001
4 | 001806400
5 | 008102900
6 | 700000008
7 | 006708200
8 | 002609500
9 | 800203009
10 | 005010300
11 | Grid 02
12 | 200080300
13 | 060070084
14 | 030500209
15 | 000105408
16 | 000000000
17 | 402706000
18 | 301007040
19 | 720040060
20 | 004010003
21 | Grid 03
22 | 000000907
23 | 000420180
24 | 000705026
25 | 100904000
26 | 050000040
27 | 000507009
28 | 920108000
29 | 034059000
30 | 507000000
31 | Grid 04
32 | 030050040
33 | 008010500
34 | 460000012
35 | 070502080
36 | 000603000
37 | 040109030
38 | 250000098
39 | 001020600
40 | 080060020
41 | Grid 05
42 | 020810740
43 | 700003100
44 | 090002805
45 | 009040087
46 | 400208003
47 | 160030200
48 | 302700060
49 | 005600008
50 | 076051090
51 | Grid 06
52 | 100920000
53 | 524010000
54 | 000000070
55 | 050008102
56 | 000000000
57 | 402700090
58 | 060000000
59 | 000030945
60 | 000071006
61 | Grid 07
62 | 043080250
63 | 600000000
64 | 000001094
65 | 900004070
66 | 000608000
67 | 010200003
68 | 820500000
69 | 000000005
70 | 034090710
71 | Grid 08
72 | 480006902
73 | 002008001
74 | 900370060
75 | 840010200
76 | 003704100
77 | 001060049
78 | 020085007
79 | 700900600
80 | 609200018
81 | Grid 09
82 | 000900002
83 | 050123400
84 | 030000160
85 | 908000000
86 | 070000090
87 | 000000205
88 | 091000050
89 | 007439020
90 | 400007000
91 | Grid 10
92 | 001900003
93 | 900700160
94 | 030005007
95 | 050000009
96 | 004302600
97 | 200000070
98 | 600100030
99 | 042007006
100 | 500006800
101 | Grid 11
102 | 000125400
103 | 008400000
104 | 420800000
105 | 030000095
106 | 060902010
107 | 510000060
108 | 000003049
109 | 000007200
110 | 001298000
111 | Grid 12
112 | 062340750
113 | 100005600
114 | 570000040
115 | 000094800
116 | 400000006
117 | 005830000
118 | 030000091
119 | 006400007
120 | 059083260
121 | Grid 13
122 | 300000000
123 | 005009000
124 | 200504000
125 | 020000700
126 | 160000058
127 | 704310600
128 | 000890100
129 | 000067080
130 | 000005437
131 | Grid 14
132 | 630000000
133 | 000500008
134 | 005674000
135 | 000020000
136 | 003401020
137 | 000000345
138 | 000007004
139 | 080300902
140 | 947100080
141 | Grid 15
142 | 000020040
143 | 008035000
144 | 000070602
145 | 031046970
146 | 200000000
147 | 000501203
148 | 049000730
149 | 000000010
150 | 800004000
151 | Grid 16
152 | 361025900
153 | 080960010
154 | 400000057
155 | 008000471
156 | 000603000
157 | 259000800
158 | 740000005
159 | 020018060
160 | 005470329
161 | Grid 17
162 | 050807020
163 | 600010090
164 | 702540006
165 | 070020301
166 | 504000908
167 | 103080070
168 | 900076205
169 | 060090003
170 | 080103040
171 | Grid 18
172 | 080005000
173 | 000003457
174 | 000070809
175 | 060400903
176 | 007010500
177 | 408007020
178 | 901020000
179 | 842300000
180 | 000100080
181 | Grid 19
182 | 003502900
183 | 000040000
184 | 106000305
185 | 900251008
186 | 070408030
187 | 800763001
188 | 308000104
189 | 000020000
190 | 005104800
191 | Grid 20
192 | 000000000
193 | 009805100
194 | 051907420
195 | 290401065
196 | 000000000
197 | 140508093
198 | 026709580
199 | 005103600
200 | 000000000
201 | Grid 21
202 | 020030090
203 | 000907000
204 | 900208005
205 | 004806500
206 | 607000208
207 | 003102900
208 | 800605007
209 | 000309000
210 | 030020050
211 | Grid 22
212 | 005000006
213 | 070009020
214 | 000500107
215 | 804150000
216 | 000803000
217 | 000092805
218 | 907006000
219 | 030400010
220 | 200000600
221 | Grid 23
222 | 040000050
223 | 001943600
224 | 009000300
225 | 600050002
226 | 103000506
227 | 800020007
228 | 005000200
229 | 002436700
230 | 030000040
231 | Grid 24
232 | 004000000
233 | 000030002
234 | 390700080
235 | 400009001
236 | 209801307
237 | 600200008
238 | 010008053
239 | 900040000
240 | 000000800
241 | Grid 25
242 | 360020089
243 | 000361000
244 | 000000000
245 | 803000602
246 | 400603007
247 | 607000108
248 | 000000000
249 | 000418000
250 | 970030014
251 | Grid 26
252 | 500400060
253 | 009000800
254 | 640020000
255 | 000001008
256 | 208000501
257 | 700500000
258 | 000090084
259 | 003000600
260 | 060003002
261 | Grid 27
262 | 007256400
263 | 400000005
264 | 010030060
265 | 000508000
266 | 008060200
267 | 000107000
268 | 030070090
269 | 200000004
270 | 006312700
271 | Grid 28
272 | 000000000
273 | 079050180
274 | 800000007
275 | 007306800
276 | 450708096
277 | 003502700
278 | 700000005
279 | 016030420
280 | 000000000
281 | Grid 29
282 | 030000080
283 | 009000500
284 | 007509200
285 | 700105008
286 | 020090030
287 | 900402001
288 | 004207100
289 | 002000800
290 | 070000090
291 | Grid 30
292 | 200170603
293 | 050000100
294 | 000006079
295 | 000040700
296 | 000801000
297 | 009050000
298 | 310400000
299 | 005000060
300 | 906037002
301 | Grid 31
302 | 000000080
303 | 800701040
304 | 040020030
305 | 374000900
306 | 000030000
307 | 005000321
308 | 010060050
309 | 050802006
310 | 080000000
311 | Grid 32
312 | 000000085
313 | 000210009
314 | 960080100
315 | 500800016
316 | 000000000
317 | 890006007
318 | 009070052
319 | 300054000
320 | 480000000
321 | Grid 33
322 | 608070502
323 | 050608070
324 | 002000300
325 | 500090006
326 | 040302050
327 | 800050003
328 | 005000200
329 | 010704090
330 | 409060701
331 | Grid 34
332 | 050010040
333 | 107000602
334 | 000905000
335 | 208030501
336 | 040070020
337 | 901080406
338 | 000401000
339 | 304000709
340 | 020060010
341 | Grid 35
342 | 053000790
343 | 009753400
344 | 100000002
345 | 090080010
346 | 000907000
347 | 080030070
348 | 500000003
349 | 007641200
350 | 061000940
351 | Grid 36
352 | 006080300
353 | 049070250
354 | 000405000
355 | 600317004
356 | 007000800
357 | 100826009
358 | 000702000
359 | 075040190
360 | 003090600
361 | Grid 37
362 | 005080700
363 | 700204005
364 | 320000084
365 | 060105040
366 | 008000500
367 | 070803010
368 | 450000091
369 | 600508007
370 | 003010600
371 | Grid 38
372 | 000900800
373 | 128006400
374 | 070800060
375 | 800430007
376 | 500000009
377 | 600079008
378 | 090004010
379 | 003600284
380 | 001007000
381 | Grid 39
382 | 000080000
383 | 270000054
384 | 095000810
385 | 009806400
386 | 020403060
387 | 006905100
388 | 017000620
389 | 460000038
390 | 000090000
391 | Grid 40
392 | 000602000
393 | 400050001
394 | 085010620
395 | 038206710
396 | 000000000
397 | 019407350
398 | 026040530
399 | 900020007
400 | 000809000
401 | Grid 41
402 | 000900002
403 | 050123400
404 | 030000160
405 | 908000000
406 | 070000090
407 | 000000205
408 | 091000050
409 | 007439020
410 | 400007000
411 | Grid 42
412 | 380000000
413 | 000400785
414 | 009020300
415 | 060090000
416 | 800302009
417 | 000040070
418 | 001070500
419 | 495006000
420 | 000000092
421 | Grid 43
422 | 000158000
423 | 002060800
424 | 030000040
425 | 027030510
426 | 000000000
427 | 046080790
428 | 050000080
429 | 004070100
430 | 000325000
431 | Grid 44
432 | 010500200
433 | 900001000
434 | 002008030
435 | 500030007
436 | 008000500
437 | 600080004
438 | 040100700
439 | 000700006
440 | 003004050
441 | Grid 45
442 | 080000040
443 | 000469000
444 | 400000007
445 | 005904600
446 | 070608030
447 | 008502100
448 | 900000005
449 | 000781000
450 | 060000010
451 | Grid 46
452 | 904200007
453 | 010000000
454 | 000706500
455 | 000800090
456 | 020904060
457 | 040002000
458 | 001607000
459 | 000000030
460 | 300005702
461 | Grid 47
462 | 000700800
463 | 006000031
464 | 040002000
465 | 024070000
466 | 010030080
467 | 000060290
468 | 000800070
469 | 860000500
470 | 002006000
471 | Grid 48
472 | 001007090
473 | 590080001
474 | 030000080
475 | 000005800
476 | 050060020
477 | 004100000
478 | 080000030
479 | 100020079
480 | 020700400
481 | Grid 49
482 | 000003017
483 | 015009008
484 | 060000000
485 | 100007000
486 | 009000200
487 | 000500004
488 | 000000020
489 | 500600340
490 | 340200000
491 | Grid 50
492 | 300200000
493 | 000107000
494 | 706030500
495 | 070009080
496 | 900020004
497 | 010800050
498 | 009040301
499 | 000702000
500 | 000008006
501 |
--------------------------------------------------------------------------------
/tests/test.hs:
--------------------------------------------------------------------------------
1 | import Test.Tasty
2 | import Test.Tasty.HUnit
3 |
4 | import Control.Monad.Amb
5 | import Control.Monad.CSP
6 | import Control.Monad
7 | import Data.List
8 |
9 | import System.IO.Unsafe
10 |
11 | main = defaultMain tests
12 |
13 | tests :: TestTree
14 | tests = testGroup "Tests" [unitTests]
15 |
16 | unitTests = testGroup "Unit tests"
17 | [ testCase "constraint1" $
18 | oneCSPSolution testC0 @?= 2
19 | , testCase "constraint2 same type" $
20 | oneCSPSolution testC1 @?= (5,4)
21 | , testCase "constraint2 different types" $
22 | oneCSPSolution testC2 @?= ("2",2::Int)
23 | , testCase "constraint3 different types" $
24 | oneCSPSolution testC3 @?= ("2",2::Int,2)
25 | , testCase "sudoku1" $
26 | 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]]
27 | , testCase "sudoku3" $
28 | 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]]
29 | -- Temporarily disabled, sometimes the sudoku file isn't found.
30 | -- , testCase "Euler p96" $
31 | -- length p96 @?= 50
32 | , testCase "Dinesman's dwellings" $
33 | dinesmanDwellings @?= [[3,2,4,5,1]]
34 | ]
35 |
36 | testC0 = do
37 | a <- mkDV [1,2,5]
38 | constraint1 (==2) a
39 | return a
40 |
41 | testC1 = do
42 | a <- mkDV [1,2,5]
43 | b <- mkDV [10,4,7]
44 | constraint2 (>) a b
45 | return (a,b)
46 |
47 | testC2 = do
48 | a <- mkDV ["1","2","5"]
49 | b <- mkDV [3,2,7]
50 | constraint2 (\a b -> read a == b) a b
51 | return (a,b)
52 |
53 | testC3 = do
54 | a <- mkDV ["1","2","3"]
55 | b <- mkDV [2::Int,3,4]
56 | c <- mkDV [2.0::Double,4,5]
57 | constraint3 (\a b c -> read a == b && read a == c) a b c
58 | return (a,b,c)
59 |
60 | -- Project Euler problem 96
61 |
62 | mapAllPairsM_ :: Monad m => (a -> a -> m b) -> [a] -> m ()
63 | mapAllPairsM_ f [] = return ()
64 | mapAllPairsM_ f (_:[]) = return ()
65 | mapAllPairsM_ f (a:l) = mapM_ (f a) l >> mapAllPairsM_ f l
66 |
67 | solveSudoku :: (Enum a, Eq a, Num a) => [[a]] -> [[a]]
68 | solveSudoku puzzle = oneCSPSolution $ do
69 | dvs <- mapM (mapM (\a -> mkDV $ if a == 0 then [1 .. 9] else [a])) puzzle
70 | mapM_ assertRowConstraints dvs
71 | mapM_ assertRowConstraints $ transpose dvs
72 | sequence_ [assertSquareConstraints dvs x y | x <- [0,3,6], y <- [0,3,6]]
73 | return dvs
74 | where assertRowConstraints = mapAllPairsM_ (constraint2 (/=))
75 | assertSquareConstraints dvs i j =
76 | mapAllPairsM_ (constraint2 (/=)) [(dvs !! x) !! y | x <- [i..i+2], y <- [j..j+2]]
77 |
78 | 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]]
79 |
80 | 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]]
81 |
82 | p96 :: [(Int, [[Int]])]
83 | p96 = let f = unsafePerformIO $ readFile "sudoku.txt"
84 | in map (\(g:gs) -> (read $ drop 5 g, solveSudoku $ map (\g -> map (read . (:[])) g) gs))
85 | $ groupBy (\a b -> not $ isPrefixOf "Grid" b) $ lines f
86 |
87 | dinesmanDwellings = allCSPSolutions $ do
88 | baker <- mkDV [1..5]
89 | cooper <- mkDV [1..5]
90 | fletcher <- mkDV [1..5]
91 | miller <- mkDV [1..5]
92 | smith <- mkDV [1..5]
93 | constraint1 (/= 5) baker
94 | constraint1 (/= 1) cooper
95 | constraint1 (\x -> x/=1 && x/=5) fletcher
96 | constraint2 (>) miller cooper
97 | notAdjacent smith fletcher
98 | notAdjacent fletcher cooper
99 | constraint allDistinct [baker,cooper,fletcher,miller,smith]
100 | return [baker,cooper,fletcher,miller,smith]
101 |
102 | notAdjacent a b = constraint2 (\x y -> abs (x - y) /= 1) a b
103 |
104 | allDistinct x = go x []
105 | where go [] _ = True
106 | go (x:xs) y
107 | | x `elem` y = False
108 | | otherwise = go xs (x:y)
109 |
--------------------------------------------------------------------------------