Solution to /r/dailyprogrammer's "Diagonal Maze" problem: https://www.reddit.com/r/dailyprogrammer/comments/3f9o7k/20150731_challenge_225_intermediate_diagonal_maze/

diagonalMaze.hs

import Control.Monad (when, forM)
import Data.Array
import Data.Char (isSpace)
import Data.List (elemIndices, transpose, intercalate)
import Data.Maybe (catMaybes)
import Data.Monoid ((<>))
import Data.Text (Text)
import System.Exit (die)
import Text.Printf (printf)
import qualified Data.List.NonEmpty as N
import qualified Data.Text as T
import qualified Data.Text.IO as T


-- A type representing the original, orthogonal Maze.
--
-- `mazeSize` is the number of cells in x and y directions. `mazeCellSize`
-- is the dimensions of the rectangle of spaces "inside" a cell.
--
-- (x, y) `elem` mazeHWalls means there is a wall running from the (x, y)th
-- corner (+) to the right. (x, y) `elem` mazeVWalls means the same, with
-- walls running down.

type WallPosition = (Int, Int)

data Maze = Maze { mazeSize     :: (Int, Int)
                 , mazeCellSize :: (Int, Int)
                 , mazeHWalls   :: [WallPosition]
                 , mazeVWalls   :: [WallPosition] }


-- Display a maze turned 45 degrees.
diagonal :: Maze -> Array (Int, Int) Char
diagonal (Maze (m, n) (cW, cH) hWalls vWalls) =

  -- First, construct a large blank array of spaces.
  let size = m * cW + n * cH
      blank = listArray ((0, 0), (size - 1, size - 1)) (repeat ' ')

  -- `corner` transforms some scaled-down coordinates to the exact point
  -- in the array where the top-left corner of a horizontal wall should
  -- be drawn.
  --
  -- We would render a maze consisting entirely of walls as e.g.:
  --
  --             01234567
  --
  --           0      /@
  --           1     /  \
  --           2    /\   .
  --           3   /  \
  --           4  /\   .
  --           5 /  \
  --           6 \   .
  --           7  \
  --               .
  --
  -- There are (n * cH) forward slashes, so the corner marked '@' (which
  -- would normally contain a '\') is at (n * cH, 0) in the array. Then,
  -- moving "down" from that corner actually moves (-cH, cW) in our new
  -- array, and moving "right" moves by (cH, cW). Then we can extract a
  -- linear transformation using these movements as the "basis" for our new
  -- vector space, and (n * cH, 0) as the new origin:

      corner :: (Int, Int) -> (Int, Int)
      corner (x, y) = ((n - y) * cH + x * cW,
                          y    * cH + x * cW)

  -- `updateH` makes a [(i, e)] update from a horizontal wall's top
  -- coordinate; `updateV` does the same for vertical walls. We then
  -- construct a big list of updates and execute it over the blank array.

      updateH :: WallPosition -> [((Int, Int), Char)]
      updateH (x, y) = let (x', y') = corner (x, y) in
        [((x' + k, y' + k), '\\') | k <- [0..cW - 1]]

      updateV :: WallPosition -> [((Int, Int), Char)]
      updateV (x, y) = let (x', y') = corner (x, y) in
        [((x' - k - 1, y' + k), '/') | k <- [0 .. cH - 1]]

      updates :: [((Int, Int), Char)]
      updates = concat $ map updateH hWalls ++ map updateV vWalls

  in blank // updates


-- Turn a rectangle of characters from an Array into a String with
-- newlines.
showCharArray :: Array (Int, Int) Char -> String
showCharArray arr =
  let ((xMin, yMin), (xMax, yMax)) = bounds arr
  in unlines [[arr ! (x, y) | x <- [xMin..xMax]] | y <- [yMin..yMax]]


-- Read the height line in a maze file.
readHeight :: IO Int
readHeight = do
  -- Handle the first line of input.
  heightLine <- getLine
  height <- case reads heightLine of
              [(x, "")] -> return x
              _         -> die "Height must be an integer"

  when (height < 0) $ die "Height may not be negative"
  return height


-- Read the lines from a maze file and pad them nicely.
readMazeLines :: IO [Text]
readMazeLines = do
  rawMazeLines <- T.lines <$> T.getContents
  let strippedMazeLines = map T.stripEnd rawMazeLines
      width = maximum (map T.length strippedMazeLines)
  return $ map (T.justifyLeft width ' ') strippedMazeLines


-- Turn a list of padded maze lines into an array.
makeMazeArray :: [Text] -> Array (Int, Int) Char
makeMazeArray mazeLines =
  let xMax = T.length (head mazeLines) - 1
      yMax = length mazeLines - 1
  in listArray ((0, 0), (xMax, yMax))
               (concat $ transpose $ map T.unpack mazeLines)


-- Read the cell dimensions from the padded lines of a maze.
readCellDimensions :: Array (Int, Int) Char -> IO (Int, Int)
readCellDimensions maze = do
  let ((xMin, yMin), (xMax, yMax)) = bounds maze
      firstRow = [maze ! (x, yMin) | x <- [xMin..xMax]]
      firstCol = [maze ! (xMin, y) | y <- [yMin..yMax]]

  cellWidth <- case elemIndices '+' firstRow of
    []      -> die "The first row must contain a +"
    [_]     -> die "The first row must contain more than one +"
    (i:j:_) -> if i == 0 then return (j - 1)
                         else die "The top-left corner must be a +"

  -- `elemIndices x xs` is strictly increasing and nowhere negative, so the
  -- `n`th element must be `>= n`. This means `j >= 1` in the above pattern
  -- match, and thus `cellWidth >= 0`. There's one more case to eliminate:

  when (cellWidth == 0) $ die "Cell width must be non-zero"

  -- Suppose that `width == 0`. Then by definition of `width`, we would
  -- have that `T.length line == 0` for each `line` in `mazeLines`, so
  -- `plusColumns` must be `[]`, and we've already crashed. Thus at this
  -- point, `width > 0`, and all lines are non-empty, so the following is
  -- safe:

  -- We find the height of a cell in a similar way:

  cellHeight <- case elemIndices '+' firstCol of
    [] -> die "The first column must contain a +"
    [_] -> die "The first column must contain more than one +"
    (i:j:_) -> if i == 0 then return (j - 1)
                         else die "The top-left corner must be a +"

  when (cellHeight == 0) $ die "Cell height must be non-zero"

  return (cellWidth, cellHeight)


-- Verify if the given maze array (assuming the given cell dimensions) can
-- be split up into cells, and return how many such cells there are in each
-- dimension.
readSize :: (Int, Int) -> Array (Int, Int) Char -> IO (Int, Int)
readSize (cW, cH) maze = do
  -- Our (m x n) maze should look like:
  --
  --                 <---- m cells ---->
  --
  --                 01234501234501234501 <-- (x mod (cellWidth + 1))
  --
  --             ^ 0 +-----+-----+-----+
  --             | 1 |                 |
  --             | 2 |                 |
  --             | 3 |                 |
  --     n cells | 0 +-----+     +     +
  --             | 1 |           |     | \
  --             | 2 |           |     | |-> cellHeight
  --             | 3 |           |     | /
  --             v 0 +-----+-----+-----+
  --               1  \___/
  --                    '-> cellWidth
  --               ^
  --               '------------------------- (y mod (cellHeight + 1))
  --
  -- We see that, when mapping our ASCII maze to an array:
  --
  --   * The array dimensions are (1, 1) mod (cW + 1, cH + 1).
  --
  --     * In fact, they are (m * (cW + 1) + 1, n * (cH + 1) + 1).
  --
  --   * The corners are at (0, 0) mod (cW + 1, cH + 1).
  --
  --   * The vertical walls are at (0, y) mod (cW + 1, cH + 1), with y > 0.
  --
  --     * They should be either | or space.
  --
  --   * The horizontal walls are at (x, 0) mod (cW + 1, cH + 1), with x > 0.
  --
  --     * They should be either - or space.
  --
  --   * All other coordinates should be empty spaces.
  --
  -- Let's encode these requirements:

  let ((xMin, yMin), (xMax, yMax)) = bounds maze
      width  = xMax - xMin + 1
      height = yMax - yMin + 1

  (m, n) <- case (width `divMod` (cW+1), height `divMod` (cH+1)) of
              ((m, 1), (n, 1)) -> return (m, n)
              _ -> die (printf "Invalid maze dimensions: should be \
                               \(%dm+1, %dn+1) for some (m, n)" (cW+1) (cH+1))

  let validCharsFor :: (Int, Int) -> [Char]
      validCharsFor (x, y) =
        case (x `mod` (cW+1), y `mod` (cH+1)) of
          (0, 0) -> ['+']
          (0, _) -> [' ', '|']
          (_, 0) -> [' ', '-']
          (_, _) -> [' ']

  forM (assocs maze) $ \(i, e) -> do
    let valid = validCharsFor i
        prettyValid = intercalate " or " (map show valid)
    when (e `notElem` valid) $
      die (printf "Invalid char at %s: expected %s, found %s"
                  (show i) prettyValid (show e))

  return (m, n)


-- Assuming the given cell dimensions, parse walls from the given maze
-- bitmap.
readWalls :: (Int, Int) -> Array (Int, Int) Bool
                        -> IO ([WallPosition], [WallPosition])
readWalls (cellWidth, cellHeight) maze = do
  let ((xMin, yMin), (xMax, yMax)) = bounds maze
      width  = xMax - xMin + 1
      height = yMax - yMin + 1

  let (cW, cH) = (cellWidth, cellHeight)

  -- Read wall masks as lists of (top-left corner, mask).
  let hWallMasks :: [((Int, Int), [Bool])]
      hWallMasks = do
        sx <- [0, cW+1 .. width - 1 - (cW+1)]
        sy <- [0, cH+1 .. height - 1]
        let coord = (sx `div` (cW + 1), sy `div` (cH+1))
            bits = [maze ! (sx + k, sy) | k <- [1..cW]]
        return (coord, bits)

      vWallMasks :: [((Int, Int), [Bool])]
      vWallMasks = do
        sx <- [0, cW+1 .. width - 1]
        sy <- [0, cH+1 .. height - 1 - (cH+1)]
        let coord = (sx `div` (cW+1), sy `div` (cH+1))
            bits = [maze ! (sx, sy + k) | k <- [1..cH]]
        return (coord, bits)

  -- Handle our wall masks: either the bits in a wall should be "all on"
  -- (in which case there's a wall) or "all off" (in which case there
  -- isn't). Using `catMaybes`, we get a list of scaled-down top-left
  -- coordinates for where walls start.
  let getWalls :: [((Int, Int), [Bool])] -> IO [(Int, Int)]
      getWalls masks =
        fmap catMaybes $ forM masks $ \(c, mask) -> do
          case mask of x | and x      -> return (Just c)
                       x | not (or x) -> return Nothing
                       _              -> die "Broken wall"

  hWalls <- getWalls hWallMasks
  vWalls <- getWalls vWallMasks
  return (hWalls, vWalls)


-- Read a maze from a maze file.
readMaze :: IO Maze
readMaze = do
  height <- readHeight
  mazeLines <- readMazeLines

  -- `height` *should* be the number of lines we just read.
  let realHeight = length mazeLines
  when (realHeight /= height) $ do
    die (printf "Given height was %d, but read %d lines" height realHeight)

  let maze = makeMazeArray mazeLines
  (cW, cH) <- readCellDimensions maze
  (m, n) <- readSize (cW, cH) maze

  let bitmap = fmap (not . isSpace) maze
  (hWalls, vWalls) <- readWalls (cW, cH) bitmap

  return (Maze (m, n) (cW, cH) hWalls vWalls)


main :: IO ()
main = do
  maze <- readMaze
  putStrLn (showCharArray $ diagonal maze)