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 (first:wires1, _) = do
  let _ = applyWire first emptyBoard

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

applyWire :: Wire -> Board -> Board
applyWire wire board
  | wireMag wire == 0 = board
  | otherwise = applyWire (wireMap (pred) wire) $ moveBoardPos wire (applyAtPos board)

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 :: Wire -> Board -> Board
type Wires = [Wire]

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))

moveBoardPos :: Wire -> Board -> Board
moveBoardPos wire board = newBoard
  where
    (wireX, wireY) = wireDir wire
    newBoard = mapBoardPos (\(posX, posY) -> (posX + wireX, posY + wireY)) 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 Wire
  = Up Int
  | Dn Int
  | Lt Int
  | Rt Int

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

wireMap :: (Int -> Int) -> Wire -> Wire
wireMap mapping (Up n) = Up (mapping n)
wireMap mapping (Dn n) = Dn (mapping n)
wireMap mapping (Lt n) = Lt (mapping n)
wireMap mapping (Rt n) = Rt (mapping n)

wireMag :: Wire -> Int
wireMag (Up n) = n
wireMag (Dn n) = n
wireMag (Lt n) = n
wireMag (Rt n) = n

wirePair :: Wire -> (Int, Int)
wirePair (Up n) = (0, -n)
wirePair (Dn n) = (0, n)
wirePair (Lt n) = (-n, 0)
wirePair (Rt n) = (n, 0)

wireDir :: Wire -> (Int, Int)
wireDir (Up n) = (0, -1)
wireDir (Dn n) = (0, 1)
wireDir (Lt n) = (-1, 0)
wireDir (Rt n) = (1, 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

growMatWire :: Wire -> Mat -> Mat
growMatWire wire mat
  | wireMag wire == 0 = mat
  | otherwise = growMat (wirePair wire) 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