├── .gitignore ├── ChangeLog.md ├── LICENSE ├── README.md ├── Setup.hs ├── app └── Main.hs ├── asciicasts ├── wfc-fast.cast └── wfc.cast ├── mad-props.cabal ├── package.yaml ├── src ├── Examples │ ├── NQueens.hs │ └── Sudoku.hs ├── Props.hs └── Props │ └── Internal │ ├── Backtracking.hs │ ├── Graph.hs │ ├── Links.hs │ ├── MinTracker.hs │ ├── PropT.hs │ └── Props.hs ├── stack.yaml └── stack.yaml.lock /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | wave-function-collapse.cabal 3 | *~ 4 | /*.prof 5 | /*.html 6 | -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Changelog for wave-function-collapse 2 | 3 | ## Unreleased changes 4 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Chris Penner (c) 2019 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Chris Penner nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Mad Props 2 | 3 | [Hackage & Docs](http://hackage.haskell.org/package/mad-props) 4 | 5 | Mad props is a simple generalized propagator framework. This means it's pretty good at expressing and solving generalized [constraint satisfaction problems](https://en.wikipedia.org/wiki/Constraint_satisfaction_problem). 6 | 7 | Note that `mad-props` doesn't use lattice filters for propagation, nor does it yet support dynamic choice of propagator elements (though you can specify choice ordering through the container type you choose). Those things are more a bit more complicated. 8 | 9 | There are many other constraint solvers out there, probably most of them are faster than this one, but for those who like the comfort and type-safety of working in Haskell, I've gotcha covered. 10 | 11 | With other constraint solvers it can be a bit of a pain to express your problem; you either need to compress your problem down to relations between boolean variables, or try to cram your problem into their particular format. Mad Props uses a Monadic DSL for expressing the variables in your problem and the relationships between them, meaning you can use normal Haskell to express your problem. 12 | 13 | It's still unfinished and undergoing rapid iteration and experimentation, so I wouldn't base any major projects on it yet. 14 | 15 | ## Example: Sudoku 16 | 17 | We'll write a quick Sudoku solver using Propagators. 18 | 19 | Here's a problem which Telegraph has claimed to be ["the world's hardest Sudoku"](https://www.telegraph.co.uk/news/science/science-news/9359579/Worlds-hardest-sudoku-can-you-crack-it.html). Let's see if we can crack it. 20 | 21 | ```haskell 22 | hardestProblem :: [String] 23 | hardestProblem = tail . lines $ [r| 24 | 8........ 25 | ..36..... 26 | .7..9.2.. 27 | .5...7... 28 | ....457.. 29 | ...1...3. 30 | ..1....68 31 | ..85...1. 32 | .9....4..|] 33 | ``` 34 | 35 | Sudoku is a constraint satisfaction problem, the "constraints" are that each of the numbers 1-9 are represented in each row, column and 3x3 grid. 36 | 37 | ```haskell 38 | txtToBoard :: [String] -> [[S.Set Int]] 39 | txtToBoard = (fmap . fmap) possibilities 40 | where 41 | possibilities :: Char -> S.Set Int 42 | possibilities '.' = S.fromList [1..9] 43 | possibilities a = S.fromList [read [a]] 44 | 45 | hardestBoard :: [[S.Set Int]] 46 | hardestBoard = txtToBoard hardestProblem 47 | ``` 48 | 49 | We've now got our problem as a list of rows of 'cells', each cell is a set containing the possible numbers for that cell. 50 | 51 | We need to express the constraint that each 'region' (i.e. row, column and 'block') can only have one of each number in them. We'll write some helper function for collecting the regions of the puzzle: 52 | 53 | ```haskell 54 | rowsOf, colsOf, blocksOf :: [[a]] -> [[a]] 55 | rowsOf = id 56 | colsOf = transpose 57 | blocksOf = chunksOf 9 . concat . concat . fmap transpose . chunksOf 3 . transpose 58 | ``` 59 | 60 | Now we can worry about telling the system about our constraints. 61 | 62 | We can now introduce the constraints of Sudoku as relations between cells. The cells in each region are related to one other in the sense that **their values must be disjoint**. No two cells in each quadrant can have the same value. 63 | 64 | ```haskell 65 | -- | Given a board of 'PVar's, link the appropriate cells with 'disjoint' constraints 66 | linkBoardCells :: [[PVar S.Set Int]] -> Prop () 67 | linkBoardCells xs = do 68 | let rows = rowsOf xs 69 | let cols = colsOf xs 70 | let blocks = blocksOf xs 71 | for_ (rows <> cols <> blocks) $ \region -> do 72 | let uniquePairings = [(a, b) | a <- region, b <- region, a /= b] 73 | for_ uniquePairings $ \(a, b) -> constrain a b disj 74 | where 75 | disj :: Ord a => a -> S.Set a -> S.Set a 76 | disj x xs = S.delete x xs 77 | ``` 78 | 79 | This function introduces a few new types, namely `Prop` and `Pvar`. We'll show how `PVar`s are actually created soon, but the gist of this function is that we map over each 'region' and relate every variable to every other one. 80 | 81 | `Prop` is a monad which allows us to create and link `PVar`s together. It keeps track of the constraints on all of our variables and will eventually build a graph that the library uses to solve the problem. 82 | 83 | We call the `constrain` function to state that no cell pairing within a region should have the same number. 84 | 85 | `constrain` accepts two `PVar`s and a function, the function takes a 'choice' from the first variable and uses it to constrain the 'options' from the second. In this case, if the first variable is fixed to a specific value we 'propagate' by removing all matching values from the other variable's pool, you can see the implementation of the `disj` helper above. The information about this constraint is stored inside the `Prop` monad. 86 | 87 | Set disjunction is symmetric, propagators in general are not, so we'll need to 'constrain' in each direction. Luckily our loop will process each pair twice, so we'll run this once in each direction. 88 | 89 | Here's the real signature in case you're curious: 90 | 91 | ```haskell 92 | constrain :: Monad m 93 | => PVar f a 94 | -> PVar g b 95 | -> (a -> g b -> g b) 96 | -> PropT m () 97 | ``` 98 | 99 | We're almost there; we've got a way to constrain a board of `PVar`s, but we need to make the board of `PVar`s somehow! 100 | 101 | This is pretty easy; we can make a `PVar` by calling `newPVar` and passing it a container full of possible options the variable could be. We'll convert our `[[S.Set Int]]` into `[[PVar S.Set Int]]` by traversing the structure using `newPVar`. 102 | 103 | ```haskell 104 | -- | Given a sudoku board, apply the necessary constraints and return a result board of 'PVar's. 105 | constrainBoard :: [[S.Set Int]]-> Prop [[PVar S.Set Int]] 106 | constrainBoard board = do 107 | vars <- (traverse . traverse) newPVar board 108 | linkBoardCells vars 109 | return vars 110 | ``` 111 | 112 | Here's the signature of `newPVar` in case you're curious: 113 | 114 | ```haskell 115 | newPVar :: (Monad m, Foldable f, Typeable f, Typeable a) 116 | => f a 117 | -> PropT m (PVar f a) 118 | ``` 119 | 120 | Now that we've got our problem set up we need to execute it! 121 | 122 | ```haskell 123 | -- Solve a given sudoku board and print it to screen 124 | solvePuzzle :: [[S.Set Int]] -> IO () 125 | solvePuzzle puz = do 126 | -- We know it will succeed, but in general you should handle failure safely 127 | let Just results = solve (fmap . fmap) $ constrainBoard puz 128 | putStrLn $ boardToText results 129 | ``` 130 | 131 | `solvePuzzle` will print a solution for any valid puzzle you pass it. It accepts a puzzle, builds and constrains the cells, then calls `solve` which will find a valid solution for the constraints we provided if possible. We pass it a 'finalizer' function which accepts a function for resolving any `PVar` to its 'solved' result. In our case we just use `fmap . fmap` to map the resolver over every PVar in the board returned from `constrainBoard`. If all went well we'll have the solution of each cell! Then we'll print it out. 132 | 133 | Unfortunately `solve` has a bit of a complicated signature, there are simpler versions, but unfortunately they're not possible until GHC supports proper ImpredicativeTypes. 134 | 135 | ```haskell 136 | solve :: forall a r. 137 | -- A finalizer which accepts a PVar 'resolver' as an argument 138 | -- alongside the result of the Prop setup, and returns some result 139 | ((forall f x. PVar f x -> x) -> a -> r) 140 | -> Prop a 141 | -> (Maybe r) 142 | ``` 143 | 144 | We can plug in our hardest sudoku and after a second or two we'll print out the answer! 145 | 146 | ```haskell 147 | >>> solvePuzzle hardestBoard 148 | 812753649 149 | 943682175 150 | 675491283 151 | 154237896 152 | 369845721 153 | 287169534 154 | 521974368 155 | 438526917 156 | 796318452 157 | ``` 158 | 159 | You can double check it for me, but I'm pretty sure that's a valid solution! 160 | 161 | ## Example: N-Queens 162 | 163 | Just for fun, here's the N-Queens problem 164 | 165 | ```haskell 166 | {-# LANGUAGE ScopedTypeVariables #-} 167 | {-# LANGUAGE ViewPatterns #-} 168 | module Examples.NQueens where 169 | 170 | import qualified Data.Set as S 171 | import Props 172 | import Data.Foldable 173 | import Data.List 174 | 175 | -- | A board coordinate 176 | type Coord = (Int, Int) 177 | 178 | -- | Given a number of queens, constrain them to not overlap 179 | constrainQueens :: Int -> Prop [PVar S.Set Coord] 180 | constrainQueens n = do 181 | -- All possible grid locations 182 | let locations = S.fromList [(x, y) | x <- [0..n - 1], y <- [0..n - 1]] 183 | -- Each queen could initially be placed anywhere 184 | let queens = replicate n locations 185 | -- Make a PVar for each queen's location 186 | queenVars <- traverse newPVar queens 187 | -- Each pair of queens must not overlap 188 | let queenPairs = [(a, b) | a <- queenVars, b <- queenVars, a /= b] 189 | for_ queenPairs $ \(a, b) -> require (\x y -> not $ overlapping x y) a b 190 | return queenVars 191 | 192 | -- | Check whether two queens overlap with each other (i.e. could kill each other) 193 | overlapping :: Coord -> Coord -> Bool 194 | overlapping (x, y) (x', y') 195 | -- Same Row 196 | | x == x' = True 197 | -- Same Column 198 | | y == y' = True 199 | -- Same Diagonal 1 200 | | x - x' == y - y' = True 201 | -- Same Diagonal 2 202 | | x + y == x' + y' = True 203 | | otherwise = False 204 | 205 | -- | Print an nQueens puzzle to a string. 206 | showSolution :: Int -> [Coord] -> String 207 | showSolution n (S.fromList -> qs) = 208 | let str = toChar . (`S.member` qs) <$> [(x, y) | x <- [0..n-1], y <- [0..n-1]] 209 | in unlines . chunksOf n $ str 210 | where 211 | toChar :: Bool -> Char 212 | toChar True = 'Q' 213 | toChar False = '.' 214 | 215 | chunksOf :: Int -> [a] -> [[a]] 216 | chunksOf n = unfoldr go 217 | where 218 | go [] = Nothing 219 | go xs = Just (take n xs, drop n xs) 220 | 221 | -- | Solve and print an N-Queens puzzle 222 | nQueens :: Int -> IO () 223 | nQueens n = do 224 | let Just results = solve fmap (constrainQueens n) 225 | putStrLn $ showSolution n results 226 | 227 | -- | Solve and print all possible solutions of an N-Queens puzzle 228 | -- This will include duplicates. 229 | nQueensAll :: Int -> IO () 230 | nQueensAll n = do 231 | let results = solveAll (constrainQueens n) 232 | traverse_ (putStrLn . showSolution n) results 233 | ``` 234 | 235 | ## Performance 236 | 237 | This is a generalized solution, so performance suffers in relation to a tool built for the job (e.g. It's not as fast as dedicated Sudoku solvers); but it does "pretty well". 238 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Examples.Sudoku as S 4 | import Examples.NQueens as NQ 5 | 6 | main :: IO () 7 | main = do 8 | S.solveEasyPuzzle 9 | NQ.nQueens 8 10 | -------------------------------------------------------------------------------- /mad-props.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.31.2. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | -- 7 | -- hash: a42c235991d5a051d2c2e06b557284432c12645b78bd3e0c94de36ef67c038bb 8 | 9 | name: mad-props 10 | version: 0.2.1.0 11 | synopsis: Monadic DSL for building constraint solvers using basic propagators. 12 | description: Please see the README on GitHub at 13 | category: Propagators 14 | homepage: https://github.com/ChrisPenner/mad-props#readme 15 | bug-reports: https://github.com/ChrisPenner/mad-props/issues 16 | author: Chris Penner 17 | maintainer: christopher.penner@gmail.com 18 | copyright: Chris Penner 19 | license: BSD3 20 | license-file: LICENSE 21 | build-type: Simple 22 | extra-source-files: 23 | README.md 24 | ChangeLog.md 25 | 26 | source-repository head 27 | type: git 28 | location: https://github.com/ChrisPenner/mad-props 29 | 30 | library 31 | exposed-modules: 32 | Examples.NQueens 33 | Examples.Sudoku 34 | Props 35 | Props.Internal.Backtracking 36 | Props.Internal.Graph 37 | Props.Internal.Links 38 | Props.Internal.MinTracker 39 | Props.Internal.Props 40 | Props.Internal.PropT 41 | other-modules: 42 | Paths_mad_props 43 | hs-source-dirs: 44 | src 45 | ghc-options: -Wall -fno-warn-name-shadowing -fwarn-redundant-constraints -O2 46 | build-depends: 47 | MonadRandom 48 | , base >=4.7 && <5 49 | , containers 50 | , lens 51 | , logict 52 | , mtl 53 | , psqueues 54 | , random 55 | , random-shuffle 56 | , raw-strings-qq 57 | , transformers 58 | default-language: Haskell2010 59 | 60 | executable sudoku-exe 61 | main-is: Main.hs 62 | other-modules: 63 | Paths_mad_props 64 | hs-source-dirs: 65 | app 66 | ghc-options: -Wall -fno-warn-name-shadowing -fwarn-redundant-constraints -O2 -threaded -rtsopts -with-rtsopts=-N 67 | build-depends: 68 | MonadRandom 69 | , base >=4.7 && <5 70 | , containers 71 | , lens 72 | , logict 73 | , mad-props 74 | , mtl 75 | , psqueues 76 | , random 77 | , random-shuffle 78 | , raw-strings-qq 79 | , transformers 80 | default-language: Haskell2010 81 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: mad-props 2 | version: 0.2.1.0 3 | github: "ChrisPenner/mad-props" 4 | license: BSD3 5 | author: "Chris Penner" 6 | maintainer: "christopher.penner@gmail.com" 7 | copyright: "Chris Penner" 8 | 9 | extra-source-files: 10 | - README.md 11 | - ChangeLog.md 12 | 13 | # Metadata used when publishing your package 14 | synopsis: Monadic DSL for building constraint solvers using basic propagators. 15 | category: Propagators 16 | 17 | # To avoid duplicated efforts in documentation and dealing with the 18 | # complications of embedding Haddock markup inside cabal files, it is 19 | # common to point users to the README.md file. 20 | description: Please see the README on GitHub at 21 | 22 | dependencies: 23 | - base >= 4.7 && < 5 24 | - lens 25 | - raw-strings-qq 26 | - containers 27 | - mtl 28 | - transformers 29 | - MonadRandom 30 | - random-shuffle 31 | - psqueues 32 | - logict 33 | - random 34 | 35 | library: 36 | source-dirs: src 37 | 38 | ghc-options: 39 | - -Wall 40 | - -fno-warn-name-shadowing 41 | - -fwarn-redundant-constraints 42 | - -O2 43 | 44 | executables: 45 | sudoku-exe: 46 | main: Main.hs 47 | source-dirs: app 48 | ghc-options: 49 | - -threaded 50 | - -rtsopts 51 | - -with-rtsopts=-N 52 | dependencies: 53 | - mad-props 54 | -------------------------------------------------------------------------------- /src/Examples/NQueens.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Examples.NQueens 3 | Description : An implementation of the classic N-Queens constraint puzzle. 4 | Copyright : (c) Chris Penner, 2019 5 | License : BSD3 6 | 7 | Click 'Source' on a function to see how it's implemented! 8 | -} 9 | {-# LANGUAGE ScopedTypeVariables #-} 10 | {-# LANGUAGE ViewPatterns #-} 11 | module Examples.NQueens where 12 | 13 | import qualified Data.Set as S 14 | import Props 15 | import Data.Foldable 16 | import Data.List 17 | 18 | -- | A board coordinate 19 | type Coord = (Int, Int) 20 | 21 | -- | Given a number of queens, constrain them to not overlap 22 | constrainQueens :: Int -> Prop [PVar S.Set Coord] 23 | constrainQueens n = do 24 | -- All possible grid locations 25 | let locations = S.fromList [(x, y) | x <- [0..n - 1], y <- [0..n - 1]] 26 | -- Each queen could initially be placed anywhere 27 | let queens = replicate n locations 28 | -- Make a PVar for each queen's location 29 | queenVars <- traverse newPVar queens 30 | -- Each pair of queens must not overlap 31 | let queenPairs = [(a, b) | a <- queenVars, b <- queenVars, a /= b] 32 | for_ queenPairs $ \(a, b) -> require (\x y -> not $ overlapping x y) a b 33 | return queenVars 34 | 35 | -- | Check whether two queens overlap with each other (i.e. could kill each other) 36 | overlapping :: Coord -> Coord -> Bool 37 | overlapping (x, y) (x', y') 38 | -- Same Row 39 | | x == x' = True 40 | -- Same Column 41 | | y == y' = True 42 | -- Same Diagonal 1 43 | | x - x' == y - y' = True 44 | -- Same Diagonal 2 45 | | x + y == x' + y' = True 46 | | otherwise = False 47 | 48 | -- | Print an nQueens puzzle to a string. 49 | showSolution :: Int -> [Coord] -> String 50 | showSolution n (S.fromList -> qs) = 51 | let str = toChar . (`S.member` qs) <$> [(x, y) | x <- [0..n-1], y <- [0..n-1]] 52 | in unlines . chunksOf n $ str 53 | where 54 | toChar :: Bool -> Char 55 | toChar True = 'Q' 56 | toChar False = '.' 57 | 58 | chunksOf :: Int -> [a] -> [[a]] 59 | chunksOf n = unfoldr go 60 | where 61 | go [] = Nothing 62 | go xs = Just (take n xs, drop n xs) 63 | 64 | -- | Solve and print an N-Queens puzzle 65 | nQueens :: Int -> IO () 66 | nQueens n = do 67 | let Just results = solve fmap (constrainQueens n) 68 | putStrLn $ showSolution n results 69 | 70 | -- | Solve and print all possible solutions of an N-Queens puzzle 71 | -- This will include duplicates. 72 | nQueensAll :: Int -> IO () 73 | nQueensAll n = do 74 | let results = solveAll fmap (constrainQueens n) 75 | traverse_ (putStrLn . showSolution n) results 76 | -------------------------------------------------------------------------------- /src/Examples/Sudoku.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Examples.Sudoku 3 | Description : A simple sudoku solver 4 | Copyright : (c) Chris Penner, 2019 5 | License : BSD3 6 | 7 | Click 'Source' on a function to see how it's implemented! 8 | -} 9 | {-# LANGUAGE FlexibleContexts #-} 10 | {-# LANGUAGE TypeFamilies #-} 11 | {-# LANGUAGE QuasiQuotes #-} 12 | {-# LANGUAGE OverloadedStrings #-} 13 | module Examples.Sudoku where 14 | 15 | import Props 16 | import Data.Foldable 17 | import Text.RawString.QQ (r) 18 | import qualified Data.Set as S 19 | import Data.List 20 | 21 | -- | Convert a textual board into a board containing sets of cells of possible numbers 22 | txtToBoard :: [String] -> [[S.Set Int]] 23 | txtToBoard = (fmap . fmap) possibilities 24 | where 25 | possibilities :: Char -> S.Set Int 26 | possibilities '.' = S.fromList [1..9] 27 | possibilities a = S.fromList [read [a]] 28 | 29 | -- | Convert a board to a string. 30 | boardToText :: [[Int]] -> String 31 | boardToText xs = unlines . fmap concat $ (fmap . fmap) show xs 32 | 33 | -- | An easy to solve sudoku board 34 | easyBoard :: [[S.Set Int]] 35 | easyBoard = txtToBoard . tail . lines $ [r| 36 | ..3.42.9. 37 | .9..6.5.. 38 | 5......1. 39 | ..17..285 40 | ..8...1.. 41 | 329..87.. 42 | .3......1 43 | ..5.9..2. 44 | .8.21.6..|] 45 | 46 | hardestBoard :: [[S.Set Int]] 47 | hardestBoard = txtToBoard . tail . lines $ [r| 48 | 8........ 49 | ..36..... 50 | .7..9.2.. 51 | .5...7... 52 | ....457.. 53 | ...1...3. 54 | ..1....68 55 | ..85...1. 56 | .9....4..|] 57 | 58 | 59 | -- | Get a list of all rows in a board 60 | rowsOf :: [[a]] -> [[a]] 61 | rowsOf = id 62 | 63 | -- | Get a list of all columns in a board 64 | colsOf :: [[a]] -> [[a]] 65 | colsOf = transpose 66 | 67 | -- | Get a list of all square blocks in a board 68 | blocksOf :: [[a]] -> [[a]] 69 | blocksOf = chunksOf 9 . concat . concat . fmap transpose . chunksOf 3 . transpose 70 | where 71 | chunksOf :: Int -> [a] -> [[a]] 72 | chunksOf n = unfoldr go 73 | where 74 | go [] = Nothing 75 | go xs = Just (take n xs, drop n xs) 76 | 77 | 78 | -- | Given a board of 'PVar's, link the appropriate cells with 'disjoint' constraints 79 | linkBoardCells :: [[PVar S.Set Int]] -> Prop () 80 | linkBoardCells xs = do 81 | let rows = rowsOf xs 82 | let cols = colsOf xs 83 | let blocks = blocksOf xs 84 | for_ (rows <> cols <> blocks) $ \region -> do 85 | let uniquePairings = [(a, b) | a <- region, b <- region, a /= b] 86 | for_ uniquePairings $ \(a, b) -> constrain a b disj 87 | where 88 | disj :: Ord a => a -> S.Set a -> S.Set a 89 | disj x xs = S.delete x xs 90 | 91 | -- | Given a sudoku board, apply the necessary constraints and return a result board of 92 | -- 'PVar's. We wrap the result in 'Compose' because 'solve' requires a Functor over 'PVar's 93 | constrainBoard :: [[S.Set Int]]-> Prop [[PVar S.Set Int]] 94 | constrainBoard board = do 95 | vars <- (traverse . traverse) newPVar board 96 | linkBoardCells vars 97 | return vars 98 | 99 | -- Solve a given sudoku board and print it to screen 100 | solvePuzzle :: [[S.Set Int]] -> IO () 101 | solvePuzzle puz = do 102 | -- We know it will succeed, but in general you should handle failure safely 103 | let Just results = solve (fmap . fmap) $ constrainBoard puz 104 | putStrLn $ boardToText results 105 | 106 | solveEasyPuzzle :: IO () 107 | solveEasyPuzzle = solvePuzzle easyBoard 108 | -------------------------------------------------------------------------------- /src/Props.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Props 3 | Description : Monadic DSL for building constraint solvers using basic propagators. 4 | Copyright : (c) Chris Penner, 2019 5 | License : BSD3 6 | 7 | This module exports everything you should need to get started. Take a look at 'Examples.NQueens' or 'Examples.Sudoku' to see how to get started. 8 | -} 9 | module Props 10 | ( 11 | -- * Initializing problems 12 | Prop 13 | , PropT 14 | , PVar 15 | , newPVar 16 | 17 | -- * Finding Solutions 18 | , solveT 19 | , solveAllT 20 | , solve 21 | , solveAll 22 | 23 | -- * Constraining variables 24 | , constrain 25 | , disjoint 26 | , equal 27 | , require 28 | ) where 29 | 30 | import Props.Internal.PropT 31 | import Props.Internal.Links 32 | -------------------------------------------------------------------------------- /src/Props/Internal/Backtracking.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ViewPatterns #-} 2 | {-# LANGUAGE DerivingStrategies #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | {-# LANGUAGE TemplateHaskell #-} 5 | module Props.Internal.Backtracking where 6 | 7 | import Control.Monad.Logic 8 | import Control.Applicative 9 | import Data.Foldable 10 | import System.Random.Shuffle 11 | import Control.Monad.State 12 | import Props.Internal.Graph 13 | import qualified Props.Internal.MinTracker as MT 14 | import Control.Lens 15 | import Data.Bifunctor 16 | import System.Random 17 | import Control.Monad.Random 18 | import Data.Maybe 19 | 20 | -- Note; State on the OUTSIDE means it WILL backtrack state. 21 | newtype Backtrack a = Backtrack (StateT BState (RandT StdGen Logic) a) 22 | deriving newtype (Functor, Alternative, Applicative, Monad, MonadState BState, MonadRandom) 23 | 24 | data BState = 25 | BState { _bsMinTracker :: MT.MinTracker 26 | , _graph :: Graph 27 | } 28 | makeLenses ''BState 29 | 30 | instance MT.HasMinTracker BState where 31 | minTracker = bsMinTracker 32 | 33 | rselect :: (Foldable f) => f a -> Backtrack a 34 | rselect (toList -> fa) = (shuffleM fa) >>= select 35 | {-# INLINE rselect #-} 36 | 37 | select :: (Foldable f) => f a -> Backtrack a 38 | select (toList -> fa) = asum (pure <$> fa) 39 | {-# INLINE select #-} 40 | 41 | runBacktrack :: MT.MinTracker -> Graph -> Backtrack a -> Maybe (a, Graph) 42 | runBacktrack mt g (Backtrack m) = 43 | fmap (second _graph) 44 | . listToMaybe 45 | . observeMany 1 46 | . flip evalRandT (mkStdGen 0) 47 | . flip runStateT (BState mt g) 48 | $ m 49 | 50 | runBacktrackAll :: MT.MinTracker -> Graph -> Backtrack a -> [(a, Graph)] 51 | runBacktrackAll mt g (Backtrack m) = 52 | fmap (second _graph) 53 | . observeAll 54 | . flip evalRandT (mkStdGen 0) 55 | . flip runStateT (BState mt g) 56 | $ m 57 | -------------------------------------------------------------------------------- /src/Props/Internal/Graph.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE ViewPatterns #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | {-# LANGUAGE DeriveFunctor #-} 6 | {-# LANGUAGE DeriveFoldable #-} 7 | {-# LANGUAGE DeriveTraversable #-} 8 | {-# LANGUAGE MultiParamTypeClasses #-} 9 | {-# LANGUAGE ExistentialQuantification #-} 10 | {-# LANGUAGE ConstraintKinds #-} 11 | {-# LANGUAGE KindSignatures #-} 12 | {-# LANGUAGE DataKinds #-} 13 | {-# LANGUAGE FlexibleContexts #-} 14 | {-# LANGUAGE TypeApplications #-} 15 | {-# LANGUAGE GADTs #-} 16 | 17 | module Props.Internal.Graph 18 | ( Graph 19 | , valueAt 20 | , imAsList 21 | , edgesFrom 22 | , edges 23 | , vertices 24 | , Vertex(..) 25 | , Quantum(..) 26 | , SuperPos(..) 27 | , _Observed 28 | , _Unknown 29 | , DFilter 30 | , DChoice 31 | , forceDyn 32 | , values 33 | , entropyOfQ 34 | , emptyGraph 35 | , edgeBetween 36 | , vertexCount 37 | , superPos 38 | ) where 39 | 40 | import qualified Data.IntMap.Strict as IM 41 | import Control.Lens 42 | import Data.Dynamic 43 | import Data.Maybe 44 | import Data.Typeable 45 | import Data.Typeable.Lens 46 | 47 | type DFilter = Dynamic 48 | type DChoice = Dynamic 49 | type Vertex' = Int 50 | newtype Vertex = Vertex Int 51 | deriving (Show, Eq, Ord) 52 | 53 | data SuperPos f a where 54 | Observed :: Foldable f => a -> SuperPos f a 55 | Unknown :: Foldable f => f a -> SuperPos f a 56 | 57 | instance Show (SuperPos f a) where 58 | show (Observed _) = "Observed" 59 | show (Unknown _) = "Unknown" 60 | 61 | _Unknown :: Foldable f => Prism' (SuperPos f a) (f a) 62 | _Unknown = prism' embed match 63 | where 64 | embed = Unknown 65 | match (Unknown f) = Just f 66 | match _ = Nothing 67 | 68 | _Observed :: Foldable f => Prism' (SuperPos f a) a 69 | _Observed = prism' embed match 70 | where 71 | embed = Observed 72 | match (Observed a) = Just a 73 | match _ = Nothing 74 | 75 | data Quantum = 76 | forall f a. (Show (SuperPos f a), Typeable f, Typeable a, Foldable f) => Quantum 77 | { options :: SuperPos f a 78 | } 79 | 80 | superPos :: (Typeable f, Typeable a) => Traversal' Quantum (SuperPos f a) 81 | superPos f (Quantum o) = Quantum <$> (o & _cast %%~ f) 82 | 83 | instance Show Quantum where 84 | show (Quantum xs) = "Quantum " <> show xs 85 | 86 | forceDyn :: forall a. Typeable a => Dynamic -> a 87 | forceDyn d = 88 | fromMaybe (error ("Expected type: " <> expected <> " but Dyn was type: " <> show d)) (fromDynamic d) 89 | where 90 | expected = show (typeOf (undefined :: a)) 91 | 92 | data Graph = 93 | Graph { _vertices :: !(IM.IntMap (Quantum, IM.IntMap DFilter)) 94 | , _vertexCount :: !Int 95 | } deriving Show 96 | 97 | 98 | makeLenses ''Graph 99 | 100 | emptyGraph :: Graph 101 | emptyGraph = Graph mempty 0 102 | 103 | valueAt :: Vertex -> Lens' (Graph) Quantum 104 | valueAt (Vertex n) = singular (vertices . ix n . _1) 105 | {-# INLINE valueAt #-} 106 | 107 | imAsList :: Iso' (IM.IntMap v ) [(Vertex', v)] 108 | imAsList = iso IM.toList IM.fromList 109 | {-# INLINABLE imAsList #-} 110 | 111 | edges :: Vertex -> Lens' (Graph) (IM.IntMap DFilter) 112 | edges (Vertex n) = singular (vertices . ix n . _2) 113 | {-# INLINABLE edges #-} 114 | 115 | edgeBetween :: Vertex -> Vertex -> Lens' (Graph) (Maybe DFilter) 116 | edgeBetween from' (Vertex to') = edges from' . at to' 117 | {-# INLINABLE edgeBetween #-} 118 | 119 | values :: Traversal' (Graph) (Vertex, Quantum) 120 | values = vertices . imAsList . traversed . alongside coerced _1 121 | {-# INLINABLE values #-} 122 | 123 | edgesFrom :: Vertex -> Traversal' (Graph) (Vertex, DFilter) 124 | edgesFrom n = edges n . imAsList . traversed . coerced 125 | {-# INLINE edgesFrom #-} 126 | 127 | entropyOfQ :: Quantum -> (Maybe Int) 128 | entropyOfQ (Quantum (Unknown xs)) = Just $ length xs 129 | entropyOfQ _ = Nothing 130 | -------------------------------------------------------------------------------- /src/Props/Internal/Links.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | module Props.Internal.Links 3 | ( disjoint 4 | , equal 5 | , require 6 | ) where 7 | 8 | import qualified Data.Set as S 9 | import Props.Internal.PropT 10 | 11 | {-| 12 | Apply the constraint that two variables may NOT be set to the same value. This constraint is bidirectional. 13 | 14 | E.g. you might apply this constraint to two cells in the same row of sudoku grid to assert they don't contain the same value. 15 | -} 16 | disjoint :: forall a m. (Monad m, Ord a) => PVar S.Set a -> PVar S.Set a -> PropT m () 17 | disjoint a b = do 18 | constrain a b disj 19 | constrain b a disj 20 | where 21 | disj :: a -> S.Set a -> S.Set a 22 | disj x xs = S.delete x xs 23 | 24 | {-| 25 | Apply the constraint that two variables MUST be set to the same value. This constraint is bidirectional. 26 | -} 27 | equal :: forall a m. (Monad m, Ord a) => PVar S.Set a -> PVar S.Set a -> PropT m () 28 | equal a b = do 29 | constrain a b eq 30 | constrain b a eq 31 | where 32 | eq :: a -> S.Set a -> S.Set a 33 | eq x xs | x `S.member` xs = S.singleton x 34 | | otherwise = S.empty 35 | 36 | {-| 37 | Given a choice for @a@; filter for valid options of @b@ using the given predicate. 38 | 39 | E.g. if @a@ must always be greater than @b@, you could require: 40 | 41 | > require (>) a b 42 | -} 43 | require :: Monad m => (a -> b -> Bool) -> PVar S.Set a -> PVar S.Set b -> PropT m () 44 | require f a b = do 45 | constrain a b (S.filter . f) 46 | -------------------------------------------------------------------------------- /src/Props/Internal/MinTracker.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | module Props.Internal.MinTracker where 5 | 6 | import qualified Data.IntPSQ as PSQ 7 | import Control.Monad.State 8 | import Control.Lens as L 9 | import Props.Internal.Graph 10 | 11 | data MinTracker = 12 | MinTracker { _minQueue :: (PSQ.IntPSQ Int ()) } 13 | 14 | makeClassy ''MinTracker 15 | 16 | empty :: MinTracker 17 | empty = MinTracker PSQ.empty 18 | 19 | popMinNode :: (HasMinTracker e, MonadState e m) => m (Maybe Vertex) 20 | popMinNode = do 21 | uses minQueue PSQ.minView >>= \case 22 | Nothing -> return Nothing 23 | Just (n, _, _, q) -> do 24 | minQueue .= q 25 | return $ Just (Vertex n) 26 | {-# INLINE popMinNode #-} 27 | 28 | setNodeEntropy :: (HasMinTracker e, MonadState e m) => Vertex -> Int -> m () 29 | setNodeEntropy (Vertex nd) ent = do 30 | minQueue %= snd . PSQ.insertView nd ent () 31 | {-# INLINE setNodeEntropy #-} 32 | 33 | fromList :: [(Vertex, Int)] -> MinTracker 34 | fromList xs = MinTracker (PSQ.fromList (fmap assoc xs)) 35 | where 36 | assoc (Vertex n, ent) = (n, ent, ()) 37 | -------------------------------------------------------------------------------- /src/Props/Internal/PropT.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DerivingStrategies #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | {-# LANGUAGE ExistentialQuantification #-} 4 | {-# LANGUAGE KindSignatures #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE FlexibleContexts #-} 7 | {-# LANGUAGE RankNTypes #-} 8 | {-# LANGUAGE GADTs #-} 9 | {-# LANGUAGE TypeApplications #-} 10 | 11 | module Props.Internal.PropT 12 | ( Prop 13 | , PropT 14 | , newPVar 15 | , constrain 16 | , solveT 17 | , solveAllT 18 | , solve 19 | , solveAll 20 | , readPVar 21 | , PVar 22 | ) where 23 | 24 | import Props.Internal.Graph 25 | import qualified Props.Internal.Props as P 26 | import Control.Monad.State 27 | import Control.Lens 28 | import Data.Typeable 29 | import Data.Dynamic 30 | import Data.Maybe 31 | 32 | -- | Pure version of 'PropT' 33 | type Prop a = PropT Identity a 34 | 35 | 36 | {-| 37 | A monad transformer for setting up constraint problems. 38 | -} 39 | newtype PropT m a = 40 | PropT { runGraphM :: StateT Graph m a 41 | } 42 | deriving newtype (Functor, Applicative, Monad, MonadIO, MonadTrans) 43 | 44 | {-| 45 | A propagator variable where the possible values @a@ are contained in the container @f@. 46 | -} 47 | data PVar (f :: * -> *) a where 48 | PVar :: (Typeable a, Typeable f) => Vertex -> PVar f a 49 | 50 | -- | Nominal equality, Ignores contents 51 | instance Eq (PVar f a) where 52 | (PVar v) == (PVar t) = v == t 53 | 54 | instance Ord (PVar f a) where 55 | PVar v <= PVar t = v <= t 56 | 57 | instance Show (PVar f a) where 58 | show (PVar _) = unwords ["PVar", show (typeRep (Proxy @f)), show (typeRep (Proxy @a))] 59 | 60 | {-| 61 | Used to create a new propagator variable within the setup for your problem. 62 | 63 | @f@ is any Foldable container which contains each of the possible states which the variable could take. 64 | 65 | E.g. For a sudoku solver you would use 'newPVar' to create a variable for each cell, passing a @Set Int@ containing the numbers @[1..9]@. 66 | -} 67 | newPVar :: (Monad m, Foldable f, Typeable f, Typeable a) => f a -> PropT m (PVar f a) 68 | newPVar xs = PropT $ do 69 | v <- vertexCount <+= 1 70 | vertices . at v ?= (Quantum (Unknown xs), mempty) 71 | return (PVar (Vertex v)) 72 | 73 | {-| 74 | 'constrain' the relationship between two 'PVar's. Note that this is a ONE WAY relationship; e.g. @constrain a b f@ will propagate constraints from @a@ to @b@ but not vice versa. 75 | 76 | Given @PVar f a@ and @PVar g b@ as arguments, provide a function which will filter/alter the options in @g@ according to the choice. 77 | 78 | For a sudoku puzzle you'd have two @Pvar Set Int@'s, each representing a cell on the board. 79 | You can constrain @b@ to be a different value than @a@ with the following call: 80 | 81 | > constrain a b $ \elementA setB -> S.delete elementA setB) 82 | 83 | Take a look at some linking functions which are already provided: 'disjoint', 'equal', 'require' 84 | -} 85 | constrain :: Monad m 86 | => PVar f a 87 | -> PVar g b 88 | -> (a -> g b -> g b) 89 | -> PropT m () 90 | constrain (PVar from') (PVar to') f = PropT $ do 91 | edgeBetween from' to' ?= toDyn f 92 | 93 | readPVar :: Graph -> PVar f a -> a 94 | readPVar g (PVar v) = 95 | fromMaybe (error "readPVar called on unsolved graph") 96 | $ (g ^? valueAt v . folding unpackQuantum) 97 | 98 | unpackQuantum :: (Typeable a) => Quantum -> Maybe a 99 | unpackQuantum (Quantum (Observed xs)) = cast xs 100 | unpackQuantum (Quantum _) = Nothing 101 | 102 | buildGraph :: PropT m a -> m (a, Graph) 103 | buildGraph = flip runStateT emptyGraph . runGraphM 104 | 105 | {-| 106 | Provide an initialization action which constrains the problem, and a finalizer, and 'solveT' will return a result if one exists. 107 | 108 | The finalizer is an annoyance caused by the fact that GHC does not yet support Impredicative Types. 109 | 110 | For example, if you wrote a solution to the nQueens problem, you might run it like so: 111 | 112 | > -- Set up the problem for 'n' queens and return their PVar's as a list. 113 | > initNQueens :: Int -> Prop [PVar S.Set Coord] 114 | > initNQueens = ... 115 | > 116 | > solution :: [Coord] 117 | > solution = solve (\readPVar vars -> fmap readPVar vars) (initNQueens 8) 118 | > -- or more simply: 119 | > solution = solve fmap (initNQueens 8) 120 | which converts 'PVar's into a result.Given an action which initializes and constrains a problem 'solveT' will and returns some container of 'PVar's, 'solveT' will attempt to find a solution which passes all valid constraints. 121 | -} 122 | solveT :: forall m a r. 123 | Monad m 124 | => ((forall f x. PVar f x -> x) -> a -> r) 125 | -> PropT m a 126 | -> m (Maybe r) 127 | solveT f m = do 128 | (a, g) <- buildGraph m 129 | case P.solve g of 130 | Nothing -> return Nothing 131 | Just solved -> return . Just $ f (readPVar solved) a 132 | 133 | 134 | {-| 135 | Like 'solveT', but finds ALL possible solutions. There will likely be duplicates. 136 | -} 137 | solveAllT :: forall m a r. 138 | Monad m 139 | => ((forall f x. PVar f x -> x) -> a -> r) 140 | -> PropT m a 141 | -> m [r] 142 | solveAllT f m = do 143 | (a, g) <- buildGraph m 144 | let gs = P.solveAll g 145 | return $ gs <&> \g' -> f (readPVar g') a 146 | 147 | {-| 148 | Pure version of 'solveT' 149 | -} 150 | solve :: forall a r. 151 | ((forall f x. PVar f x -> x) -> a -> r) 152 | -> Prop a 153 | -> (Maybe r) 154 | solve f = runIdentity . solveT f 155 | 156 | {-| 157 | Pure version of 'solveAllT' 158 | -} 159 | solveAll :: forall a r. 160 | ((forall f x. PVar f x -> x) -> a -> r) 161 | -> Prop a 162 | -> [r] 163 | solveAll f = runIdentity . solveAllT f 164 | -------------------------------------------------------------------------------- /src/Props/Internal/Props.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE QuasiQuotes #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | {-# LANGUAGE DeriveFunctor #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | {-# LANGUAGE ViewPatterns #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | {-# LANGUAGE DeriveFunctor #-} 9 | {-# LANGUAGE DeriveTraversable #-} 10 | module Props.Internal.Props (solve, solveAll) where 11 | 12 | import qualified Props.Internal.Graph as G 13 | import Control.Lens hiding (Context) 14 | import Props.Internal.Backtracking 15 | import Props.Internal.Graph 16 | import qualified Props.Internal.MinTracker as MT 17 | import Data.Dynamic 18 | import Data.Foldable 19 | import Control.Monad.State 20 | 21 | solve :: Graph 22 | -> Maybe Graph 23 | solve graph' = fmap snd $ runBacktrack (initMinTracker graph') graph' solve' 24 | 25 | solveAll :: Graph -> [Graph] 26 | solveAll graph' = snd <$> runBacktrackAll (initMinTracker graph') graph' solve' 27 | 28 | solve' :: Backtrack () 29 | solve' = MT.popMinNode >>= \case 30 | Nothing -> return () 31 | Just n -> collapse n *> solve' 32 | {-# INLINABLE solve' #-} 33 | 34 | collapse :: G.Vertex 35 | -> Backtrack () 36 | collapse n = do 37 | focused <- use (singular (graph . valueAt n)) 38 | choicesOfQ' focused n 39 | {-# INLINE collapse #-} 40 | 41 | choicesOfQ' :: Quantum -> Vertex -> Backtrack () 42 | choicesOfQ' (Quantum (Observed{})) _ = error "Can't collapse an already collapsed node!" 43 | choicesOfQ' (Quantum (Unknown xs :: SuperPos f a)) n = do 44 | choice <- select xs 45 | graph . valueAt n . superPos .= (Observed choice :: SuperPos f a) 46 | propagate (n, toDyn choice) 47 | {-# INLINE choicesOfQ' #-} 48 | 49 | initMinTracker :: Graph -> MT.MinTracker 50 | initMinTracker graph' = MT.fromList (allEntropies ^.. traversed . below _Just) 51 | where 52 | allEntropies :: [(G.Vertex, Maybe Int)] 53 | allEntropies = allNodes ^.. traversed . alongside id (to entropyOfQ) 54 | allNodes :: [(G.Vertex, Quantum)] 55 | allNodes = graph' ^.. values 56 | 57 | propagate :: (Vertex, DChoice) -> Backtrack () 58 | propagate (from', choice) = do 59 | allEdges <- gets (toListOf (graph . edgesFrom from')) 60 | for_ allEdges step' 61 | where 62 | step' :: (Vertex, DFilter) -> Backtrack () 63 | step' e = propagateSingle choice e 64 | {-# INLINE propagate #-} 65 | 66 | propagateSingle :: DChoice -> (Vertex, DFilter) -> Backtrack () 67 | propagateSingle v (to', dfilter) = do 68 | graph . valueAt to' %%= alterQ >>= \case 69 | Nothing -> return () 70 | Just newEnt -> MT.setNodeEntropy to' newEnt 71 | return () 72 | where 73 | alterQ :: Quantum -> (Maybe Int, Quantum) 74 | alterQ (Quantum (Unknown xs :: SuperPos f a)) = do 75 | let filteredDown = (forceDyn $ dynApp (dynApp dfilter v) (toDyn xs) :: f a) 76 | in (Just $ length filteredDown, Quantum (Unknown filteredDown)) 77 | alterQ q = (Nothing, q) 78 | {-# INLINE propagateSingle #-} 79 | -------------------------------------------------------------------------------- /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 | # 15 | # The location of a snapshot can be provided as a file or url. Stack assumes 16 | # a snapshot provided as a file might change, whereas a url resource does not. 17 | # 18 | # resolver: ./custom-snapshot.yaml 19 | # resolver: https://example.com/snapshots/2018-01-01.yaml 20 | resolver: lts-14.1 21 | 22 | # User packages to be built. 23 | # Various formats can be used as shown in the example below. 24 | # 25 | # packages: 26 | # - some-directory 27 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 28 | # subdirs: 29 | # - auto-update 30 | # - wai 31 | packages: 32 | - . 33 | 34 | # Dependency packages to be pulled from upstream that are not in the resolver. 35 | # These entries can reference officially published versions as well as 36 | # forks / in-progress versions pinned to a git hash. For example: 37 | # 38 | extra-deps: 39 | - monad-dijkstra-0.1.1.2@sha256:4bca3eca6358f916b06501f82c7bfa4c59236af0ac8cac551854c2e928e78c37,1962 40 | # - acme-missiles-0.3 41 | # - git: https://github.com/commercialhaskell/stack.git 42 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 43 | # 44 | # extra-deps: [] 45 | 46 | # Override default flag values for local packages and extra-deps 47 | # flags: {} 48 | 49 | # Extra package databases containing global packages 50 | # extra-package-dbs: [] 51 | 52 | # Control whether we use the GHC we find on the path 53 | # system-ghc: true 54 | # 55 | # Require a specific version of stack, using version ranges 56 | # require-stack-version: -any # Default 57 | # require-stack-version: ">=2.1" 58 | # 59 | # Override the architecture used by stack, especially useful on Windows 60 | # arch: i386 61 | # arch: x86_64 62 | # 63 | # Extra directories used by stack for building 64 | # extra-include-dirs: [/path/to/dir] 65 | # extra-lib-dirs: [/path/to/dir] 66 | # 67 | # Allow a newer minor version of GHC than the snapshot specifies 68 | # compiler-check: newer-minor 69 | -------------------------------------------------------------------------------- /stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: 7 | - completed: 8 | hackage: monad-dijkstra-0.1.1.2@sha256:4bca3eca6358f916b06501f82c7bfa4c59236af0ac8cac551854c2e928e78c37,1962 9 | pantry-tree: 10 | size: 333 11 | sha256: 055ea4bab35e29fc8a2e4f8e2a9b3acb2219d1f074729ba9ef96308b64b11876 12 | original: 13 | hackage: monad-dijkstra-0.1.1.2@sha256:4bca3eca6358f916b06501f82c7bfa4c59236af0ac8cac551854c2e928e78c37,1962 14 | snapshots: 15 | - completed: 16 | size: 523448 17 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/14/1.yaml 18 | sha256: 0045b9bae36c3bb2dd374c29b586389845af1557eea0423958d152fc500d4fbf 19 | original: lts-14.1 20 | --------------------------------------------------------------------------------