adventofcode-2019/day03/Day03.old.hs

import Debug.Trace
import Data.List
import Data.List.Split

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

dirMap :: (Int -> Int) -> Dir -> Dir
dirMap mapping dir = case dir of
                        Up n -> Up $ mapping n
                        Dn n -> Dn $ mapping n
                        Lt n -> Lt $ mapping n
                        Rt n -> Rt $ mapping n

dirAbs :: Dir -> Int
dirAbs dir = case dir of
                        Up n -> n
                        Dn n -> n
                        Lt n -> n
                        Rt n -> n

data WireBoard = WireBoard {
    board :: [[Bool]],
    origin :: (Int, Int),
    pos :: (Int, Int)
}

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

wireBoardChar :: (Int, Int) -> WireBoard -> Char
wireBoardChar lookup wireBoard
    | lookup == (origin wireBoard) = 'o'
    | lookup == (pos wireBoard) = '*'
    | otherwise = do
        let (posX, posY) = lookup
        if (board wireBoard) !! posY !! posX
            then '+'
            else '.'

emptyWireBoard :: WireBoard
emptyWireBoard = WireBoard { board = [], origin = (0, 0), pos = (0, 0) }

parseDir :: String -> Dir
parseDir dir = do
    let num = read (tail dir)
    case dir !! 0 of
        'U' -> Up num
        'D' -> Dn num
        'L' -> Lt num
        'R' -> Rt num
        _ -> error $ "bad direction: " ++ dir

parseInput :: String -> ([Dir], [Dir])
parseInput inputText = do
    let [first, second] = map (splitOn ",") (lines inputText)
    (map parseDir first, map parseDir second)

main :: IO()
main = do
    inputText <- getContents
    let wires = parseInput inputText
    putStrLn $ show $ applyWire (Dn 3) emptyWireBoard
    --putStr "Part 1: "
    --putStrLn $ show (part1 wires)

part1 :: ([Dir], [Dir]) -> Int
part1 (wire1, wire2) = error "TODO"

applyWire :: Dir -> WireBoard -> WireBoard
applyWire dir wireBoard
    | (dirAbs dir) == 0 = applyAtPos wireBoard
    | otherwise = do
        let nextBoard = applyOne dir wireBoard
        applyWire (dirMap (pred) dir) nextBoard

applyOne :: Dir -> WireBoard -> WireBoard
applyOne (Up _) wireBoard = applyMove (0, -1) wireBoard
applyOne (Dn _) wireBoard = applyMove (0, 1) wireBoard
applyOne (Lt _) wireBoard = applyMove (-1, 0) wireBoard
applyOne (Rt _) wireBoard = applyMove (1, 0) wireBoard

applyMove :: (Int, Int) -> WireBoard -> WireBoard
applyMove (x, y) wireBoard = do
    let newBoard = applyAtPos wireBoard
    let (oldX, oldY) = (pos newBoard)
    let (newX, newY) = (oldX + x, oldY + y)
    WireBoard {
        board = (board newBoard),
        origin = (origin newBoard),
        pos = (newX, newY)
    }

applyAtPos :: WireBoard -> WireBoard
applyAtPos wireBoard = applyAt (pos wireBoard) wireBoard

applyAt :: (Int, Int) -> WireBoard -> WireBoard
applyAt (x, y) wireBoard = do
    let matrix = board (ensureBoardSize (x, y) wireBoard)
    let splitMatrix = splitAt (trace ("splitting at " ++ (show y)) y) matrix
    let (headRows, row : tailRows) = trace (show splitMatrix) splitMatrix
    let (headCols, _ : tailCols) = splitAt x row
    let newBoard = headRows ++ [headCols ++ True : tailCols] ++ tailRows
    WireBoard {
        board = newBoard,
        origin = (origin wireBoard),
        pos = (pos wireBoard)
    }

ensureBoardSize :: (Int, Int) -> WireBoard -> WireBoard
ensureBoardSize (x, y) wireBoard = do
    let (maxX, maxY) = maxBoardPos wireBoard
    let (minX, minY) = minBoardPos wireBoard
    let growLeft    = max 0 $ minX - x
    let growRight   = max 0 $ x - maxX
    let growUp      = max 0 $ minY - y
    let growDown    = max 0 $ y - maxY
    growBoard wireBoard (growUp, growDown, growLeft, growRight)

maxBoardPos :: WireBoard -> (Int, Int)
maxBoardPos wireBoard = do
    let (originX, originY) = (origin wireBoard)
    let (sizeX, sizeY) = (boardSize wireBoard)
    (sizeX - originX, sizeY - originY)

minBoardPos :: WireBoard -> (Int, Int)
minBoardPos wireBoard = do
    let (originX, originY) = (origin wireBoard)
    let (sizeX, sizeY) = (boardSize wireBoard)
    (originX - sizeX, originY - sizeY)

boardSize :: WireBoard -> (Int, Int)
boardSize wireBoard = do
    let ymax = length (board wireBoard)
    if ymax == 0
        then (0, 0)
        else (length $ ((board wireBoard) !! 0), ymax)

growBoard :: WireBoard -> (Int, Int, Int, Int) -> WireBoard
growBoard wireBoard (0, 0, 0, 0) = wireBoard
growBoard wireBoard (up, down, left, right) = do
    let (oldX, _) = (boardSize wireBoard)
    let newX = oldX + left + right
    let newTop = [[False | _ <- [0..newX]] | _ <- [1..up]]
    let newBottom = [[False | _ <- [0..newX]] | _ <- [0..down]]
    let newMiddle = [
                        [False | _ <- [1..left]] ++ middle ++ [False | _ <- [0..right]]
                        | middle <- (board wireBoard)
                    ]
    let newBoard = newTop ++ newMiddle ++ newBottom
    let (originX, originY) = (origin wireBoard)
    let (posX, posY) = (pos wireBoard)
    WireBoard {
        board = newBoard,
        origin = (originX + left, originY + up),
        pos = (posX + left, posY + up)
    }