On Day 9 we are simulating defragging a disk. The input is a list of digits that alternate between a file size and a gap size. No file or gap is larger than 9 blocks.
The first part of the problem is to simply move the rightmost block that contains a file to the leftmost empty space. We repeat until there are no more empty spaces. Again, we could attempt to shoehorn this into a series approach, but it is straightforward to use an array to represent our disk and use side effects to simulate moving the blocks around.
Whenever you use an array, you’ll virtually always want to
side effect the array contents, and you’ll virtually always
iterate over the array. As a result, the do macro and
its varaints such as dotimes will be useful interation
constructs. The code will be definitely not be functional, but
imperative in nature. There is just going to be state hanging out
everywhere in this code.
The first thing we have to do is read the input:
;;; -*- Lisp -*-
(in-package "ADVENT2024/DAY9")
(defun read-input (input-file)
(with-open-file (stream input-file :direction :input)
(read-line stream nil nil)))
(defun read-layout (input-file)
(let* ((line (read-input input-file))
(file-count (/ (1+ (length line)) 2))
(files (make-simple-vector file-count))
(free-block-count (1- file-count))
(free-blocks (make-simple-vector free-block-count)))
(do ((input-index 0 (1+ input-index))
(disk-loc 0 (+ disk-loc (char->decimal (schar line input-index))))
(file-flag t (not file-flag))
(file-id 0 (if file-flag
(1+ file-id)
file-id))
(free-block-index 0 (if file-flag
free-block-index
(1+ free-block-index))))
((>= input-index (length line)) (values files free-blocks))
(if file-flag
(setf (svref files file-id)
(cons disk-loc (char->decimal (schar line input-index))))
(setf (svref free-blocks free-block-index)
(cons disk-loc (make-simple-vector (char->decimal (schar line input-index))
:initial-element nil)))))))
The main iteration alternates between reading a file block and a free block. The blocks are placed in a file array or a free-block array depending on the file-flag, which toggles on each pass through the loop. The disk-loc is updated with the size of the file or free block. File blocks are just the disk-loc consed to the file size, but free blocks are the disk-loc consed to an empty array that will be filled in later.
We’ll be required to compute a “checksum” of the disk, which will, for each block, the number of the block multplied by the file id of the file in the block. Since the files and the freelist are represented differently, we need a separate routine for each one and we’ll add them at the end.
(defun files-checksum (files)
(collect-sum
(#M(lambda (file-id)
(let ((file-record (svref files file-id)))
(collect-sum
(#M(lambda (i)
(* file-id (+ (car file-record) i)))
(scan-range :below (cdr file-record))))))
(scan-range :below (length files)))))
The outer collect-sum loop iterates over each file
summing the checksums. The inner collect-sum iterates
over the blocks (stored in the cdr of the file record) in the file
summing the product of the file-id and the offset of the block
itself.
We handle freelist segments differently. They have an array into which we have moved file blocks, so we iterate over the array and multiply the file-id in the array (if there is one) by the freelist block offset and sum them:
(defun freelist-checksum (freelist)
(collect-sum
(#M(lambda (freelist-record)
(let* ((segment-base (car freelist-record))
(segment (cdr freelist-record)))
(collect-sum
(#M(lambda (offset-in-segment)
(let ((file-id (or (svref segment offset-in-segment) 0)))
(* file-id (+ segment-base offset-in-segment))))
(scan-range :below (length segment))))))
(scan ’vector freelist))))
(defun filesystem-checksum (files freelist)
(+ (files-checksum files)
(freelist-checksum freelist)))
The two parts of the day’s puzzle involve two different strategies for “defragging” the disk. For part 1, we repeatedly move the rightmost file block to the leftmost free block. To find the rightmost occupied block, we iterate over the file list from right to left:
(defun source-block (files)
(do ((file-id (1- (length files)) (1- file-id)))
((not (zerop (cdr (svref files file-id))))
(values (+ (car (svref files file-id)) (cdr (svref files file-id)))
(svref files file-id)
file-id))))
To find the leftmost free block, we search the free blocks until we find one that is not fully occupied.
(defun target-block (freelist)
(let* ((free-segment (find-if (lambda (segment)
(position nil (cdr segment)))
freelist))
(offset (position nil (cdr free-segment))))
(values (+ (car free-segment) offset)
(cdr free-segment)
offset)))
These aren’t the most efficient because they forget the information from the previous search, but presumably a defragging process would be dominated by the disk reads and writes.
Once we have the source and target blocks, we move the source block to the target block:
(defun move-block! (files freelist)
(multiple-value-bind (source-block source-record file-id) (source-block files)
(multiple-value-bind (target-block target-segment target-offset) (target-block freelist)
(when (< target-block source-block)
(decf (cdr source-record))
(setf (svref target-segment target-offset) file-id)
t))))
We only move blocks to lower addresses and return NIL
if we cannot move a block.
To defrag with this strategy, we just repeatedly call move-block!
until it returns NIL:
(defun defrag1! (files freelist)
(when (move-block! files freelist)
(defrag1! files freelist)))
(defun puzzle (input-pathname defrag)
(multiple-value-bind (files freelist) (read-layout input-pathname)
(funcall defrag files freelist)
(filesystem-checksum files freelist)))
(defun part-1 ()
(puzzle (input-pathname) #’defrag1!))
Part 2 uses a different strategy to defrag the disk. Instead of blocks, we move entire files, and we move them to the leftmost block that they’ll fit. To find that leftmost block, we scan the freelist:
(defun defrag2-target (file freelist)
(collect-first
(choose-if
(lambda (free-record)
(and (< (car free-record) (car file))
(<= (cdr file) (count nil (cdr free-record)))))
(scan ’vector freelist))))
We iterate over the files from right to left:
(defun defrag2! (files freelist)
(do ((file-id (1- (length files)) (- file-id 1)))
((zerop file-id))
(let* ((file (svef files file-id))
(target (defrag2-target file freelist)))
(when target
(let* ((start (position nil (cdr target)))
(end (+ start (cdr file))))
(fill (cdr target) file-id :start start :end end)
(setf (cdr file) 0))))))
(defun part-2 ()
(puzzle (input-pathname) #’defrag2!))
No comments:
Post a Comment