summaryrefslogtreecommitdiff
path: root/src/MyQueens.hs
blob: a3c5e0bcdb81063f6cbbee4a9dc90b266cbdb7a9 (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
{-# language NoImplicitPrelude #-}
module MyQueens where
-- To run, type `stack ghci` then `:load MyQueens` then `main`

import Rebase.Prelude

data Rank = R1 | R2 | R3 | R4 | R5 | R6 | R7 | R8
  deriving (Eq, Enum, Bounded, Show)

data RankOptions = RankOptions [Rank] | RankChoice Rank
  deriving (Show)

type Board = [RankOptions]
type PartialBoard = [RankOptions]

allOptionsColumn :: RankOptions
allOptionsColumn = RankOptions [R1 .. R8]

allOptionsBoard :: Board
allOptionsBoard = take 8 $ repeat allOptionsColumn

select :: Board -> [Board]
select (x@(RankChoice _):xs) = map (x:) (select xs)
select ((RankOptions rs):xs) = dropHopeless $ map (restrict xs) rs
select []                    = error "select on invalid board"

dropHopeless :: [Board] -> [Board]
dropHopeless = filter (not . any hopeless)

hopeless :: RankOptions -> Bool
hopeless (RankOptions []) = True
hopeless _                = False

filterRankOptions :: (Rank -> Bool) -> RankOptions -> RankOptions
filterRankOptions f (RankOptions rs) = RankOptions (filter f rs)
filterRankOptions _ x                = x

restrict :: PartialBoard -> Rank -> PartialBoard
restrict rs r = ((RankChoice r) :) $
  (dropDiagonal pred minBound r) .
  (dropDiagonal succ maxBound r) .
  (map (filterRankOptions (/= r))) $
  rs

dropDiagonal :: (Rank -> Rank) -> Rank -> Rank -> PartialBoard -> PartialBoard
dropDiagonal _ _ _ []                 = []
dropDiagonal _ bound r x | r == bound = x
dropDiagonal next bound r (x:xs)      = (filterRankOptions (/= next r) x) : dropDiagonal next bound (next r) xs

select' :: [Board] -> [Board]
select' = concatMap select

queens :: [Board]
queens = foldl1 (.) (take 8 $ repeat select') $ [allOptionsBoard]

main :: IO ()
main = do
  forM_ queens print
  print $ length queens