diff options
Diffstat (limited to 'src/MyQueens.hs')
-rw-r--r-- | src/MyQueens.hs | 88 |
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 #-} |
2 | module MyQueens where | 3 | module 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 | ||
5 | import Rebase.Prelude | 6 | import Rebase.Prelude |
6 | 7 | ||
7 | data Rank = R1 | R2 | R3 | R4 | R5 | R6 | R7 | R8 | 8 | type Rank = Int8 |
8 | deriving (Eq, Enum, Bounded, Show) | 9 | type MaxRank = Rank |
10 | |||
11 | minRank :: Rank | ||
12 | minRank = 1 | ||
9 | 13 | ||
10 | data RankOptions = RankOptions [Rank] | RankChoice Rank | 14 | data RankOptions = RankOptions [Rank] | RankChoice Rank |
11 | deriving (Show) | 15 | deriving (Show) |
@@ -13,47 +17,63 @@ data RankOptions = RankOptions [Rank] | RankChoice Rank | |||
13 | type Board = [RankOptions] | 17 | type Board = [RankOptions] |
14 | type PartialBoard = [RankOptions] | 18 | type PartialBoard = [RankOptions] |
15 | 19 | ||
16 | allOptionsColumn :: RankOptions | 20 | select :: MaxRank -> Board -> [Board] |
17 | allOptionsColumn = RankOptions [R1 .. R8] | 21 | select _ [] = error "select on invalid board" |
22 | select maxRank (x@(RankChoice _):xs) = map (x:) (select maxRank xs) | ||
23 | select 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 | ||
19 | allOptionsBoard :: Board | 34 | filterRankOptions :: (Rank -> Bool) -> RankOptions -> RankOptions |
20 | allOptionsBoard = take 8 $ repeat allOptionsColumn | 35 | filterRankOptions f (RankOptions rs) = RankOptions (filter f rs) |
36 | filterRankOptions _ x = x | ||
21 | 37 | ||
22 | select :: Board -> [Board] | 38 | restrict :: PartialBoard -> Rank -> PartialBoard |
23 | select (x@(RankChoice _):xs) = map (x:) (select xs) | 39 | restrict rs r = ((RankChoice r) :) $ |
24 | select ((RankOptions rs):xs) = dropHopeless $ map (restrict xs) rs | 40 | (dropDiagonal pred minRank r) . |
25 | select [] = error "select on invalid board" | 41 | (dropDiagonal succ maxRank r) . |
42 | (map (filterRankOptions (/= r))) $ | ||
43 | rs | ||
26 | 44 | ||
27 | dropHopeless :: [Board] -> [Board] | 45 | dropDiagonal :: (Rank -> Rank) -> Rank -> Rank -> PartialBoard -> PartialBoard |
28 | dropHopeless = 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 | ||
30 | hopeless :: RankOptions -> Bool | 50 | queens :: MaxRank -> [Board] |
31 | hopeless (RankOptions []) = True | 51 | queens maxRank = foldl1 (.) (take (fromIntegral maxRank) $ repeat select') $ [allOptionsBoard] |
32 | hopeless _ = False | ||
33 | 52 | ||
34 | filterRankOptions :: (Rank -> Bool) -> RankOptions -> RankOptions | 53 | where |
35 | filterRankOptions f (RankOptions rs) = RankOptions (filter f rs) | ||
36 | filterRankOptions _ x = x | ||
37 | 54 | ||
38 | restrict :: PartialBoard -> Rank -> PartialBoard | 55 | select' :: [Board] -> [Board] |
39 | restrict 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 | ||
45 | dropDiagonal :: (Rank -> Rank) -> Rank -> Rank -> PartialBoard -> PartialBoard | 58 | allOptionsColumn :: RankOptions |
46 | dropDiagonal _ _ _ [] = [] | 59 | allOptionsColumn = RankOptions [minRank .. maxRank] |
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 | ||
49 | 60 | ||
50 | select' :: [Board] -> [Board] | 61 | allOptionsBoard :: Board |
51 | select' = concatMap select | 62 | allOptionsBoard = take (fromIntegral maxRank) $ repeat allOptionsColumn |
52 | 63 | ||
53 | queens :: [Board] | 64 | eightQueens :: IO () |
54 | queens = foldl1 (.) (take 8 $ repeat select') $ [allOptionsBoard] | 65 | eightQueens = do |
66 | forM_ qs print | ||
67 | print $ length qs | ||
68 | where | ||
69 | qs = queens 8 | ||
55 | 70 | ||
56 | main :: IO () | 71 | main :: IO () |
57 | main = do | 72 | main = 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)) | ||