Day 7

src/Days/D07.hs

@@ -0,0 +1,196 @@
+{-
+
+  Adapted from: https://notes.abhinavsarkar.net/2022/aoc-7
+
+-}
+{-# LANGUAGE ImportQualifiedPost #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module Days.D07 (day) where
+
+import Data.Map (Map)
+import Data.Map qualified as M
+
+import Numeric (showInt)
+
+import Common
+import Parse
+import Text.Megaparsec (anySingleBut, some, (<|>))
+import Text.Megaparsec.Char (char, space, string)
+
+type Size = Int
+type Name = String
+
+newtype File = F Size deriving (Show)
+data Dir = D
+    { subdirs :: Map Name Dir
+    , files :: Map Name File
+    }
+    deriving (Show)
+
+newtype Fs = Root Dir
+
+emptyDir :: Dir
+emptyDir = D{subdirs = M.empty, files = M.empty}
+
+emptyFs :: Fs
+emptyFs = Root emptyDir
+
+instance Show Fs where
+    show (Root rootDir) = showDir 0 ("/", rootDir) ""
+      where
+        indent :: Int -> ShowS
+        indent n = showString (replicate (2 * n) ' ')
+
+        showDirs :: Int -> [(Name, Dir)] -> ShowS
+        showDirs d = foldr ((.) . showDir d) id
+
+        showDir :: Int -> (Name, Dir) -> ShowS
+        showDir depth (name, dir) =
+            indent depth
+                . showString "- "
+                . showString name
+                . showDirs depth (M.toList $ subdirs dir)
+                . showFiles depth (M.toList $ files dir)
+
+        showFiles :: Int -> [(Name, File)] -> ShowS
+        showFiles d = foldr ((.) . showFile d) id
+
+        showFile :: Int -> (Name, File) -> ShowS
+        showFile d (name, F size) =
+            indent d
+                . showString "- "
+                . showString name
+                . showString "(file, size="
+                . showInt size
+                . showString ")\n"
+
+insertFile :: Name -> File -> Dir -> Dir
+insertFile k v d = d{files = M.insert k v (files d)}
+
+insertDir :: Name -> Dir -> Dir -> Dir
+insertDir k v d = d{subdirs = M.insert k v (subdirs d)}
+
+findDir :: Name -> Dir -> Maybe Dir
+findDir k d = M.lookup k (subdirs d)
+
+data FsZipper = FsZipper
+    { path :: [(Name, Dir)]
+    , current :: Dir
+    , name :: Name
+    }
+    deriving (Show)
+
+moveUp :: FsZipper -> FsZipper
+moveUp (FsZipper [] _ _) = error "Can't ascend beyond the root"
+moveUp (FsZipper ((pName, pDir) : ds) current name) =
+    FsZipper ds (insertDir name current pDir) pName
+
+moveDown :: String -> FsZipper -> FsZipper
+moveDown targetName (FsZipper path current name) =
+    case findDir targetName current of
+        Nothing -> error "Can not descend into non-dir"
+        Just targetDir -> FsZipper ((name, current) : path) targetDir targetName
+
+moveToRoot :: FsZipper -> FsZipper
+moveToRoot zipper = case zipper of
+    FsZipper [] _ _ -> zipper
+    _ -> moveToRoot (moveUp zipper)
+
+mkdir :: Name -> FsZipper -> FsZipper
+mkdir dirName (FsZipper{..}) =
+    FsZipper path (insertDir dirName emptyDir current) name
+
+mkfile :: Name -> Size -> FsZipper -> FsZipper
+mkfile fname fsize (FsZipper{..}) =
+    FsZipper path (insertFile fname (F fsize) current) name
+
+toZipper :: Fs -> FsZipper
+toZipper (Root d) = FsZipper [] d "/"
+
+fromZipper :: FsZipper -> Fs
+fromZipper = Root . current . moveToRoot
+
+data CdArg = CdDown String | CdUp | CdRoot deriving (Show)
+data Command = Cd CdArg | Ls deriving (Show)
+data Output = OutputFile Int String | OutputDir String deriving (Show)
+data Line = LCommand Command | LOutput Output deriving (Show)
+
+parser :: Parser Fs
+parser = buildFs <$> someLines ((LCommand <$> commandParser) <|> (LOutput <$> outputParser))
+  where
+    nameParser :: Parser String
+    nameParser = some $ anySingleBut '\n'
+
+    cdParser :: Parser CdArg
+    cdParser =
+        string "cd"
+            *> space
+            *> ( CdUp
+                    <$ string ".."
+                    <|> CdRoot
+                    <$ char '/'
+                    <|> CdDown
+                    <$> nameParser
+               )
+
+    commandParser :: Parser Command
+    commandParser =
+        char '$'
+            *> space
+            *> (Cd <$> cdParser <|> Ls <$ string "ls")
+
+    outputParser :: Parser Output
+    outputParser =
+        ( OutputDir
+            <$ string "dir"
+            <* space
+            <*> nameParser
+        )
+            <|> ( OutputFile
+                    <$> number
+                    <* space
+                    <*> nameParser
+                )
+
+apply :: Line -> FsZipper -> FsZipper
+apply = \case
+    LCommand (Cd CdUp) -> moveUp
+    LCommand (Cd CdRoot) -> moveToRoot
+    LCommand (Cd (CdDown name)) -> moveDown name
+    LCommand Ls -> id
+    LOutput (OutputFile size name) -> mkfile name size
+    LOutput (OutputDir name) -> mkdir name
+
+buildFs :: [Line] -> Fs
+buildFs = fromZipper . foldl (flip apply) (toZipper emptyFs)
+
+dirSizes :: Dir -> (Int, [Int])
+dirSizes = go
+  where
+    go :: Dir -> (Int, [Int])
+    go dir =
+        let subdirGo = map go . M.elems $ subdirs dir
+            subdirNested = concatMap snd subdirGo
+            subdirSizes = sum $ map fst subdirGo
+            dirSize = subdirSizes + filesSize dir
+         in ( dirSize
+            , dirSize : subdirNested
+            )
+
+    filesSize :: Dir -> Int
+    filesSize = sum . map (\(F size) -> size) . M.elems . files
+
+part1 :: Fs -> Int
+part1 (Root dir) = sum . filter (< 100000) . snd $ dirSizes dir
+
+part2 :: Fs -> Int
+part2 (Root dir) =
+    let (total, ds) = dirSizes dir
+        requiredSpace = total - (70000000 - 30000000)
+     in minimum $ filter (> requiredSpace) ds
+
+day :: Day
+day = parsecDay parser (definitive . part1, definitive . part2)

src/Lib.hs

@@ -17,6 +17,7 @@ import Days.D03 qualified as D03
 import Days.D04 qualified as D04
 import Days.D05 qualified as D05
 import Days.D06 qualified as D06
+import Days.D07 qualified as D07
 
 import Data.Text.IO qualified as T
 
@@ -33,4 +34,5 @@ days =
     , [D04.day]
     , [D05.day]
     , [D06.day]
+    , [D07.day]
     ]