summaryrefslogtreecommitdiff
path: root/examples/queens/Main.hs
diff options
context:
space:
mode:
Diffstat (limited to 'examples/queens/Main.hs')
-rw-r--r--examples/queens/Main.hs67
1 files changed, 67 insertions, 0 deletions
diff --git a/examples/queens/Main.hs b/examples/queens/Main.hs
new file mode 100644
index 0000000..a11712c
--- /dev/null
+++ b/examples/queens/Main.hs
@@ -0,0 +1,67 @@
+module Main where
+
+-- base
+import Control.Monad ( forM_, replicateM )
+import Data.List ( find )
+import System.Environment ( getArgs )
+
+import AI.Search.FiniteDomain.Int
+
+-- A helper function to print the chess board.
+printChess :: Int -> Int -> [(Int,Int)] -> IO ()
+printChess width height solutions = do
+ forM_ [1..height] $ \row -> do
+ putStr "[ "
+ case find ((== row) . fst) solutions of
+ Nothing ->
+ forM_ [1..width] line
+ Just (_,c) -> do
+ forM_ [1..c-1] line
+ putStr "Q "
+ forM_ [c+1..width] line
+ putStrLn "]"
+ where
+ line _ = putStr "_ "
+
+-- This function transforms a given Queens puzzle into a constraint.
+toConstraint :: Int -> Int -> Int -> FD (Labeling [(Int,Int)])
+toConstraint count width height = do
+ rows <- replicateM count newVar
+ columns <- replicateM count newVar
+ forM_ rows $ between 1 (int height)
+ forM_ columns $ between 1 (int width)
+ secureQueens (zip rows columns)
+ result <- labeling (rows ++ columns)
+ pure $ do
+ solution <- result
+ pure (zip (take count solution) (drop count solution))
+ where
+ secureQueens [] = pure ()
+ secureQueens (q:qs) = do
+ secureLines qs q
+ secureQueens qs
+ secureLines [] _ = pure ()
+ secureLines ((row,col):qs) queen@(r,c) = do
+ col #/= c
+ row #> r
+ abs (col - c) #/= row - r
+ secureLines qs queen
+
+-- Put it all together.
+main :: IO ()
+main = do
+ putStrLn "Expecting [queen count, board width, board height] as command line arguments."
+ putStrLn "Default is [8, 8, 8]."
+ args <- getArgs
+ let (count, width, height) =
+ case args of
+ [qc, w, h] -> (read qc, read w, read h)
+ _ -> ( 8, 8, 8)
+ putStrLn $ "Placing " ++ show count ++ " queen(s) ..."
+ case runFD (toConstraint count width height) of
+ Unsolvable _ -> putStrLn "Queens puzzle is unsolvable."
+ Unbounded _ -> putStrLn "The constraint formulation is wrong."
+ Solutions xs -> do
+ forM_ xs $ \solution -> do
+ putStrLn "Found a solution:"
+ printChess width height solution \ No newline at end of file