Skip to content

Instantly share code, notes, and snippets.

@maurisvh
Last active September 27, 2015 18:58
Show Gist options
  • Save maurisvh/a1094eeaf0174f56210f to your computer and use it in GitHub Desktop.
Save maurisvh/a1094eeaf0174f56210f to your computer and use it in GitHub Desktop.
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)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment