Day nine

day-09-haskell/src/Task1.hs

@@ -0,0 +1,42 @@
+module Task1 (task1) where
+
+import Common
+import Control.Monad (join)
+import Flow
+
+type AllocatedBlock = (Int, Int)
+
+task1 :: String -> IO Int
+task1 input = let blocks = parseBlocks input
+                  compacted = compact blocks
+              in do
+                -- print blocks
+                -- print compacted
+                -- print $ showBlocks compacted
+                return $ reduce 0 compacted
+  where
+    compact :: [Block] -> [AllocatedBlock]
+    compact blocks = compactInner blocks (reverse blocks) (minBound :: Int)
+      where
+        compactInner :: [Block] -> [Block] -> Int -> [AllocatedBlock]
+        compactInner [] _ _ = []
+        compactInner _ [] _ = error "Backwards list cannot be empty when forwards list isn't"
+        compactInner forwards ((Empty, _):backwards) curBId = compactInner forwards backwards curBId
+        compactInner forwards ((Allocated _, 0):backwards) curBId = compactInner forwards backwards curBId
+        compactInner ((Empty, 0):forwards) backwards curBId = compactInner forwards backwards curBId
+        compactInner ((Empty, fLength):forwards) ((Allocated bId, bLength):backwards) _
+          | bLength <= fLength = (bId, bLength) : compactInner ((Empty, fLength - bLength) : forwards) backwards bId
+          | otherwise = (bId, fLength) : compactInner forwards ((Allocated bId, bLength - fLength):backwards) bId
+        compactInner ((Allocated fId, fLength):forwards) bAll@((Allocated bId, bLength):_) curBId
+          | fId >= bId = [(bId, bLength)]
+          | otherwise = (fId, fLength) : compactInner forwards bAll curBId
+
+    reduce :: Int -> [AllocatedBlock] -> Int
+    reduce _ [] = 0
+    reduce i ((_, 0): blocks) = reduce i blocks
+    reduce i ((bId, bSize):blocks) = i * bId + reduce (i + 1) ((bId, bSize - 1):blocks)
+
+    showBlocks :: [AllocatedBlock] -> String
+    showBlocks [] = ""
+    showBlocks ((blockId, blockLength):blocks) = (show blockId |> repeat |> take blockLength |> join) ++ showBlocks blocks
+