packages feed

mad-props (empty) → 0.1.0.0

raw patch · 15 files changed

+1026/−0 lines, 15 filesdep +MonadRandomdep +basedep +containerssetup-changed

Dependencies added: MonadRandom, base, containers, lens, logict, mad-props, mono-traversable, mtl, psqueues, random, random-shuffle, raw-strings-qq, transformers

Files

+ ChangeLog.md view
@@ -0,0 +1,3 @@+# Changelog for wave-function-collapse++## Unreleased changes
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Chris Penner (c) 2019++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Chris Penner nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,220 @@+# Mad Props++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).++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.++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.++It's still unfinished and undergoing rapid iteration and experimentation, so I wouldn't base any major projects on it yet.++## Example: Sudoku++We'll write a quick Sudoku solver using Propagators.++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.++```haskell+hardestProblem :: [String]+hardestProblem = tail . lines $ [r|+8........+..36.....+.7..9.2..+.5...7...+....457..+...1...3.+..1....68+..85...1.+.9....4..|]+```++A 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. `Props` allows us to create `PVars` a.k.a. Propagator Variables. `PVars` represent a piece of information in our problem which is 'unknown' but has some relationship with other variables. To convert Sudoku into a propagator problem we can make a new `PVar` for each cell, the `PVar` will contain either all possible values from 1-9; or ONLY the value which is specified in the puzzle. We use a Set to indicate the possibilities, but you can really use almost any container you like inside a `PVar`.++```haskell+txtToBoard :: [String] -> [[S.Set Int]]+txtToBoard = (fmap . fmap) possibilities+  where+    possibilities :: Char -> S.Set Int+    possibilities '.' = S.fromList [1..9]+    possibilities a = S.fromList [read [a]]++hardestBoard :: [[S.Set Int]]+hardestBoard = txtToBoard hardestProblem+```++This function takes our problem and converts it into a nested grid of variables! Each variable 'contains' all the possibilities for that square. Now we need to 'constrain' the problem!++We can then introduce the constraints of Sudoku as relations between these `PVars`. The cells in each 'quadrant' (i.e. square, row, or column) are each 'related' to one other in the sense that **their values must be disjoint**. No two cells in each quadrant can have the same value. We'll quickly write some shoddy functions to extract the lists of "regions" we need to worry about from our board. Getting the **rows** and **columns** is easy, getting the square **blocks** is a bit more tricky, the implementation here really doesn't matter.++```haskell+rowsOf, colsOf, blocksOf :: [[a]] -> [[a]]+rowsOf = id+colsOf = transpose+blocksOf = chunksOf 9 . concat . concat . fmap transpose . chunksOf 3 . transpose+```++Now we can worry about telling the system about our constraints. We'll map over each region relating every variable to every other one. This function assumes we've replaced the `Set a`'s in our board representation with the appropriate `PVar`'s, we'll actually do that soon, but for now you can look the other way.++```haskell+-- | Given a board of 'PVar's, link the appropriate cells with 'disjoint' constraints+linkBoardCells :: [[PVar (S.Set Int)]] -> Prop ()+linkBoardCells xs = do+    let rows = rowsOf xs+    let cols = colsOf xs+    let blocks = blocksOf xs+    for_ (rows <> cols <> blocks) $ \region -> do+        let uniquePairings = [(a, b) | a <- region, b <- region, a /= b]+        for_ uniquePairings $ \(a, b) -> constrain a b disj+  where+    disj :: Ord a => a -> S.Set a -> S.Set a+    disj x xs = S.delete x xs+```+++Now every pair of `PVars` in each region is linked by the `disj` relation.++`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 the 'link' is stored inside the `Prop` monad.++Here's the real signature in case you're curious: ++```haskell+constrain :: (Monad m, Typeable g, Typeable (Element f)) +          => PVar f -> PVar g -> (Element f -> g -> g) +          -> PropT m ()+```++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.++Now we can link our parts together:++```haskell+-- | Given a sudoku board, apply the necessary constraints and return a result board of+-- 'PVar's. We wrap the result in 'Compose' because 'solve' requires a Functor over 'PVar's+constrainBoard :: [[S.Set Int]]-> Prop (Compose [] [] (PVar (S.Set Int)))+constrainBoard board = do+    vars <- (traverse . traverse) newPVar board+    linkBoardCells vars+    return (Compose vars)+```++We accept a sudoku "board", we replace each `Set Int` with a `PVar (S.Set Int)` using `newPVar` which creates a propagator from a set of possible values. This is a propagator variable which has a `Set` of Ints which the variable could take. We then link all the board's cells together using constraints, and lastly return a `Functor` full of `PVar`s; which will later be replaced with actual values. `Compose` converts a list of lists into a single functor over the nested elements.++```haskell+newPVar :: (Monad m, MonoFoldable f, Typeable f, Typeable (Element f)) +        => f -> PropT m (PVar f)+```++Now that we've got our problem set up we need to execute it!++```haskell+-- Solve a given sudoku board and print it to screen+solvePuzzle :: [[S.Set Int]] -> IO ()+solvePuzzle puz = do+    -- We know it will succeed, but in general you should handle failure safely+    let Just (Compose results) = solve $ constrainBoard puz+    putStrLn $ boardToText results+```++We run `solveGraph` to run the propagation solver. It accepts a puzzle, builds and constrains the cells, then calls `solve` which maps over the `Compose`'d board we created in `constrainBoard` and replaces all the `PVar`s with actual results! If all went well we'll have the solution of each cell! Then we'll print it out.++Here are some types first, then we'll try it out:++```haskell+solve :: (Functor f, Typeable (Element g)) +      => Prop (f (PVar g)) -> Maybe (f (Element g))+```++We can plug in our hardest sudoku and after a second or two we'll print out the answer!++```haskell+>>> solvePuzzle hardestBoard+812753649+943682175+675491283+154237896+369845721+287169534+521974368+438526917+796318452+```++You can double check it for me, but I'm pretty sure that's a valid solution!++## Example: N-Queens++Just for fun, here's the N-Queens problem++```haskell+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-}+module Examples.NQueens where++import qualified Data.Set as S+import Props+import Data.Foldable+import Data.List++-- | A board coordinate+type Coord = (Int, Int)++-- | Given a number of queens, constrain them to not overlap+constrainQueens :: Int -> Prop [PVar (S.Set Coord)]+constrainQueens n = do+    -- All possible grid locations+    let locations = S.fromList [(x, y) | x <- [0..n - 1], y <- [0..n - 1]]+    -- Each queen could initially be placed anywhere+    let queens = replicate n locations+    -- Make a PVar for each queen's location+    queenVars <- traverse newPVar queens+    -- Each pair of queens must not overlap+    let queenPairs = [(a, b) | a <- queenVars, b <- queenVars, a /= b]+    for_ queenPairs $ \(a, b) -> require (\x y -> not $ overlapping x y) a b+    return queenVars++-- | Check whether two queens overlap with each other (i.e. could kill each other)+overlapping :: Coord -> Coord -> Bool+overlapping (x, y) (x', y')+  -- Same Row+  | x == x' = True+  -- Same Column+  | y == y' = True+  -- Same Diagonal 1+  | x - x' == y - y' = True+  -- Same Diagonal 2+  | x + y == x' + y' = True+  | otherwise = False++-- | Print an nQueens puzzle to a string.+showSolution :: Int -> [Coord] -> String+showSolution n (S.fromList -> qs) =+    let str = toChar . (`S.member` qs) <$> [(x, y) | x <- [0..n-1], y <- [0..n-1]]+     in unlines . chunksOf n $ str+  where+    toChar :: Bool -> Char+    toChar True = 'Q'+    toChar False = '.'++    chunksOf :: Int -> [a] -> [[a]]+    chunksOf n = unfoldr go+      where+        go [] = Nothing+        go xs = Just (take n xs, drop n xs)++-- | Solve and print an N-Queens puzzle+nQueens :: Int -> IO ()+nQueens n = do+    let Just results = solve (constrainQueens n)+    putStrLn $ showSolution n results++-- | Solve and print all possible solutions of an N-Queens puzzle+-- This will include duplicates.+nQueensAll :: Int -> IO ()+nQueensAll n = do+    let results = solveAll (constrainQueens n)+    traverse_ (putStrLn . showSolution n) results+```++## Performance++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".
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,10 @@+module Main where++import Examples.Sudoku as S+import Examples.NQueens as NQ++main :: IO ()+main = do+    S.solveEasyPuzzle+-- main = NQ.solve 12+-- main = hardLogic
+ mad-props.cabal view
@@ -0,0 +1,82 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.31.2.+--+-- see: https://github.com/sol/hpack+--+-- hash: 33df843ae197b9debc55c9ed25dfb25eb1a01e4deb1623975fa0cb69e25705be++name:           mad-props+version:        0.1.0.0+synopsis:       Monadic DSL for building constraint solvers using basic propagators.+description:    Please see the README on GitHub at <https://github.com/ChrisPenner/mad-props#readme>+category:       Propagators+homepage:       https://github.com/ChrisPenner/mad-props#readme+bug-reports:    https://github.com/ChrisPenner/mad-props/issues+author:         Chris Penner+maintainer:     christopher.penner@gmail.com+copyright:      Chris Penner+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    ChangeLog.md++source-repository head+  type: git+  location: https://github.com/ChrisPenner/mad-props++library+  exposed-modules:+      Examples.NQueens+      Examples.Sudoku+      Props+      Props.Internal.Backtracking+      Props.Internal.Graph+      Props.Internal.Links+      Props.Internal.MinTracker+      Props.Internal.Props+      Props.Internal.PropT+  other-modules:+      Paths_mad_props+  hs-source-dirs:+      src+  ghc-options: -Wall -fno-warn-name-shadowing -O2+  build-depends:+      MonadRandom+    , base >=4.7 && <5+    , containers+    , lens+    , logict+    , mono-traversable+    , mtl+    , psqueues+    , random+    , random-shuffle+    , raw-strings-qq+    , transformers+  default-language: Haskell2010++executable sudoku-exe+  main-is: Main.hs+  other-modules:+      Paths_mad_props+  hs-source-dirs:+      app+  ghc-options: -Wall -fno-warn-name-shadowing -O2 -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      MonadRandom+    , base >=4.7 && <5+    , containers+    , lens+    , logict+    , mad-props+    , mono-traversable+    , mtl+    , psqueues+    , random+    , random-shuffle+    , raw-strings-qq+    , transformers+  default-language: Haskell2010
+ src/Examples/NQueens.hs view
@@ -0,0 +1,76 @@+{-|+Module      : Examples.NQueens+Description : An implementation of the classic N-Queens constraint puzzle.+Copyright   : (c) Chris Penner, 2019+License     : BSD3++Click 'Source' on a function to see how it's implemented!+-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-}+module Examples.NQueens where++import qualified Data.Set as S+import Props+import Data.Foldable+import Data.List++-- | A board coordinate+type Coord = (Int, Int)++-- | Given a number of queens, constrain them to not overlap+constrainQueens :: Int -> Prop [PVar (S.Set Coord)]+constrainQueens n = do+    -- All possible grid locations+    let locations = S.fromList [(x, y) | x <- [0..n - 1], y <- [0..n - 1]]+    -- Each queen could initially be placed anywhere+    let queens = replicate n locations+    -- Make a PVar for each queen's location+    queenVars <- traverse newPVar queens+    -- Each pair of queens must not overlap+    let queenPairs = [(a, b) | a <- queenVars, b <- queenVars, a /= b]+    for_ queenPairs $ \(a, b) -> require (\x y -> not $ overlapping x y) a b+    return queenVars++-- | Check whether two queens overlap with each other (i.e. could kill each other)+overlapping :: Coord -> Coord -> Bool+overlapping (x, y) (x', y')+  -- Same Row+  | x == x' = True+  -- Same Column+  | y == y' = True+  -- Same Diagonal 1+  | x - x' == y - y' = True+  -- Same Diagonal 2+  | x + y == x' + y' = True+  | otherwise = False++-- | Print an nQueens puzzle to a string.+showSolution :: Int -> [Coord] -> String+showSolution n (S.fromList -> qs) =+    let str = toChar . (`S.member` qs) <$> [(x, y) | x <- [0..n-1], y <- [0..n-1]]+     in unlines . chunksOf n $ str+  where+    toChar :: Bool -> Char+    toChar True = 'Q'+    toChar False = '.'++    chunksOf :: Int -> [a] -> [[a]]+    chunksOf n = unfoldr go+      where+        go [] = Nothing+        go xs = Just (take n xs, drop n xs)++-- | Solve and print an N-Queens puzzle+nQueens :: Int -> IO ()+nQueens n = do+    let Just results = solve (constrainQueens n)+    putStrLn $ showSolution n results++-- | Solve and print all possible solutions of an N-Queens puzzle+-- This will include duplicates.+nQueensAll :: Int -> IO ()+nQueensAll n = do+    let results = solveAll (constrainQueens n)+    traverse_ (putStrLn . showSolution n) results+
+ src/Examples/Sudoku.hs view
@@ -0,0 +1,108 @@+{-|+Module      : Examples.Sudoku+Description : A simple sudoku solver+Copyright   : (c) Chris Penner, 2019+License     : BSD3++Click 'Source' on a function to see how it's implemented!+-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE OverloadedStrings #-}+module Examples.Sudoku where++import Props+import Data.Foldable+import Text.RawString.QQ (r)+import qualified Data.Set as S+import Data.List+import Data.Functor.Compose++-- | Convert a textual board into a board containing sets of cells of possible numbers+txtToBoard :: [String] -> [[S.Set Int]]+txtToBoard = (fmap . fmap) possibilities+  where+    possibilities :: Char -> S.Set Int+    possibilities '.' = S.fromList [1..9]+    possibilities a = S.fromList [read [a]]++-- | Convert a board to a string.+boardToText :: [[Int]] -> String+boardToText xs = unlines . fmap concat $ (fmap . fmap) show xs++-- | An easy to solve sudoku board+easyBoard :: [[S.Set Int]]+easyBoard = txtToBoard . tail . lines $ [r|+..3.42.9.+.9..6.5..+5......1.+..17..285+..8...1..+329..87..+.3......1+..5.9..2.+.8.21.6..|]++hardestBoard :: [[S.Set Int]]+hardestBoard = txtToBoard . tail . lines $ [r|+8........+..36.....+.7..9.2..+.5...7...+....457..+...1...3.+..1....68+..85...1.+.9....4..|]+++-- | Get a list of all rows in a board+rowsOf :: [[a]] -> [[a]]+rowsOf = id++-- | Get a list of all columns in a board+colsOf :: [[a]] -> [[a]]+colsOf = transpose++-- | Get a list of all square blocks in a board+blocksOf :: [[a]] -> [[a]]+blocksOf = chunksOf 9 . concat . concat . fmap transpose . chunksOf 3 . transpose+  where+    chunksOf :: Int -> [a] -> [[a]]+    chunksOf n = unfoldr go+      where+        go [] = Nothing+        go xs = Just (take n xs, drop n xs)+++-- | Given a board of 'PVar's, link the appropriate cells with 'disjoint' constraints+linkBoardCells :: [[PVar (S.Set Int)]] -> Prop ()+linkBoardCells xs = do+    let rows = rowsOf xs+    let cols = colsOf xs+    let blocks = blocksOf xs+    for_ (rows <> cols <> blocks) $ \region -> do+        let uniquePairings = [(a, b) | a <- region, b <- region, a /= b]+        for_ uniquePairings $ \(a, b) -> constrain a b disj+  where+    disj :: Ord a => a -> S.Set a -> S.Set a+    disj x xs = S.delete x xs++-- | Given a sudoku board, apply the necessary constraints and return a result board of+-- 'PVar's. We wrap the result in 'Compose' because 'solve' requires a Functor over 'PVar's+constrainBoard :: [[S.Set Int]]-> Prop (Compose [] [] (PVar (S.Set Int)))+constrainBoard board = do+    vars <- (traverse . traverse) newPVar board+    linkBoardCells vars+    return (Compose vars)++-- Solve a given sudoku board and print it to screen+solvePuzzle :: [[S.Set Int]] -> IO ()+solvePuzzle puz = do+    -- We know it will succeed, but in general you should handle failure safely+    let Just (Compose results) = solve $ constrainBoard puz+    putStrLn $ boardToText results++solveEasyPuzzle :: IO ()+solveEasyPuzzle = solvePuzzle easyBoard
+ src/Props.hs view
@@ -0,0 +1,29 @@+{-|+Module      : Props+Description : Monadic DSL for building constraint solvers using basic propagators.+Copyright   : (c) Chris Penner, 2019+License     : BSD3++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.+-}+module Props+    (+    -- * Initializing problems+      Prop+    , PropT+    , PVar+    , newPVar++    -- * Finding Solutions+    , solve+    , solveAll++    -- * Constraining variables+    , constrain+    , disjoint+    , equal+    , require+    ) where++import Props.Internal.PropT+import Props.Internal.Links
+ src/Props/Internal/Backtracking.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+module Props.Internal.Backtracking where++import Control.Monad.Logic+import Control.Applicative+import Data.Foldable+import System.Random.Shuffle+import Control.Monad.State+import Props.Internal.Graph+import qualified Props.Internal.MinTracker as MT+import Control.Lens+import Data.Bifunctor+import System.Random+import Control.Monad.Random+import Data.Maybe++-- Note; State on the OUTSIDE means it WILL backtrack state.+newtype Backtrack a = Backtrack (StateT BState (RandT StdGen Logic) a)+    deriving newtype (Functor, Alternative, Applicative, Monad, MonadState BState, MonadRandom)++data BState =+    BState { _bsMinTracker :: MT.MinTracker+           , _graph      :: Graph+           }+makeLenses ''BState++instance MT.HasMinTracker BState where+  minTracker = bsMinTracker++rselect :: (Foldable f, Functor f) => f a -> Backtrack a+rselect (toList -> fa) = (shuffleM fa) >>= select+{-# INLINE rselect #-}++select :: (Foldable f, Functor f) => f a -> Backtrack a+select fa = asum (pure <$> fa)+{-# INLINE select #-}++runBacktrack :: MT.MinTracker -> Graph -> Backtrack a -> Maybe (a, Graph)+runBacktrack mt g (Backtrack m) =+    fmap (second _graph)+    . listToMaybe+    . observeMany 1+    . flip evalRandT (mkStdGen 0)+    . flip runStateT (BState mt g)+    $ m++runBacktrackAll :: MT.MinTracker -> Graph -> Backtrack a -> [(a, Graph)]+runBacktrackAll mt g (Backtrack m) =+    fmap (second _graph)+    . observeAll+    . flip evalRandT (mkStdGen 0)+    . flip runStateT (BState mt g)+    $ m
+ src/Props/Internal/Graph.hs view
@@ -0,0 +1,130 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE GADTs #-}++module Props.Internal.Graph+    ( Graph+    , valueAt+    , imAsList+    , edgesFrom+    , edges+    , vertices+    , Vertex(..)+    , Quantum(..)+    , SuperPos(..)+    , _Observed+    , _Unknown+    , DFilter+    , DChoice+    , forceDyn+    , values+    , entropyOfQ+    , emptyGraph+    , edgeBetween+    , vertexCount+    , superPos+    ) where++import qualified Data.IntMap.Strict as IM+import Control.Lens+import Data.Dynamic+import Data.Maybe+import Data.Typeable+import Data.Typeable.Lens+import Data.MonoTraversable++type DFilter = Dynamic+type DChoice = Dynamic+type Vertex' = Int+newtype Vertex = Vertex Int+  deriving (Show, Eq, Ord)++data SuperPos f where+    Observed :: MonoFoldable f => Element f -> SuperPos f+    Unknown :: MonoFoldable f => f -> SuperPos f++instance Show (SuperPos f) where+  show (Observed _) = "Observed"+  show (Unknown _) = "Unknown"++_Unknown :: (Show f, Show (Element f), MonoFoldable f) => Prism' (SuperPos f) f+_Unknown = prism' embed match+  where+    embed = Unknown+    match (Unknown f) = Just f+    match _ = Nothing++_Observed :: (Show (Element f), MonoFoldable f) => Prism' (SuperPos f) (Element f)+_Observed = prism' embed match+  where+    embed = Observed+    match (Observed a) = Just a+    match _ = Nothing++data Quantum =+    forall f. (Show (SuperPos f), Typeable f, Typeable (Element f), MonoFoldable f) => Quantum+        { options   :: SuperPos f+        }++superPos :: (Typeable f, Typeable (Element f), MonoFoldable f) => Traversal' Quantum (SuperPos f)+superPos f (Quantum o) = Quantum <$> (o & _cast %%~ f)++instance Show Quantum where+  show (Quantum xs) = "Quantum " <> show xs++forceDyn :: forall a. Typeable a => Dynamic -> a+forceDyn d =+    fromMaybe (error ("Expected type: " <> expected <> " but Dyn was type: " <> show d)) (fromDynamic d)+  where+    expected = show (typeOf (undefined :: a))++data Graph =+    Graph { _vertices :: !(IM.IntMap (Quantum, IM.IntMap DFilter))+          , _vertexCount :: !Int+          } deriving Show+++makeLenses ''Graph++emptyGraph :: Graph+emptyGraph = Graph mempty 0++valueAt :: Vertex -> Lens' (Graph) Quantum+valueAt (Vertex n) = singular (vertices . ix n . _1)+{-# INLINE valueAt #-}++imAsList :: Iso' (IM.IntMap v ) [(Vertex', v)]+imAsList = iso IM.toList IM.fromList+{-# INLINABLE imAsList #-}++edges :: Vertex -> Lens' (Graph) (IM.IntMap DFilter)+edges (Vertex n) = singular (vertices . ix n . _2)+{-# INLINABLE edges #-}++edgeBetween :: Vertex -> Vertex -> Lens' (Graph) (Maybe DFilter)+edgeBetween from' (Vertex to') = edges from' . at to'+{-# INLINABLE edgeBetween #-}++values :: Traversal' (Graph) (Vertex, Quantum)+values = vertices . imAsList . traversed . alongside coerced _1+{-# INLINABLE values #-}++edgesFrom :: Vertex -> Traversal' (Graph) (Vertex, DFilter)+edgesFrom n = edges n . imAsList . traversed . coerced+{-# INLINE edgesFrom #-}++entropyOfQ :: Quantum -> (Maybe Int)+entropyOfQ (Quantum (Unknown xs)) = Just $ olength xs+entropyOfQ _ = Nothing
+ src/Props/Internal/Links.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE ScopedTypeVariables #-}+module Props.Internal.Links+    ( disjoint+    , equal+    , require+    ) where++import qualified Data.Set as S+import Props.Internal.PropT+import Data.Typeable++{-|+Apply the constraint that two variables may NOT be set to the same value. This constraint is bidirectional.++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.+-}+disjoint :: forall a m. (Monad m, Typeable a, Ord a) => PVar (S.Set a) -> PVar (S.Set a) -> PropT m ()+disjoint a b = do+    constrain a b disj+    constrain b a disj+  where+    disj :: a -> S.Set a -> S.Set a+    disj x xs = S.delete x xs++{-|+Apply the constraint that two variables MUST be set to the same value. This constraint is bidirectional.+-}+equal :: forall a m. (Monad m, Typeable a, Ord a) => PVar (S.Set a) -> PVar (S.Set a) -> PropT m ()+equal a b = do+    constrain a b eq+    constrain b a eq+  where+    eq :: a -> S.Set a -> S.Set a+    eq x xs | x `S.member` xs =  S.singleton x+            | otherwise = S.empty++{-|+Given a choice for @a@; filter for valid options of @b@ using the given predicate.++E.g. if @a@ must always be greater than @b@, you could require:++> require (>) a b +-}+require :: (Monad m, Typeable a, Ord a, Typeable b) => (a -> b -> Bool) -> PVar (S.Set a) -> PVar (S.Set b) -> PropT m ()+require f a b = do+    constrain a b (S.filter . f)
+ src/Props/Internal/MinTracker.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+module Props.Internal.MinTracker where++import qualified Data.IntPSQ as PSQ+import Control.Monad.State+import Control.Lens as L+import Props.Internal.Graph++data MinTracker =+    MinTracker { _minQueue :: (PSQ.IntPSQ Int ()) }++makeClassy ''MinTracker++empty :: MinTracker+empty = MinTracker PSQ.empty++popMinNode :: (HasMinTracker e, MonadState e m) => m (Maybe Vertex)+popMinNode = do+    uses minQueue PSQ.minView >>= \case+      Nothing -> return Nothing+      Just (n, _, _, q) -> do+          minQueue .= q+          return $ Just (Vertex n)+{-# INLINE popMinNode #-}++setNodeEntropy :: (HasMinTracker e, MonadState e m) => Vertex -> Int -> m ()+setNodeEntropy (Vertex nd) ent = do+    minQueue %= snd . PSQ.insertView nd ent ()+{-# INLINE setNodeEntropy #-}++fromList :: [(Vertex, Int)] -> MinTracker+fromList xs = MinTracker (PSQ.fromList (fmap assoc xs))+  where+    assoc (Vertex n, ent) = (n, ent, ())
+ src/Props/Internal/PropT.hs view
@@ -0,0 +1,118 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}++module Props.Internal.PropT+    ( Prop+    , PropT+    , newPVar+    , constrain+    , solve+    , solveAll+    , readPVar+    , PVar+    ) where++import Props.Internal.Graph+import qualified Props.Internal.Props as P+import Control.Monad.State+import Control.Lens+import Data.Typeable+import Data.Dynamic+import Data.MonoTraversable+import Data.Maybe++-- | Pure version of 'PropT'+type Prop a = PropT Identity a+++{-|+A monad transformer for setting up constraint problems.+-}+newtype PropT m a =+    PropT { runGraphM :: StateT Graph m a+           }+    deriving newtype (Functor, Applicative, Monad, MonadIO, MonadTrans)++{-|+A propagator variable where the possible values are contained in the MonoFoldable type @f@.+-}+data PVar f = PVar Vertex+  deriving (Eq -- ^ Nominal equality, Ignores contents+    , Ord -- ^ Nominal ordering, Ignores contents.+    , Show+           )++{-|+Used to create a new propagator variable within the setup for your problem.++@f@ is any MonoFoldable container which contains each of the possible states which the variable could take. In practice this most standard containers make a good candidate, it's easy to define a your own instance if needed.++E.g. For a sudoku solver you would use 'newPVar' to create a variable for each cell, passing a @Set Int@ or @IntSet@ containing the numbers @[1..9]@.+-}+newPVar :: (Monad m, MonoFoldable f, Typeable f, Typeable (Element f)) => f -> PropT m (PVar f)+newPVar xs = PropT $ do+    v <- vertexCount <+= 1+    vertices . at v ?= (Quantum (Unknown xs), mempty)+    return (PVar (Vertex v))++{-|+'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.++Given @PVar f@ and @PVar g@ as arguments, provide a function which will filter/alter the options in @g@ according to the choice.++For a sudoku puzzle @f@ and @g@ each represent cells on the board. If @f ~ Set Int@ and @g ~ Set Int@, then you might pass a constraint filter:++> constrain a b $ \elementA setB -> S.delete elementA setB)++Take a look at some linking functions which are already provided: 'disjoint', 'equal', 'require'+-}+constrain :: (Monad m, Typeable g, Typeable (Element f)) => PVar f -> PVar g -> (Element f -> g -> g) -> PropT m ()+constrain (PVar from') (PVar to') f = PropT $ do+    edgeBetween from' to' ?= toDyn f++readPVar :: (Typeable (Element f)) => Graph -> PVar f -> Element f+readPVar g (PVar v) =+    fromMaybe (error "readPVar called on unsolved graph")+    $ (g ^? valueAt v . folding unpackQuantum)++unpackQuantum :: (Typeable a) => Quantum -> Maybe a+unpackQuantum (Quantum (Observed xs)) = cast xs+unpackQuantum (Quantum _) = Nothing++buildGraph :: (Monad m) => PropT m a -> m (a, Graph)+buildGraph = flip runStateT emptyGraph . runGraphM++{-|+Given an action which initializes and constrains a problem and returns some container of 'PVar's, 'solveT' will attempt to find a solution which passes all valid constraints.+-}+solveT :: (Monad m, Functor f, Typeable (Element g)) => PropT m (f (PVar g)) -> m (Maybe (f (Element g)))+solveT m = do+    (a, g) <- buildGraph m+    case P.solve g of+        Nothing -> return Nothing+        Just solved -> return . Just $ readPVar solved <$> a++{-|+Like 'solveT', but finds ALL possible solutions. There will likely be duplicates.+-}+solveAllT :: (Monad m, Functor f, Typeable (Element g)) => PropT m (f (PVar g)) -> m ([f (Element g)])+solveAllT m = do+    (fa, g) <- buildGraph m+    let gs = P.solveAll g+    return $ gs <&> \g' -> (readPVar g') <$> fa++{-|+Pure version of 'solveT'+-}+solve :: (Functor f, Typeable (Element g)) => Prop (f (PVar g)) -> Maybe (f (Element g))+solve = runIdentity . solveT++{-|+Pure version of 'solveAllT'+-}+solveAll :: (Functor f, Typeable (Element g)) => Prop (f (PVar g)) -> [f (Element g)]+solveAll = runIdentity . solveAllT
+ src/Props/Internal/Props.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveTraversable #-}+module Props.Internal.Props (solve, solveAll) where++import qualified Props.Internal.Graph as G+import Control.Lens hiding (Context)+import Props.Internal.Backtracking+import Props.Internal.Graph+import qualified Props.Internal.MinTracker as MT+import Data.Dynamic+import Data.MonoTraversable+import Data.Foldable+import Control.Monad.State++solve :: Graph+      -> Maybe Graph+solve graph' = fmap snd $ runBacktrack (initMinTracker graph') graph' solve'++solveAll :: Graph -> [Graph]+solveAll graph' = snd <$> runBacktrackAll (initMinTracker graph') graph' solve'++solve' :: Backtrack ()+solve' = MT.popMinNode >>= \case+    Nothing -> return ()+    Just n  -> collapse n *> solve'+{-# INLINABLE solve' #-}++collapse :: G.Vertex+         -> Backtrack ()+collapse n = do+    focused <- use (singular (graph . valueAt n))+    choicesOfQ' focused n+{-# INLINE collapse #-}++choicesOfQ' :: Quantum -> Vertex -> Backtrack ()+choicesOfQ' (Quantum (Observed{})) _ = error "Can't collapse an already collapsed node!"+choicesOfQ' (Quantum (Unknown xs :: SuperPos f)) n = do+    let options = otoList xs+    choice <- select options+    graph . valueAt n . superPos .= (Observed choice :: SuperPos f)+    propagate (n, toDyn choice)+{-# INLINE choicesOfQ' #-}++initMinTracker :: Graph -> MT.MinTracker+initMinTracker graph' = MT.fromList (allEntropies ^.. traversed . below _Just)+    where+      allEntropies :: [(G.Vertex, Maybe Int)]+      allEntropies = allNodes ^.. traversed . alongside id (to entropyOfQ)+      allNodes :: [(G.Vertex, Quantum)]+      allNodes =  graph' ^.. values++propagate :: (Vertex, DChoice) -> Backtrack ()+propagate (from', choice) = do+    allEdges <- gets (toListOf (graph . edgesFrom from'))+    for_ allEdges step'+    where+      step' :: (Vertex, DFilter) -> Backtrack ()+      step' e = propagateSingle choice e+{-# INLINE propagate #-}++propagateSingle :: DChoice -> (Vertex, DFilter) -> Backtrack ()+propagateSingle v (to', dfilter) = do+    graph . valueAt to' %%= alterQ >>= \case+      Nothing -> return ()+      Just newEnt -> MT.setNodeEntropy to' newEnt+    return ()+  where+    alterQ :: Quantum -> (Maybe Int, Quantum)+    alterQ (Quantum (Unknown xs :: SuperPos f)) = do+        let filteredDown = (forceDyn $ dynApp (dynApp dfilter v) (toDyn xs) :: f)+         in (Just $ olength filteredDown, Quantum (Unknown filteredDown))+    alterQ q = (Nothing, q)+{-# INLINE propagateSingle #-}