September Morn Update

Task/N-queens-problem/Haskell/n-queens-problem-4.hs

@@ -1,40 +1,39 @@
 import Data.List (transpose, intercalate)
+import Data.Bool (bool)
 
 queenPuzzle :: Int -> Int -> [[Int]]
 queenPuzzle nRows nCols
   | nRows <= 0 = [[]]
   | otherwise =
     foldr
-      (\solution a ->
+      (\qs a ->
           a ++
           foldr
-            (\iCol b ->
-                if safe (nRows - 1) iCol solution
-                  then b ++ [solution ++ [iCol]]
-                  else b)
+            (\iCol b -> bool b (b ++ [qs ++ [iCol]]) (safe (nRows - 1) iCol qs))
             []
             [1 .. nCols])
       []
       (queenPuzzle (nRows - 1) nCols)
-  where
-    safe iRow iCol solution =
-      True `notElem`
-      zipWith
-        (\sc sr ->
-            (iCol == sc) || (sc + sr == iCol + iRow) || (sc - sr == iCol - iRow))
-        solution
-        [0 .. iRow - 1]
 
--- TEST ------------------------------------------------------------------------
+safe :: Int -> Int -> [Int] -> Bool
+safe iRow iCol qs =
+  (not . or) $
+  zipWith
+    (\sc sr ->
+        (iCol == sc) || (sc + sr == (iCol + iRow)) || (sc - sr == (iCol - iRow)))
+    qs
+    [0 .. iRow - 1]
+
+-- TEST ---------------------------------------------------
 -- 10 columns of solutions for the 7*7 board:
 showSolutions :: Int -> Int -> [String]
-showSolutions nCols nBoardSize =
+showSolutions nCols nSize =
   unlines <$>
-  (((intercalate "   " <$>) . transpose . (boardLines <$>)) <$>
-   chunksOf nCols (queenPuzzle nBoardSize nBoardSize))
+  ((fmap (intercalate "   ") . transpose . fmap boardLines) <$>
+   chunksOf nCols (queenPuzzle nSize nSize))
   where
     boardLines rows =
-      (\r -> foldMap (\c -> if_ (c == r) "♛" ".") [1 .. (length rows)]) <$> rows
+      (\r -> (bool '.' '♛' . (== r)) <$> [1 .. (length rows)]) <$> rows
 
 chunksOf :: Int -> [a] -> [[a]]
 chunksOf i xs = take i <$> ($ (:)) (splits xs) []
@@ -42,9 +41,5 @@ chunksOf i xs = take i <$> ($ (:)) (splits xs) []
     splits [] _ n = []
     splits l c n = l `c` splits (drop i l) c n
 
-if_ :: Bool -> a -> a -> a
-if_ True x _ = x
-if_ False _ y = y
-
 main :: IO ()
-main = mapM_ putStrLn $ showSolutions 10 7
+main = (putStrLn . unlines) $ showSolutions 10 7

Task/N-queens-problem/Haskell/n-queens-problem-5.hs

@@ -0,0 +1,63 @@
+import Control.Monad
+import System.Environment
+
+-- | data types for the puzzle
+type Row    = Int
+type State  = [Row]
+type Thread = [Row]
+
+-- | utility functions
+empty = null
+
+-- | Check for infeasible states
+infeasible :: Int -> (State, Thread) -> Bool
+infeasible n ([], _)    = False
+infeasible n ((r:rs),t) = length rs >= n || attack r rs || infeasible n (rs, t)
+
+feasible n st = not $ infeasible n st
+
+-- | Check if a row is attacking another row of a state
+attack :: Row -> [Row] -> Bool
+attack r rs = r `elem` rs
+            || r `elem` (upperDiag rs)
+            || r `elem` (lowerDiag rs)
+  where
+    upperDiag xs = zipWith (-) xs [1..]
+    lowerDiag xs = zipWith (+) xs [1..]
+
+-- | Check if it is a goal state
+isGoal :: Int -> (State, Thread) -> Bool
+isGoal n (rs,t) = (feasible n (rs,t)) && (length rs == n)
+
+-- | Perform a move
+move :: Int -> (State, Thread) -> (State, Thread)
+move x (s,t)  = (x:s, x:t)
+
+choices n = [1..n]
+moves n   = pure move <*> choices n
+
+emptySt = ([],[])
+
+-- | Breadth-first search
+bfs :: Int -> [(State, Thread)] -> (State, Thread)
+bfs n []                     = error "Couldn't find a feasible solution"
+bfs n sts | (not.empty) goal = head goal
+          | otherwise        = bfs n sts'
+  where
+    goal = filter (isGoal n) sts'
+    sts' = filter (feasible n) $ (moves n) <*> sts
+
+-- | Depth-first search
+dfs :: Int -> (State, Thread) -> [(State, Thread)]
+dfs n st | isGoal n st     = [st]
+         | infeasible n st = [emptySt]
+         | otherwise       = do x   <- [1..n]
+                                st' <- dfs n $ move x st
+                                guard $ st' /= emptySt
+                                return st'
+
+main = do
+  [narg] <- getArgs
+  let n = read narg :: Int
+  print (bfs n [emptySt])
+  print (head $ dfs n emptySt)