import Control.Monad
import Data.Bifunctor

import Control.Arrow hiding (first, second)

import Data.Map (Map)
import Data.Set (Set)
import Data.Array.Unboxed (UArray)

import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Ord as Ord
import qualified Data.List as List
import qualified Data.Char as Char
import qualified Data.Maybe as Maybe
import qualified Data.Array.Unboxed as UArray

toNumber = flip (-) (Char.ord '0') <<< Char.ord 

type FileID = Int
type FileLength = Int
type DiskPosition = Int
type File = (FileID, (DiskPosition, FileLength))
type EmptyMap = Map FileLength (Set DiskPosition)

readDisk :: DiskPosition -> [(Bool, FileLength)] -> [(Bool, (DiskPosition, FileLength))]
readDisk _ [] = []
readDisk o ((True, l):fs)  = (True, (o, l))  : readDisk (o+l) fs
readDisk o ((False, l):fs) = (False, (o, l)) : readDisk (o+l) fs

parse2 :: String -> ([File], EmptyMap)
parse2 s = takeWhile (/= '\n')
        >>> map toNumber
        >>> zip (cycle [True, False]) -- True is File, False is empty
        >>> readDisk 0
        >>> List.partition fst
        >>> join bimap (map snd)
        >>> first (zip [0..])
        >>> first List.reverse
        >>> second (filter (snd >>> (/= 0)))
        >>> second (List.sortOn snd)
        >>> second (List.groupBy (curry $ (snd *** snd) >>> uncurry (==)))
        >>> second (List.map (snd . head &&& map fst))
        >>> second (List.map (second Set.fromDistinctAscList))
        >>> second Map.fromDistinctAscList
        $ s

maybeMinimumBy :: (a -> a -> Ordering) -> [a] -> Maybe a
maybeMinimumBy _ [] = Nothing
maybeMinimumBy f as = Just $ List.minimumBy f as

fileChecksum fid fpos flen = fid * (fpos * flen + ((flen-1) * (flen-1) + (flen-1)) `div` 2)

type Checksum = Int
moveFilesAccumulate :: (Checksum, EmptyMap) -> File -> (Checksum, EmptyMap)
moveFilesAccumulate (check, spaces) (fid, (fpos, flen)) = do
        let bestFit = Map.map (Set.minView)
                >>> Map.toList
                >>> List.filter (fst >>> (>= flen))
                >>> List.filter (snd >>> Maybe.isJust)
                >>> List.map (second Maybe.fromJust) -- [(FileLength, (DiskPosition, Set DiskPosition))]
                >>> List.filter (snd >>> fst >>> (< fpos))
                >>> maybeMinimumBy (\ (_, (p, _)) (_, (p', _)) -> Ord.compare p p')
                $ spaces

        case bestFit of
                Nothing -> (check + fileChecksum fid fpos flen, spaces)
                Just (spaceLength, (spacePosition, remainingSet)) -> do
                        

                        -- remove the old empty entry by replacing the set
                        let updatedMap  = Map.update (const $! Just remainingSet) spaceLength spaces

                        -- add the remaining space, if any
                        let remainingSpace = spaceLength - flen
                        let remainingSpacePosition = spacePosition + flen
                        let updatedMap' = if remainingSpace == 0 then updatedMap else Map.insertWith (Set.union) remainingSpace (Set.singleton remainingSpacePosition) updatedMap

                        (check + fileChecksum fid spacePosition flen, updatedMap')

parse1 :: String -> UArray Int Int
parse1 s = UArray.listArray (0, sum lengthsOnly - 1) blocks
        where
                lengthsOnly = filter (/= '\n')
                        >>> map toNumber
                        $ s :: [Int]
                blocks = zip [0..]
                        >>> List.concatMap (\ (index, n) -> if index `mod` 2 == 0 then replicate n (index `div` 2) else replicate n (-1))
                        $ lengthsOnly :: [Int]

moveBlocksAccumulate :: Int -> Int -> UArray Int Int -> Int
moveBlocksAccumulate start stop array
        | start      == stop   = if startBlock == -1 then 0 else start * startBlock
        | start      >  stop   = 0
        | stopBlock  == -1     = moveBlocksAccumulate start (stop - 1) array
        | startBlock == -1     = movedChecksum + moveBlocksAccumulate (start + 1) (stop - 1) array
        | startBlock /= -1     = startChecksum + moveBlocksAccumulate (start + 1) stop array
        where
                startBlock    = array UArray.! start
                stopBlock     = array UArray.! stop
                movedChecksum = stopBlock * start
                startChecksum = startBlock * start

part1 a = moveBlocksAccumulate 0 arrayLength a
        where
                (_, arrayLength) = UArray.bounds a
part2 (files, spaces) = foldl moveFilesAccumulate (0, spaces)
        >>> fst
        $ files

main = getContents
        >>= print
        . (part1 . parse1 &&& part2 . parse2)

int[] layout = new int[0];
public void Input(IEnumerable<string> lines)
{
  layout = string.Join("", lines).ToCharArray().Select(c => int.Parse(c.ToString())).ToArray();
}

public void Part1()
{
  ushort?[] blocks = BuildBlockmap().ToArray();

  var it = 0;
  for (var i = blocks.Length - 1; i > it; i--)
  {
    if (blocks[i] == null)
      continue;

    while (it < blocks.Length && blocks[it] != null)
      ++it;

    if (it >= blocks.Length)
      break;

    (blocks[it], blocks[i]) = (blocks[i], null);
  }

  long checksum = 0;
  foreach (var part in blocks.OfType<ushort>().Select((b, i) => i * b))
    checksum += part;

  Console.WriteLine($"Checksum: {checksum}");
}

public void Part2()
{
  var sparse = BuildSparsemap().ToList();

  for (var i = sparse.Count - 1; i >= 0; i--)
  {
    if (sparse[i].Item1 == null)
      continue;

    for (var j = 0; j < i; ++j)
    {
      if (sparse[j].Item1 != null)
        continue;

      if (sparse[i].Item2 > sparse[j].Item2)
        continue;

      var size = sparse[j].Item2;
      size -= sparse[i].Item2;

      (sparse[j], sparse[i]) = (sparse[i], (null, sparse[i].Item2));

      if (i + 1 < sparse.Count && sparse[i + 1].Item1 == null)
      {
        sparse[i] = (null, (ushort)(sparse[i].Item2 + sparse[i + 1].Item2));
        sparse.RemoveAt(i + 1);
      }

      if (sparse[i - 1].Item1 == null)
      {
        sparse[i - 1] = (null, (ushort)(sparse[i - 1].Item2 + sparse[i].Item2));
        sparse.RemoveAt(i);
      }

      if (size > 0)
        sparse.Insert(j + 1, (null, size));

      j = i + 1;
    }
  }

  int ind = 0;
  long checksum = 0;
  foreach (var (val, cnt) in sparse)
    for (var i = 0; i < cnt; ++i)
    {
      checksum += (val ?? 0) * ind;
      ++ind;
    }

  Console.WriteLine($"Checksum: {checksum}");
}

IEnumerable<ushort?> BuildBlockmap()
{
  ushort blockit = 0;
  bool block = true;
  foreach (var value in layout)
  {
    for (int i = 0; i < value; ++i)
      yield return block ? blockit : null;
    if (block)
      blockit++;
    block = !block;
  }
}

IEnumerable<(ushort?, ushort)> BuildSparsemap()
{
  ushort blockit = 0;
  bool block = true;
  foreach (var value in layout)
  {
    if (block)
      yield return (blockit++, (ushort)value);
    else
      yield return (null, (ushort)value);
    block = !block;
  }
}

function readInput(inputFile::String)
	f = open(inputFile,"r"); diskMap::String = readline(f); close(f)
	disk::Vector{String} = []
	id::Int = 0
	for (i,c) in enumerate(diskMap)
		if i%2 != 0 #used space
			for j=1 : parse(Int,c)
				push!(disk,string(id))
			end
			id += 1
		else #free space
			for j=1 : parse(Int,c)
				push!(disk,".")
			end
		end
	end
	return disk
end

function getDiscBlocks(disk::Vector{String})::Vector{Vector{Int}}
	diskBlocks::Vector{Vector{Int}} = []
	currBlock::Int = parse(Int,disk[1]) #-1 for free space
	blockLength::Int = 0; blockStartIndex::Int = 0
	for (i,b) in enumerate(map(x->(x=="." ? -1 : parse(Int,x)),disk))
		if b == currBlock
			blockLength += 1
		else #b!=currBlock
			push!(diskBlocks,[currBlock,blockLength,blockStartIndex,i-2])
			currBlock = b
			blockLength = 1
			blockStartIndex = i-1 #start of next block
		end
	end
	push!(diskBlocks,[currBlock,blockLength,blockStartIndex,length(disk)-1])
	return diskBlocks
end

function compressDisk(disk::Vector{String})::Vector{Int} #part 1
	compressedDisk::Vector{Int} = []
	startPtr::Int=1; endPtr::Int=length(disk)
	while endPtr >= startPtr
		while endPtr>startPtr && disk[endPtr]=="."
			endPtr -= 1
		end
		while startPtr<endPtr && disk[startPtr]!="."
			push!(compressedDisk,parse(Int,disk[startPtr])) about AoC
			startPtr += 1
		end
		push!(compressedDisk,parse(Int,disk[endPtr]))
		startPtr+=1;endPtr-=1
	end
	return compressedDisk
end

function compressBlocks(diskBlocks::Vector{Vector{Int}})
	for i=length(diskBlocks) : -1 : 1 #go through all blocks, starting from end
		diskBlocks[i][1] == -1 ? continue : nothing
		for j=1 : i-1 #look for large enough empty space
			diskBlocks[j][1]!=-1 || diskBlocks[j][2]<diskBlocks[i][2] ? continue : nothing #skip occupied blocks and empty blocks that are too short
			diskBlocks[i][3] = diskBlocks[j][3] #set start index
			diskBlocks[i][4] = diskBlocks[j][3]+diskBlocks[i][2]-1 #set end index
			diskBlocks[j][3] += diskBlocks[i][2] #move start of empty block
			diskBlocks[j][2] -= diskBlocks[i][2] #adjust length of empty block
			break
		end
	end
	return diskBlocks
end

function calcChecksum(compressedDisk::Vector{Int})::Int
	checksum::Int = 0
	for (i,n) in enumerate(compressedDisk)
		checksum += n*(i-1)
	end
	return checksum
end

function calcChecksumBlocks(diskBlocks::Vector{Vector{Int}})::Int
	checksum::Int = 0
	for b in diskBlocks
		b[1]==-1 ? continue : nothing
		for i=b[3] : b[4]
			checksum += b[1]*i
		end
	end
	return checksum
end

disk::Vector{String} = readInput("input/day09Input")
@info "Part 1"
println("checksum: $(calcChecksum(compressDisk(disk)))")
@info "Part 2"
println("checksum: $(calcChecksumBlocks(compressBlocks(getDiscBlocks(disk)))")

because of text limit and this code being slow, I put it in a topaz paste: [ link ]

you can also find this code in the Topaz link: [ link ]

def int_of_char(x):
    return ord(x) - ord('0')

# Represent content as tuples:
# ('Empty', size) or ('File', id, size)
def parse(line):
    arr = []
    for i in range(len(line)):
        c = int_of_char(line[i])
        if i % 2 == 0:
            arr.append(('File', i // 2, c))
        else:
            arr.append(('Empty', c))
    return arr

def int_sum(low, high):
    return (high - low + 1) * (high + low) // 2

def size(elem):
    t = elem[0]
    if t == 'Empty':
        return elem[1]
    else:
        return elem[2]

def part1(array):
    total = 0
    left = 0
    pos = 0
    right = len(array) - 1

    while left < right:
        if array[left][0] == 'File':
            # File
            _, fid, fsize = array[left]
            total += fid * int_sum(pos, pos + fsize - 1)
            pos += fsize
            left += 1
        else:
            # Empty
            _, esize = array[left]
            if array[right][0] == 'Empty':
                right -= 1
            else:
                # Right is File
                _, fid, fsize = array[right]
                if esize >= fsize:
                    array[left] = ('Empty', esize - fsize)
                    total += fid * int_sum(pos, pos + fsize - 1)
                    pos += fsize
                    right -= 1
                else:
                    array[right] = ('File', fid, fsize - esize)
                    total += fid * int_sum(pos, pos + esize - 1)
                    pos += esize
                    left += 1

    # If one element remains (left == right)
    if left == right and left < len(array):
        if array[left][0] == 'File':
            _, fid, fsize = array[left]
            total += fid * int_sum(pos, pos + fsize - 1)

    return total

def positions(arr):
    total = 0
    res = []
    for e in arr:
        res.append(total)
        total += size(e)
    return res

def array_fold_right_i(f, arr, acc):
    pos = len(arr) - 1
    for elt in reversed(arr):
        acc = f(elt, pos, acc)
        pos -= 1
    return acc

def part2(array):
    def find_empty(size_needed, max_pos, pos):
        while pos <= max_pos:
            if array[pos][0] == 'File':
                raise Exception("Unexpected: only empty at odd positions")
            # Empty
            _, esize = array[pos]
            if esize >= size_needed:
                array[pos] = ('Empty', esize - size_needed)
                return pos
            pos += 2
        return None

    emptys = [1 if i < 10 else None for i in range(10)]
    pos_arr = positions(array)

    def fold_fun(elt, i, total):
        if elt[0] == 'Empty':
            return total
        # File
        _, fid, fsize = elt
        init_pos = emptys[fsize]
        if init_pos is None:
            new_pos = pos_arr[i]
        else:
            opt = find_empty(fsize, i, init_pos)
            if opt is None:
                new_pos = pos_arr[i]
            else:
                new_pos = pos_arr[opt]
                pos_arr[opt] += fsize
                emptys[fsize] = opt
        return total + fid * int_sum(new_pos, new_pos + fsize - 1)

    return array_fold_right_i(fold_fun, array, 0)

def main():
    with open('largest_test', 'r') as f:
        line = f.read().replace('\r', '').replace('\n', '')
    arr = parse(line)
    arr_copy = arr[:]
    p1 = part1(arr_copy)
    print("Part 1 :", p1)
    p2 = part2(arr)
    print("Part 2 :", p2)

if __name__ == "__main__":
    main()

#include "common.h"

/*
 * First went with a doubly linked list approach, but it was quite verbose
 * and we're dealing with short runs (max 9) anyway.
 */
static char input[20*1000+1];
static short disk[200*1000];
int input_sz, disk_sz;

static void
defrag(int p2)
{
	int a,b, a0=0, run, gap;

	/*
	 * b runs back to front, finding files.
	 * a runs front to back (from first gap, a0), finding gaps.
	 *
	 * For part 1 we short circuit the file length check so it deals
	 * with single tiles.
	 */
	for (b=disk_sz-1; b > 0; b--) {
		/* find and measure next file from back */
		for (; b>0 && !disk[b]; b--) ;
		for (run=1; p2 && b>0 && disk[b-1]==disk[b]; b--, run++) ;

		/* find the first gap */
		for (; a0 < b && disk[a0]; a0++) ;

		/* find a gap large enough */
		for (a=a0, gap=0; a<b; a++)
			if (!disk[a]) {
				for (gap=1; disk[a+gap] == disk[a]; gap++) ;
				if (gap >= run) break;
			}

		/* move if its */
		if (gap >= run)
			for (; run > 0; a++, run--) {
				disk[a] = disk[b+run-1];
				disk[b+run-1] = 0;
			}
	}
}

int
main(int argc, char **argv)
{

	int part, i,j;
	uint64_t ans[2]={};

	if (argc > 1)
		DISCARD(freopen(argv[1], "r", stdin));
	
	input_sz = (int)fread(input, 1, sizeof(input), stdin);
	assert(!ferror(stdin));
	assert(feof(stdin));

	for (part=0; part<2; part++) {
		disk_sz = 0;

		for (i=0; i < input_sz && isdigit(input[i]); i++)
		for (j=0; j < input[i]-'0'; j++) {
			assert(disk_sz < (int)LEN(disk));
			disk[disk_sz++] = i%2 ? 0 : i/2+1;
		}

		defrag(part);

		for (i=0; i < disk_sz; i++)
			if (disk[i])
				ans[part] += i * (disk[i]-1);
	}

	printf("08: %"PRIu64" %"PRIu64"\n", ans[0], ans[1]);
	return 0;
}

#include <stdio.h>

int
main(int argc, char **argv)
{
	char buf[16], p1[9]="aaaaaaaa", p2[9]="aaaaaaaa";
	int counts[8][256]={}, i,j;

	if (argc > 1)
		freopen(argv[1], "r", stdin);

	while (fgets(buf, sizeof(buf), stdin))
		for (i=0; i<8 && buf[i] >= 'a' && buf[i] <= 'z'; i++)
			counts[i][(int)buf[i]]++;

	for (i=0; i<8; i++)
	for (j='a'; j<='z'; j++) {
		if (counts[i][j] > counts[i][(int)p1[i]]) p1[i] = j;
		if (counts[i][j] < counts[i][(int)p2[i]]) p2[i] = j;
	}

	printf("06: %s %s\n", p1, p2);
	

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

import 'dart:math';
import 'package:collection/collection.dart';
import 'package:more/more.dart';

List<int> parse(List<String> lines) => lines.first
    .split('')
    .map(int.parse)
    .mapIndexed((i, e) => List.filled(e, (i.isOdd ? -1 : i ~/ 2)))
    .reduce((s, t) => s + t);

part1(List<String> lines) {
  var fs = parse(lines);
  var i = 0;
  while ((i = fs.indexOf(-1)) >= 0) {
    while (fs.last == -1) {
      fs.removeLast();
    }
    fs[i] = fs.removeLast();
  }
  return fs.mapIndexed((i, e) => i * e).sum;
}

Function eq = const ListEquality().equals;
part2(List<String> lines) {
  var fs = parse(lines);
  for (var target in 1.to(fs.max + 1).reversed) {
    var index = fs.indexOf(target);
    var length = fs.sublist(index).takeWhile((e) => e == target).length;
    var sseq = List.filled(length, -1);
    var space = fs
        .indices()
        .where((e) => e < index)
        .firstWhereOrNull((i) => eq(fs.sublist(i, i + length), sseq));
    if (space == null) continue;
    // Copy the file, clear old location.
    fs.replaceRange(space, space + length, List.filled(length, target));
    fs.replaceRange(index, index + length, List.filled(length, -1));
  }
  return fs.mapIndexed((i, e) => i * max(e, 0)).sum;
}

{-# 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