summaryrefslogtreecommitdiff log msg author committer range
path: root/examples/queens/Main.hs
blob: a11712ca63732a08122088588fe70cf22b658e77 (plain)
 ```1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 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``````