Day nine

day-09-haskell/src/Common.hs

@@ -0,0 +1,31 @@
+module Common where
+
+data BlockType = Empty | Allocated Int
+
+instance Show BlockType where
+  show Empty = "(empty)"
+  show (Allocated blockId) = show blockId
+instance Eq BlockType where
+  (==) Empty Empty = True
+  (==) (Allocated a) (Allocated b) = True
+  (==) _ _ = False
+
+type Block = (BlockType, Int)
+length :: Block -> Int
+length (_, l) = l
+
+parseBlocks :: String -> [Block]
+parseBlocks = startWithBlock 0
+  where
+    startWithBlock :: Int -> String -> [Block]
+    startWithBlock _ [] = []
+    startWithBlock blockId (size:rest)
+      | size >= '0' && size <= '9' = (Allocated blockId, read [size]) : startWithEmpty (blockId + 1) rest
+      | otherwise = startWithBlock blockId rest
+
+    startWithEmpty :: Int -> String -> [Block]
+    startWithEmpty _ [] = []
+    startWithEmpty blockId (size:rest)
+      | size >= '0' && size <= '9' = (Empty, read [size]) : startWithBlock blockId rest
+      | otherwise = startWithEmpty blockId rest
+

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
+

day-09-haskell/src/Task2.hs

@@ -0,0 +1,48 @@
+module Task2 (task2) where
+
+import Common
+import Flow
+
+task2 :: String -> IO Int
+task2 input = let blocks = parseBlocks input
+                  compacted = compact blocks
+              in do
+                -- print blocks
+                --print compacted
+                return $ reduce 0 compacted
+  where
+    compact :: [Block] -> [Block]
+    compact inputBlocks = compactInner (reverse inputBlocks) inputBlocks
+      where
+        compactInner :: [Block] -> [Block] -> [Block]
+        compactInner [] blocks = blocks
+        compactInner _ [] = error ""
+        compactInner ((Empty, _):inserts) disk = compactInner inserts disk
+        compactInner ((Allocated aId, aLength):inserts) disk = moveFront disk |> compactInner inserts
+          where
+            moveFront :: [Block] -> [Block]
+            moveFront [] = []
+            moveFront (block@(Allocated tId, _):blocks)
+              | tId == aId = block : blocks
+              | otherwise = block : moveFront blocks
+            moveFront (block@(Empty, eLength):blocks)
+              | aLength <= eLength = (Allocated aId, aLength) : (Empty, eLength - aLength) : (combineEmpties $ removeSelf blocks)
+              | otherwise = block : moveFront blocks
+
+            combineEmpties :: [Block] -> [Block]
+            combineEmpties ((Empty, aLen):(Empty, bLen):blocks) = combineEmpties ((Empty, aLen + bLen):blocks)
+            combineEmpties value = value
+
+            removeSelf :: [Block] -> [Block]
+            removeSelf [] = []
+            removeSelf (t@(Allocated tId, tLength):blocks)
+              | tId == aId = (Empty, tLength) : blocks
+              | otherwise = t : removeSelf blocks
+            removeSelf (t:blocks) = t : removeSelf blocks
+
+    reduce :: Int -> [Block] -> Int
+    reduce _ [] = 0
+    reduce i ((_, 0):blocks) = reduce i blocks
+    reduce i ((Empty, eLength):blocks) = reduce (i + 1) ((Empty, eLength - 1):blocks)
+    reduce i ((Allocated bId, bSize):blocks) = i * bId + reduce (i + 1) ((Allocated bId, bSize - 1):blocks)
+