adventofcode-2019/day03/Day03.hs

import Data.List
import Data.List.Split
import Flow

main :: IO ()
main = do
  inputText <- getContents
  let input = parseInput inputText
  putStr "Part 1: "
  putStrLn $ part1 input
  putStrLn $ show $ applyAt (-4, 4) emptyBoard

part1 :: (Wires, Wires) -> String
part1 _ = " "

parseInput :: String -> (Wires, Wires)
parseInput input = (wires1, wires2)
  where
    wires1:wires2:_ = input |> lines |> fmap (splitOn "," .> fmap parseDir)

applyAtPos :: Board -> Board
applyAtPos board = applyAt (pos board) board

applyAt :: (Int, Int) -> Board -> Board
applyAt (x, y) board =
  board |> growBoard (x * 2, y * 2) |> mapBoardMat (updateMat (x, y))

--applyWires :: Wires -> Board -> Board
--applyWires wires board = 
--applyWire :: Dir -> Board -> Board
type Wires = [Dir]

type Mat = [[Bool]]

data Board =
  Board
    { mat :: Mat
    , pos :: (Int, Int)
    , origin :: (Int, Int)
    }

emptyBoard :: Board
emptyBoard = Board {mat = [], pos = (0, 0), origin = (0, 0)}

growBoard :: (Int, Int) -> Board -> Board
growBoard (x, y) board = growBoardX x (growBoardY y board)

growBoardY :: Int -> Board -> Board
growBoardY 0 board = board
growBoardY y board = do
  let incY (x0, y0) = (x0, y0 + abs y)
  let newBoard = mapBoardMat (growMatY y) board
  if y < 0
    then mapBoardPos incY $ mapBoardOrigin incY newBoard
    else newBoard

growBoardX :: Int -> Board -> Board
growBoardX 0 board = board
growBoardX x board = do
  let incX (x0, y0) = (x0 + abs x, y0)
  let newBoard = mapBoardMat (growMatX x) board
  if x < 0
    then mapBoardPos incX $ mapBoardOrigin incX newBoard
    else newBoard

mapBoardMat :: (Mat -> Mat) -> Board -> Board
mapBoardMat mapping board =
  Board
    { mat = withBoardMat mapping board
    , pos = (pos board)
    , origin = (origin board)
    }

withBoardMat :: (Mat -> a) -> Board -> a
withBoardMat mapping board = (mapping (mat board))

mapBoardOrigin :: ((Int, Int) -> (Int, Int)) -> Board -> Board
mapBoardOrigin mapping board =
  Board {mat = mat board, pos = pos board, origin = mapping (origin board)}

withBoardOrigin :: ((Int, Int) -> a) -> Board -> a
withBoardOrigin mapping board = (mapping (origin board))

mapBoardPos :: ((Int, Int) -> (Int, Int)) -> Board -> Board
mapBoardPos mapping board =
  Board {mat = mat board, pos = mapping (pos board), origin = origin board}

withBoardPos :: ((Int, Int) -> a) -> Board -> a
withBoardPos mapping board = (mapping (pos board))

instance Show Board where
  show board =
    concat $
    intersperse
      "\n"
      [ [boardChar (x, y) board | (x, _) <- zip [0 ..] row]
      | (y, row) <- zip [0 ..] (mat board)
      ]

boardChar :: (Int, Int) -> Board -> Char
boardChar loc board
  | (origin board) == loc = 'o'
  | (pos board) == loc = '*'
  | otherwise = do
    let (x, y) = loc
    if (mat board) !! y !! x
      then '+'
      else '.'

data Dir
  = Up Int
  | Dn Int
  | Lt Int
  | Rt Int

parseDir :: String -> Dir
parseDir text = do
  let n = read $ tail text
  case text !! 0 of
    'U' -> Up n
    'D' -> Dn n
    'L' -> Lt n
    'R' -> Rt n

dirMap :: (Int -> Int) -> Dir -> Dir
dirMap mapping (Up n) = Up (mapping n)
dirMap mapping (Dn n) = Dn (mapping n)
dirMap mapping (Lt n) = Lt (mapping n)
dirMap mapping (Rt n) = Rt (mapping n)

dirMag :: Dir -> Int
dirMag (Up n) = n
dirMag (Dn n) = n
dirMag (Lt n) = n
dirMag (Rt n) = n

dirPair :: Dir -> (Int, Int)
dirPair (Up n) = (0, -n)
dirPair (Dn n) = (0, n)
dirPair (Lt n) = (-n, 0)
dirPair (Rt n) = (n, 0)

updateMat :: (Int, Int) -> Mat -> Mat
updateMat (x, y) mat = newMat
  where
    (rowHead, _:rowTail) = splitAt y mat
    row = mat !! y
    (colHead, _:colTail) = splitAt x row
    newMat = rowHead ++ [colHead ++ True : colTail] ++ rowTail

growMatDir :: Dir -> Mat -> Mat
growMatDir dir mat
  | dirMag dir == 0 = mat
  | otherwise = growMat (dirPair dir) mat

growMat :: (Int, Int) -> Mat -> Mat
growMat (x, y) mat = growMatX x (growMatY y mat)

growMatX :: Int -> Mat -> Mat
growMatX 0 mat = mat
growMatX x mat =
  if x < 0
    then [take (abs x) (repeat False) ++ row | row <- mat]
    else [row ++ take (abs x) (repeat False) | row <- mat]

growMatY :: Int -> Mat -> Mat
growMatY 0 mat = mat
growMatY y mat =
  if y < 0
    then (take (abs y) (repeat (take (matW mat) (repeat False)))) ++ mat
    else mat ++ (take (abs y) (repeat (take (matW mat) (repeat False))))

matSize :: Mat -> (Int, Int)
matSize mat = (matW mat, matH mat)

matW :: Mat -> Int
matW mat =
  if matH mat == 0
    then 0
    else mx (fmap length mat)

matH :: Mat -> Int
matH mat = length mat

mx :: [Int] -> Int
mx [] = 0
mx [x] = x
mx (x:xs)
  | (mx xs) > x = mx xs
  | otherwise = x