Day 9: Disk Fragmenter
Megathread guidelines
- Keep top level comments as only solutions, if you want to say something other than a solution put it in a new post. (replies to comments can be whatever)
- You can send code in code blocks by using three backticks, the code, and then three backticks or use something such as https://topaz.github.io/paste/ if you prefer sending it through a URL
FAQ
- What is this?: Here is a post with a large amount of details: https://programming.dev/post/6637268
- Where do I participate?: https://adventofcode.com/
- Is there a leaderboard for the community?: We have a programming.dev leaderboard with the info on how to join in this post: https://programming.dev/post/6631465
2 points
*
Haskell
Unoptimized as hell, also brute-force approach (laptops are beasts).
Spoiler
{-# LANGUAGE MultiWayIf #-}
import Control.Arrow
import Control.Monad.ST (ST, runST)
import Data.Array.ST (STUArray)
import qualified Data.List as List
import qualified Data.Maybe as Maybe
import qualified Data.Array.MArray as MArray
toNumber '0' = 0
toNumber '1' = 1
toNumber '2' = 2
toNumber '3' = 3
toNumber '4' = 4
toNumber '5' = 5
toNumber '6' = 6
toNumber '7' = 7
toNumber '8' = 8
toNumber '9' = 9
parse :: String -> [Int]
parse s = filter (/= '\n')
>>> map toNumber
>>> zip [0..]
>>> List.concatMap (\ (index, n) -> if index `mod` 2 == 0 then replicate n (index `div` 2) else replicate n (-1))
$ s
calculateChecksum :: [Int] -> Int
calculateChecksum = zip [0..]
>>> filter (snd >>> (/= -1))
>>> map (uncurry (*))
>>> sum
moveFiles :: [Int] -> ST s Int
moveFiles bs = do
let bLength = length bs
marray <- MArray.newListArray (1, bLength) bs
moveFiles' marray 1 bLength
elems <- MArray.getElems marray
return $ calculateChecksum elems
moveFiles' :: STUArray s Int Int -> Int -> Int -> ST s ()
moveFiles' a start stop
| start == stop = return ()
| otherwise = do
stopBlock <- MArray.readArray a stop
if stopBlock == -1
then
moveFiles' a start (pred stop)
else
do
startBlock <- MArray.readArray a start
if startBlock == -1
then
do
MArray.writeArray a start stopBlock
MArray.writeArray a stop (-1)
moveFiles' a (succ start) (pred stop)
else
moveFiles' a (succ start) stop
countConsecutive :: STUArray s Int Int -> Int -> Int -> ST s Int
countConsecutive a i step = do
block <- MArray.readArray a i
let nextI = i + step
bounds <- MArray.getBounds a
if | MArray.inRange bounds nextI ->
do
nextBlock <- MArray.readArray a nextI
if nextBlock == block
then
do
steps <- countConsecutive a nextI step
return $ 1 + steps
else
return 1
| otherwise -> return 1
findEmpty :: STUArray s Int Int -> Int -> Int -> Int -> ST s (Maybe Int)
findEmpty a i l s = do
block <- MArray.readArray a i
blockLength <- countConsecutive a i 1
let nextI = i + blockLength
bounds <- MArray.getBounds a
let nextInBounds = MArray.inRange bounds nextI
if | i >= s -> return $! Nothing
| block == -1 && blockLength >= l -> return $ Just i
| block /= -1 && nextInBounds -> findEmpty a nextI l s
| blockLength <= l && nextInBounds -> findEmpty a nextI l s
| not nextInBounds -> return $! Nothing
moveDefragmenting :: [Int] -> ST s Int
moveDefragmenting bs = do
let bLength = length bs
marray <- MArray.newListArray (1, bLength) bs
moveDefragmenting' marray bLength
elems <- MArray.getElems marray
return $ calculateChecksum elems
moveDefragmenting' :: STUArray s Int Int -> Int -> ST s ()
moveDefragmenting' a 1 = return ()
moveDefragmenting' a stop
| otherwise = do
stopBlock <- MArray.readArray a stop
stopLength <- countConsecutive a stop (-1)
targetBlock <- findEmpty a 1 stopLength stop
elems <- MArray.getElems a
let nextStop = stop - stopLength
bounds <- MArray.getBounds a
let nextStopInRange = MArray.inRange bounds nextStop
if | stopBlock == -1
-> moveDefragmenting' a nextStop
| Maybe.isJust targetBlock
-> do
let target = Maybe.fromJust targetBlock
mapM_ (\ o -> MArray.writeArray a (stop - o) (-1)) [0..stopLength - 1]
mapM_ (\ o -> MArray.writeArray a (target + o) stopBlock) [0..stopLength - 1]
if nextStopInRange then moveDefragmenting' a nextStop else return ()
| nextStopInRange -> moveDefragmenting' a nextStop
| otherwise -> return ()
part1 bs = runST $ moveFiles bs
part2 bs = runST $ moveDefragmenting bs
main = getContents
>>= print
. (part1 &&& part2)
. parse
2 points
*
Nim
Wrote ugly-ass code today, but it was surprisingly easy to debug and fast.
Solution:
Part 1: Parse data into a sequence of blocks and empty space like in example (I use -1 for empty space) and two indexes. First index goes 0 -> end, second index starts at the end. When we encounter empty space -> we use value from second index and decrement it (while skipping empty spaces). Repeat until both indexes meet at some point.
Part 2: Parse data into sequence of block objects and try to insert each data block into each empty space block before it. Somehow it all just worked without too many bugs.
Runtime (final version): 123 ms
type
BlockKind = enum Data, Space
Block = object
size: int
case kind: BlockKind
of Data:
index: int
of Space:
discard
func parseBlocks(input: string): tuple[blocks: seq[Block], id: int] =
for i, c in input:
let digit = c.ord - '0'.ord
if i mod 2 == 0:
result.blocks.add Block(kind: Data, size: digit, index: result.id)
if i < input.high: inc result.id
else:
result.blocks.add Block(kind: Space, size: digit)
proc solve(input: string): AOCSolution[int, int] =
block p1:
var memBlocks = newSeqOfCap[int](100_000)
var indBlock = 0
for i, c in input:
let digit = c.ord - '0'.ord
if i mod 2 == 0:
memBlocks.add (indBlock).repeat(digit)
inc indBlock
else:
memBlocks.add -1.repeat(digit)
var ind = 0
var revInd = memBlocks.high
while ind <= revInd:
if memBlocks[ind] == -1:
while memBlocks[revInd] == -1: dec revInd
result.part1 += ind * memBlocks[revInd]
dec revInd
else:
result.part1 += ind * memBlocks[ind]
inc ind
block p2:
var (memBlocks, index) = parseBlocks(input)
var revInd = memBlocks.high
while revInd > 0:
doAssert memBlocks[revInd].kind == Data
var spaceInd = -1
let blockSize = memBlocks[revInd].size
for ind in 0..revInd:
if memBlocks[ind].kind == Space and memBlocks[ind].size >= blockSize:
spaceInd = ind; break
if spaceInd != -1:
let bSize = memBlocks[revInd].size
let diffSize = memBlocks[spaceInd].size - bSize
swap(memBlocks[spaceInd], memBlocks[revInd])
if diffSize != 0:
memBlocks[revInd].size = bSize
memBlocks.insert(Block(kind: Space, size: diffSize), spaceInd + 1)
inc revInd # shift index bc we added object
dec index
# skip space blocks and data blocks with higher index
while (dec revInd; revInd < 0 or
memBlocks[revInd].kind != Data or
memBlocks[revInd].index != index): discard
var unitIndex = 0
for b in memBlocks:
case b.kind
of Data:
for _ in 1..b.size:
result.part2 += unitIndex * b.index
inc unitIndex
of Space:
unitIndex += b.size
2 points
*
Haskell
Not a lot of time to come up with a pretty solution today; sorry.
Ugly first solution
import Data.List
import Data.Maybe
import Data.Sequence (Seq)
import Data.Sequence qualified as Seq
readInput :: String -> Seq (Maybe Int, Int)
readInput =
Seq.fromList
. zip (intersperse Nothing $ map Just [0 ..])
. (map (read . singleton) . head . lines)
expand :: Seq (Maybe Int, Int) -> [Maybe Int]
expand = concatMap (uncurry $ flip replicate)
compact :: Seq (Maybe Int, Int) -> Seq (Maybe Int, Int)
compact chunks =
case Seq.spanr (isNothing . fst) chunks of
(suffix, Seq.Empty) -> suffix
(suffix, chunks' Seq.:|> file@(_, fileSize)) ->
case Seq.breakl (\(id, size) -> isNothing id && size >= fileSize) chunks' of
(_, Seq.Empty) -> compact chunks' Seq.>< file Seq.<| suffix
(prefix, (Nothing, gapSize) Seq.:<| chunks'') ->
compact $ prefix Seq.>< file Seq.<| (Nothing, gapSize - fileSize) Seq.<| chunks'' Seq.>< (Nothing, fileSize) Seq.<| suffix
part1, part2 :: Seq (Maybe Int, Int) -> Int
part1 input =
let blocks = dropWhileEnd isNothing $ expand input
files = catMaybes blocks
space = length blocks - length files
compacted = take (length files) $ fill blocks (reverse files)
in sum $ zipWith (*) [0 ..] compacted
where
fill (Nothing : xs) (y : ys) = y : fill xs ys
fill (Just x : xs) ys = x : fill xs ys
part2 = sum . zipWith (\i id -> maybe 0 (* i) id) [0 ..] . expand . compact
main = do
input <- readInput <$> readFile "input09"
print $ part1 input
print $ part2 input
3 points
*
Second attempt! I like this one much better.
Edit: down to 0.040 secs now!
import Control.Arrow
import Data.Either
import Data.List
import Data.Map (Map)
import Data.Map qualified as Map
type Layout = ([(Int, (Int, Int))], Map Int Int)
readInput :: String -> Layout
readInput =
map (read . singleton) . head . lines
>>> (scanl' (+) 0 >>= zip) -- list of (pos, len)
>>> zipWith ($) (intersperse Right [Left . (id,) | id <- [0 ..]])
>>> partitionEithers
>>> filter ((> 0) . snd . snd) *** Map.filter (> 0) . Map.fromAscList
checksum :: Layout -> Int
checksum = sum . map (\(id, (pos, len)) -> id * len * (2 * pos + len - 1) `div` 2) . fst
compact :: (Int -> Int -> Bool) -> Layout -> Layout
compact select (files, spaces) = foldr moveFile ([], spaces) files
where
moveFile file@(fileId, (filePos, fileLen)) (files, spaces) =
let candidates = Map.assocs $ fst . Map.split filePos $ spaces
in case find (select fileLen . snd) candidates of
Just (spacePos, spaceLen) ->
let spaces' = Map.delete spacePos spaces
in if spaceLen >= fileLen
then
( (fileId, (spacePos, fileLen)) : files,
if spaceLen == fileLen
then spaces'
else Map.insert (spacePos + fileLen) (spaceLen - fileLen) spaces'
)
else
moveFile
(fileId, (filePos + spaceLen, fileLen - spaceLen))
((fileId, (spacePos, spaceLen)) : files, spaces')
Nothing -> (file : files, spaces)
main = do
input <- readInput <$> readFile "input09"
mapM_ (print . checksum . ($ input) . compact) [const $ const True, (<=)]
2 points
It will always be a wonder to me how you manage to do so much in so few lines, even your naive solution only takes a few seconds to run. 🤯
1 point
Aww, thank you <3
It’s just practice, I guess? (The maths degree probably doesn’t hurt either)
2 points
C#
public class Day09 : Solver
{
private string data;
public void Presolve(string input) {
data = input.Trim();
}
public string SolveFirst() {
var arr = new List<int>();
bool file = true;
int file_id = 0;
foreach (var ch in data) {
if (file) {
Enumerable.Range(0, ch - '0').ToList().ForEach(_ => arr.Add(file_id));
file_id++;
} else {
Enumerable.Range(0, ch - '0').ToList().ForEach(_ => arr.Add(-1));
}
file = !file;
}
int from_ptr = arr.Count - 1;
int to_ptr = 0;
while (from_ptr > to_ptr) {
if (arr[to_ptr] != -1) {
to_ptr++;
continue;
}
if (arr[from_ptr] == -1) {
from_ptr--;
continue;
}
arr[to_ptr] = arr[from_ptr];
arr[from_ptr] = -1;
to_ptr++;
from_ptr--;
}
return Enumerable.Range(0, arr.Count)
.Select(block_id => arr[block_id] > 0 ? ((long)arr[block_id]) * block_id : 0)
.Sum().ToString();
}
public string SolveSecond() {
var files = new List<(int Start, int Size, int Id)>();
bool is_file = true;
int file_id = 0;
int block_id = 0;
foreach (var ch in data) {
if (is_file) {
files.Add((block_id, ch - '0', file_id));
file_id++;
}
is_file = !is_file;
block_id += (ch - '0');
}
while (true) {
bool moved = false;
for (int from_ptr = files.Count - 1; from_ptr >= 1; from_ptr--) {
var file = files[from_ptr];
if (file.Id >= file_id) continue;
file_id = file.Id;
for (int to_ptr = 0; to_ptr < from_ptr; to_ptr++) {
if (files[to_ptr + 1].Start - files[to_ptr].Start - files[to_ptr].Size >= file.Size) {
files.RemoveAt(from_ptr);
files.Insert(to_ptr + 1, file with { Start = files[to_ptr].Start + files[to_ptr].Size });
moved = true;
break;
}
}
if (moved) break;
}
if (!moved) break;
}
return files.Select(file => ((long)file.Id) * file.Size * (2 * ((long)file.Start) + file.Size - 1) / 2)
.Sum().ToString();
}
}
1 point
Deleted by creator
