summaryrefslogtreecommitdiff
path: root/src/MyQueens.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/MyQueens.hs')
-rw-r--r--src/MyQueens.hs88
1 files changed, 54 insertions, 34 deletions
diff --git a/src/MyQueens.hs b/src/MyQueens.hs
index a3c5e0b..904921a 100644
--- a/src/MyQueens.hs
+++ b/src/MyQueens.hs
@@ -1,11 +1,15 @@
1{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
1{-# language NoImplicitPrelude #-} 2{-# language NoImplicitPrelude #-}
2module MyQueens where 3module MyQueens where
3-- To run, type `stack ghci` then `:load MyQueens` then `main` 4-- To run, type `stack ghci` then `:load MyQueens` then `main`
4 5
5import Rebase.Prelude 6import Rebase.Prelude
6 7
7data Rank = R1 | R2 | R3 | R4 | R5 | R6 | R7 | R8 8type Rank = Int8
8 deriving (Eq, Enum, Bounded, Show) 9type MaxRank = Rank
10
11minRank :: Rank
12minRank = 1
9 13
10data RankOptions = RankOptions [Rank] | RankChoice Rank 14data RankOptions = RankOptions [Rank] | RankChoice Rank
11 deriving (Show) 15 deriving (Show)
@@ -13,47 +17,63 @@ data RankOptions = RankOptions [Rank] | RankChoice Rank
13type Board = [RankOptions] 17type Board = [RankOptions]
14type PartialBoard = [RankOptions] 18type PartialBoard = [RankOptions]
15 19
16allOptionsColumn :: RankOptions 20select :: MaxRank -> Board -> [Board]
17allOptionsColumn = RankOptions [R1 .. R8] 21select _ [] = error "select on invalid board"
22select maxRank (x@(RankChoice _):xs) = map (x:) (select maxRank xs)
23select maxRank ((RankOptions rs):xs) = dropHopeless $ map (restrict xs) rs
24
25 where
26
27 dropHopeless :: [Board] -> [Board]
28 dropHopeless = filter (not . any hopeless)
29
30 hopeless :: RankOptions -> Bool
31 hopeless (RankOptions []) = True
32 hopeless _ = False
18 33
19allOptionsBoard :: Board 34 filterRankOptions :: (Rank -> Bool) -> RankOptions -> RankOptions
20allOptionsBoard = take 8 $ repeat allOptionsColumn 35 filterRankOptions f (RankOptions rs) = RankOptions (filter f rs)
36 filterRankOptions _ x = x
21 37
22select :: Board -> [Board] 38 restrict :: PartialBoard -> Rank -> PartialBoard
23select (x@(RankChoice _):xs) = map (x:) (select xs) 39 restrict rs r = ((RankChoice r) :) $
24select ((RankOptions rs):xs) = dropHopeless $ map (restrict xs) rs 40 (dropDiagonal pred minRank r) .
25select [] = error "select on invalid board" 41 (dropDiagonal succ maxRank r) .
42 (map (filterRankOptions (/= r))) $
43 rs
26 44
27dropHopeless :: [Board] -> [Board] 45 dropDiagonal :: (Rank -> Rank) -> Rank -> Rank -> PartialBoard -> PartialBoard
28dropHopeless = filter (not . any hopeless) 46 dropDiagonal _ _ _ [] = []
47 dropDiagonal _ bound r x | r == bound = x
48 dropDiagonal next bound r (x:xs) = (filterRankOptions (/= next r) x) : dropDiagonal next bound (next r) xs
29 49
30hopeless :: RankOptions -> Bool 50queens :: MaxRank -> [Board]
31hopeless (RankOptions []) = True 51queens maxRank = foldl1 (.) (take (fromIntegral maxRank) $ repeat select') $ [allOptionsBoard]
32hopeless _ = False
33 52
34filterRankOptions :: (Rank -> Bool) -> RankOptions -> RankOptions 53 where
35filterRankOptions f (RankOptions rs) = RankOptions (filter f rs)
36filterRankOptions _ x = x
37 54
38restrict :: PartialBoard -> Rank -> PartialBoard 55 select' :: [Board] -> [Board]
39restrict rs r = ((RankChoice r) :) $ 56 select' = concatMap (select maxRank)
40 (dropDiagonal pred minBound r) .
41 (dropDiagonal succ maxBound r) .
42 (map (filterRankOptions (/= r))) $
43 rs
44 57
45dropDiagonal :: (Rank -> Rank) -> Rank -> Rank -> PartialBoard -> PartialBoard 58 allOptionsColumn :: RankOptions
46dropDiagonal _ _ _ [] = [] 59 allOptionsColumn = RankOptions [minRank .. maxRank]
47dropDiagonal _ bound r x | r == bound = x
48dropDiagonal next bound r (x:xs) = (filterRankOptions (/= next r) x) : dropDiagonal next bound (next r) xs
49 60
50select' :: [Board] -> [Board] 61 allOptionsBoard :: Board
51select' = concatMap select 62 allOptionsBoard = take (fromIntegral maxRank) $ repeat allOptionsColumn
52 63
53queens :: [Board] 64eightQueens :: IO ()
54queens = foldl1 (.) (take 8 $ repeat select') $ [allOptionsBoard] 65eightQueens = do
66 forM_ qs print
67 print $ length qs
68 where
69 qs = queens 8
55 70
56main :: IO () 71main :: IO ()
57main = do 72main = do
58 forM_ queens print 73 eightQueens
59 print $ length queens 74 -- finding one solution is quick up to 21.
75 forM_ [4..21] $
76 \n -> print (n, head (queens n))
77 -- finding all solutions is only quick up to 12.
78 forM_ [4..12] $
79 \n -> print (n, length (queens n))