144 lines
4.9 KiB
Idris
144 lines
4.9 KiB
Idris
import System.File.ReadWrite
|
|
import Data.List
|
|
import Data.String
|
|
|
|
data Crate = C Char
|
|
|
|
Show Crate where
|
|
show (C c) = pack ['[', c, ']']
|
|
|
|
parseCrate : String -> Maybe Crate
|
|
parseCrate str = let str = unpack str in
|
|
case str of
|
|
('[' :: x :: ']' :: _) => Just (C x)
|
|
_ => Nothing
|
|
|
|
data Stacks = Stks (List (List Crate))
|
|
|
|
Show Stacks where
|
|
show (Stks stacks) =
|
|
let longestStack = foldl max 0 . map length $ stacks
|
|
stringStacks = map (extendFront longestStack " ") . map (map show) $ stacks
|
|
lastLine = unwords . map (\x => " " ++ x ++ " ") . map show $ rangeFromTo 1 (length stacks)
|
|
lineStacks = filter (/= "") . map unwords . transposeList longestStack $ stringStacks
|
|
in joinBy "\n" $ (lineStacks ++ [lastLine])
|
|
where extendFront : Nat -> a -> List a -> List a
|
|
extendFront k x xs =
|
|
if length xs < k
|
|
then replicate (minus k (length xs)) x ++ xs
|
|
else xs
|
|
transposeList : Nat -> List (List a) -> List (List a)
|
|
transposeList k xs =
|
|
if any isNil xs
|
|
then replicate k []
|
|
else let firsts = map (take 1) xs
|
|
rests = map (drop 1) xs
|
|
in foldl (++) [] firsts :: transposeList k (assert_smaller xs rests)
|
|
|
|
-- Chunk up a list
|
|
chunk : Nat -> List a -> List (List a)
|
|
chunk k [] = []
|
|
chunk k xs = let (head, tail) = splitAt k xs in
|
|
head :: chunk k tail
|
|
|
|
-- Ensure a list of maybes is at least a specific length
|
|
ensureLen : Nat -> List (Maybe a) -> List (Maybe a)
|
|
ensureLen k [] = replicate k Nothing
|
|
ensureLen 0 xs = xs
|
|
ensureLen (S k) (x :: xs) = x :: ensureLen k xs
|
|
|
|
-- Parse a list of stacks, this should be passed a list of lines including the line of numbers
|
|
parseStacks : Nat -> List String -> Stacks
|
|
parseStacks k [] = Stks $ replicate k []
|
|
parseStacks k (x :: []) = parseStacks k []
|
|
parseStacks k (x :: xs) = let (Stks bottom) = parseStacks k xs
|
|
row = ensureLen k . map parseCrate . map pack . chunk 4 . unpack $ x
|
|
in Stks $ zipWith parseStacksHelper row bottom
|
|
where parseStacksHelper : Maybe Crate -> List Crate -> List Crate
|
|
parseStacksHelper (Just crate) xs = crate :: xs
|
|
parseStacksHelper Nothing xs = xs
|
|
|
|
simple : String
|
|
simple = """
|
|
[D]
|
|
[N] [C]
|
|
[Z] [M] [P]
|
|
1 2 3
|
|
|
|
move 1 from 2 to 1
|
|
move 3 from 1 to 3
|
|
move 2 from 2 to 1
|
|
move 1 from 1 to 2
|
|
"""
|
|
data Command = Cmd Nat Nat Nat
|
|
|
|
Show Command where
|
|
show (Cmd x y z) = (show x) ++ " " ++ (show (y + 1)) ++ "->" ++ (show (z + 1))
|
|
|
|
-- Parse a command
|
|
parseCommand : String -> Maybe Command
|
|
parseCommand str =
|
|
let nums : List Nat
|
|
nums = catMaybes . map parsePositive . words $ str
|
|
in case nums of
|
|
[x, y, z] => Just (Cmd x (minus y 1) (minus z 1))
|
|
_ => Nothing
|
|
|
|
-- Apply a command to the stacks
|
|
applyCommand : Command -> Stacks -> Maybe Stacks
|
|
applyCommand (Cmd count from to) stacks =
|
|
do (crates, removed) <- extractCrates count from stacks
|
|
addCrates (reverse crates) to removed
|
|
where extractCrates : Nat -> Nat -> Stacks -> Maybe ((List Crate), Stacks)
|
|
extractCrates count from (Stks []) = Nothing
|
|
extractCrates count 0 (Stks (x :: xs)) =
|
|
if count > length x
|
|
then Nothing
|
|
else let (taken, rest) = splitAt count x in
|
|
Just (taken, Stks (rest :: xs))
|
|
extractCrates count (S k) (Stks (x :: xs)) =
|
|
do (c, (Stks s)) <- extractCrates count k (Stks xs)
|
|
Just (c, (Stks (x :: s)))
|
|
addCrates : List Crate -> Nat -> Stacks -> Maybe Stacks
|
|
addCrates xs to (Stks []) = Nothing
|
|
addCrates xs 0 (Stks (x :: ys)) = Just (Stks ((xs ++ x) :: ys))
|
|
addCrates xs (S k) (Stks (x :: ys)) =
|
|
do (Stks added) <- addCrates xs k (Stks ys)
|
|
Just (Stks (x :: added))
|
|
|
|
data CmdResult = CR Bool (Maybe Command) Stacks
|
|
|
|
Show CmdResult where
|
|
show (CR bool command stacks) =
|
|
unlines ["Command applied: " ++ (show bool), "Command: " ++ (show command), show stacks]
|
|
|
|
-- Apply a list of commands to a stacks
|
|
applyCommands : List Command -> Stacks -> List CmdResult
|
|
applyCommands [] x = [CR False Nothing x]
|
|
applyCommands (y :: xs) x =
|
|
case applyCommand y x of
|
|
Just stacks => CR True (Just y) stacks :: applyCommands xs stacks
|
|
Nothing => [CR False (Just y) x]
|
|
|
|
mapM : Monad m => (a -> m b) -> List a -> m (List b)
|
|
mapM f [] = pure []
|
|
mapM f (x :: xs) =
|
|
do x <- f x
|
|
rest <- mapM f xs
|
|
pure $ x :: rest
|
|
|
|
main : IO ()
|
|
main =
|
|
do file <- readFile "input"
|
|
case file of
|
|
Right content =>
|
|
let stacks = parseStacks 9 . takeWhile (/= "") . lines $ content
|
|
commands = catMaybes . map parseCommand . drop 1 . dropWhile (/= "") . lines $ content
|
|
result = applyCommands commands stacks
|
|
in do putStrLn "Input: "
|
|
printLn stacks
|
|
putStrLn ""
|
|
_ <- mapM printLn result
|
|
pure ()
|
|
Left err => printLn err
|