No posts for a month and now this one's a rerun. Don't ask me why I'm fixated upon such a stupid problem, but I'm playing checkers again. It's the exact same exercise I described in a previous write-up: determine if any pieces on a checkers board are in danger of being attacked. I've already demonstrated how the array manipulation prowess of Q lend themselves well to this puzzle, but I also believe ADTs and monads simplify things further, which is why I'm taking another crack at it in Haskell. I should emphasize the Haskell part of "Haskell," because the code here is not actually Purescript like it is in my other posts—I've got a new job where I'm required to write Haskell-ass Haskell, so I should brush up on it.
{-# LANGUAGE UnicodeSyntax #-}
import Control.Arrow ((***))
import Control.Monad (foldM, join, liftM2)
import Data.Array (range)
import Data.Map (elems, fromListWith)
import Data.Maybe (isJust)
As always, I'm using Haskell as a saner J, which means liftM2 (lift2 in Purescript) is a must.
data Cell = R | B | E deriving Show
type Board = [[Cell]]
While the Q solution relied on using numerical values to represent which checkers pieces occupied which cell, I figured an explicit algebraic data type would make more sense. A Cell can have instances of R, B, or E, which represent red pieces, black pieces, or empty cells respectively. A 2D list of Cell values is represented by a Board type synonym. Some safe and unsafe board configurations follow.
unsafe1 ∷ Board
unsafe1 =
[[E, R, E, E],
[E, E, B, E],
[E, R, E, E],
[E, E, B, E]]
unsafe2 ∷ Board
unsafe2 =
[[E, R, E, E],
[B, E, E, E],
[E, R, E, E],
[B, E, E, E]]
safe1 ∷ Board
safe1 =
[[E, B, E, E],
[E, E, R, E],
[E, E, E, R],
[E, E, E, B]]
safe2 ∷ Board
safe2 =
[[E, B, E, E],
[R, E, R, E],
[E, E, B, E],
[B, R, B, B]]
Boards are analyzed the same way as before: segregate the diagonal runs of boards into linear arrays, and fold across them. If a black piece precedes a red piece in any of these arrays, the board is considered dangerous. It is safe otherwise. The Q code checked for red-black alignments instead of black-red because it accumulated the indices of its diagonal rows differently, but the principle is the same.
Diagonals are found in a similar manner as well.
enumerate is the first function necessary for this process.
enumerate ∷ [a] → [Int]
enumerate = curry range 0 . pred . length
It takes a list and enumerates each of its indices.
> enumerate unsafe1
[0,1,2,3]
Enumerating a Board and its head gives the n×m dimensions required for the cartesian product.
cartesian ∷ Board → [(Int, Int)]
cartesian = (liftM2 . liftM2) (,) enumerate (enumerate . head)
Some interesting concepts rear their heads already here. There is no need for a dedicated cross product function in Haskell; it is enough to lift a tuple constructor (,) into the monadic context of [] to return a pairing of all indices. If this seems like magic, recall that the definition of liftM2 is nothing more than
f <$> x <*> y
Mapping a binary function like (,) across one list x would return a list of partially-applied constructors waiting for their second tuple value. Applying these functions to the second list y yields the complete pairing.
That explains the first use of liftM2 in cartesian. Recall that liftM2 in the context of functions is J-style monadic fork f (g x) (h x). So (liftM2 . liftM2) is a forking combinator in the context of [] that performs a train of three functions against a Board.
> cartesian unsafe1
[(0,0),(0,1),(0,2),(0,3),(1,0),(1,1),(1,2),(1,3),(2,0),(2,1),(2,2),(2,3),(3,0),(3,1),(3,2),(3,3)]
Coercing these values into a map requires more manipulation. The product must be converted into a list of the form
[(Int, [Int])]
where the first integer is the sum of coordinates, and the second integer is an index in the flattened board, lifted into a list singleton for concatenation purposes.
The second integer is provided by zipping the product against another enumerate, resulting in a list of nested tuples.
> (zip <*> enumerate) (cartesian unsafe1)
[((0,0),0),((0,1),1),((0,2),2),((0,3),3),((1,0),4),((1,1),5),((1,2),6),((1,3),7),((2,0),8),((2,1),9),((2,2),10),((2,3),11),((3,0),12),((3,1),13),((3,2),14),((3,3),15)]
Then performing a bifunctor mapping operation with uncurry (+) and pure will provide the shape we seek.
> (map (uncurry (+) *** pure) . (zip <*> enumerate)) (cartesian unsafe1)
[(0,[0]),(1,[1]),(2,[2]),(3,[3]),(1,[4]),(2,[5]) …]
This operation won't work in the REPL because pure is ambiguous, but you can see how it all comes together once written in a properly-typed function.
diagonal ∷ [(Int, Int)] → [[Int]]
diagonal = elems . fromListWith (++) . map withRowNum . withIndices
where
withIndices = zip <*> enumerate
withRowNum = uncurry (+) *** pure
fromListWith (++) converts the list to Map Int [Int], and then elems will return a 2D list representing diagonally-segregated indices.
> (diagonal . cartesian) unsafe1
[[0],[4,1],[8,5,2],[12,9,6,3],[13,10,7],[14,11],[15]]
You can see how this mirrors the Q example, though the indices are compiled in reverse. This is why the Haskell program checks for black-red adjacent cells rather than the other way around.
The project functions takes a list of cells and a list of desired indices, and returns only the cells that match.
project ∷ [Cell] → [Int] → [Cell]
project = map . (!!)
> project [E, R, B, E] [1, 1, 1, 2]
[R,R,R,B]
Curried with a flattened board as its first argument, mapping project across each sublist of the diagonally-segregated indices provides a diagonal projection of the original board.
split ∷ Board → Board
split = liftM2 (map . project) join (diagonal . cartesian)
> split unsafe1
[[E],[E,R],[E,E,E],[E,R,B,E],[E,E,E],[B,E],[E]]
Of course this projection is hardly unsafe, seeing as how there are no black-red pairs to be found. The program must check the diagonals in both directions, which involves reversing a board on its x-axis.
bothDirections ∷ Board → Board
bothDirections = liftM2 (++) split (split . map reverse)
> bothDirections unsafe1
[[E],[E,R],[E,E,E],[E,R,B,E],[E,E,E],[B,E],[E],[E],[E,E],[E,B,R],[E,E,E,E],[B,R,E],[E,E],[E]]
There's a B,R in there somewhere.
Haskell's true beauty reveals itself at this stage of the program. The strongly typed Cell means we don't have to do weird arithmetic, and the existence of monads allows us to short-circuit the evaluation of any unsafe board, rather than mapping over the whole thing as we would in Q.
neighborCheck ∷ Cell → Cell → Maybe Cell
neighborCheck B R = Nothing
neighborCheck _ ω = Just ω
This checking procedure is folded over each diagonal row. As stated earlier, if a black piece is found in front of a red piece, the board is unsafe. Returning Nothing signals this. Otherwise, the second cell's contents are provided as the new accumulator wrapped in a Just. Folding a function (b → a → f b) with foldM can signal failure early on, unlike a generic fold.
> foldM neighborCheck E [E,R,B,E,E,R]
Just R
> foldM neighborCheck E [E,B,R,E,E,R]
Nothing
traverse maps a function across a structure within an applicative context. That is to say, much like how
(+) <$> Nothing <*> (Just 1)
will terminate when it encounters Nothing, a traversal will also cease mapping if it encounters a failure case. It is therefore enough to check an entire board with
traverse (foldM neighborCheck E)
which performs a foldM of neighborCheck across each diagonal row sublist, but short-circuits to Nothing the moment an unsafe configuration is detected.
A board is safe when a Just is returned.
safe ∷ Board → Bool
safe = isJust . traverse (foldM neighborCheck E) . bothDirections
> safe <$> [unsafe1, unsafe2, safe1, safe2]
[False,False,True,True]
It's not as terse as Q, but I think I prefer this implementation, and Haskell in general.