From 2bc321995dfe6db5894c66356fdf506d96055589 Mon Sep 17 00:00:00 2001
From: Andrew Cady <d@jerkface.net>
Date: Fri, 14 Jun 2019 11:28:00 -0400
Subject: MyQueens: support for arbitrary board sizes

---
 src/MyQueens.hs | 88 +++++++++++++++++++++++++++++++++++----------------------
 1 file 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 @@
+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
 {-# 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)
+type Rank = Int8
+type MaxRank = Rank
+
+minRank :: Rank
+minRank = 1
 
 data RankOptions = RankOptions [Rank] | RankChoice Rank
   deriving (Show)
@@ -13,47 +17,63 @@ data RankOptions = RankOptions [Rank] | RankChoice Rank
 type Board = [RankOptions]
 type PartialBoard = [RankOptions]
 
-allOptionsColumn :: RankOptions
-allOptionsColumn = RankOptions [R1 .. R8]
+select :: MaxRank -> Board -> [Board]
+select _ []                    = error "select on invalid board"
+select maxRank (x@(RankChoice _):xs) = map (x:) (select maxRank xs)
+select maxRank ((RankOptions rs):xs) = dropHopeless $ map (restrict xs) rs
+
+  where
+
+    dropHopeless :: [Board] -> [Board]
+    dropHopeless = filter (not . any hopeless)
+
+    hopeless :: RankOptions -> Bool
+    hopeless (RankOptions []) = True
+    hopeless _                = False
 
-allOptionsBoard :: Board
-allOptionsBoard = take 8 $ repeat allOptionsColumn
+    filterRankOptions :: (Rank -> Bool) -> RankOptions -> RankOptions
+    filterRankOptions f (RankOptions rs) = RankOptions (filter f rs)
+    filterRankOptions _ x                = x
 
-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"
+    restrict :: PartialBoard -> Rank -> PartialBoard
+    restrict rs r = ((RankChoice r) :) $
+      (dropDiagonal pred minRank r) .
+      (dropDiagonal succ maxRank r) .
+      (map (filterRankOptions (/= r))) $
+      rs
 
-dropHopeless :: [Board] -> [Board]
-dropHopeless = filter (not . any hopeless)
+    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
 
-hopeless :: RankOptions -> Bool
-hopeless (RankOptions []) = True
-hopeless _                = False
+queens :: MaxRank -> [Board]
+queens maxRank = foldl1 (.) (take (fromIntegral maxRank) $ repeat select') $ [allOptionsBoard]
 
-filterRankOptions :: (Rank -> Bool) -> RankOptions -> RankOptions
-filterRankOptions f (RankOptions rs) = RankOptions (filter f rs)
-filterRankOptions _ x                = x
+  where
 
-restrict :: PartialBoard -> Rank -> PartialBoard
-restrict rs r = ((RankChoice r) :) $
-  (dropDiagonal pred minBound r) .
-  (dropDiagonal succ maxBound r) .
-  (map (filterRankOptions (/= r))) $
-  rs
+    select' :: [Board] -> [Board]
+    select' = concatMap (select maxRank)
 
-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
+    allOptionsColumn :: RankOptions
+    allOptionsColumn = RankOptions [minRank .. maxRank]
 
-select' :: [Board] -> [Board]
-select' = concatMap select
+    allOptionsBoard :: Board
+    allOptionsBoard = take (fromIntegral maxRank) $ repeat allOptionsColumn
 
-queens :: [Board]
-queens = foldl1 (.) (take 8 $ repeat select') $ [allOptionsBoard]
+eightQueens :: IO ()
+eightQueens = do
+  forM_ qs print
+  print $ length qs
+  where
+    qs = queens 8
 
 main :: IO ()
 main = do
-  forM_ queens print
-  print $ length queens
+  eightQueens
+  -- finding one solution is quick up to 21.
+  forM_ [4..21] $
+    \n -> print (n, head (queens n))
+  -- finding all solutions is only quick up to 12.
+  forM_ [4..12] $
+    \n -> print (n, length (queens n))
-- 
cgit v1.2.3