advent-of-code-2023

My solutions to AoC 2023
git clone git://git.entf.net/advent-of-code-2023
Log | Files | Refs

commit 83e577fc461fbc4022842b0883ab3ef4c8f7f1fd
parent d577e6be7374ee8d749c64ed2a22dfa622fd41f8
Author: Lukas Henkel <lh@entf.net>
Date:   Sun,  3 Dec 2023 11:48:36 +0100

Optimize day 3

Diffstat:
Msrc/day-3.lisp | 144++++++++++++++++++++++++++++++++++++++-----------------------------------------
Msrc/main.lisp | 2+-
Msrc/utils.lisp | 109+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++------------------
Mt/utils.lisp | 13-------------
4 files changed, 156 insertions(+), 112 deletions(-)

diff --git a/src/day-3.lisp b/src/day-3.lisp @@ -8,84 +8,80 @@ (not (digit-char-p symbol)))) (declaim (inline digit-at-p)) -(defun digit-at-p (map y x) - (digit-char-p (aref map y x))) +(defun digit-at-p (map point) + (digit-char-p (map-cell map point))) -(defun extract-part-number (map y start-x) - (loop for x from start-x below (array-dimension map 1) - for char = (aref map y x) - while (digit-char-p char) - collect char into chars - finally (return (values (parse-integer (coerce chars 'string)) - (1- x))))) +(defun number-borders-symbol (map y x-1 x-2) + (labels ((scan-line (y) + (loop for x from x-1 to x-2 + for cell = (map-cell map (cons x y)) + thereis (schematic-symbol-p cell)))) + (or (when (> x-1 0) + (decf x-1) + (schematic-symbol-p (map-cell map (cons x-1 y)))) + (when (< x-2 (1- (input-map-width map))) + (incf x-2) + (schematic-symbol-p (map-cell map (cons x-2 y)))) + (and (> y 0) + (scan-line (1- y))) + (and (< y (1- (input-map-height map))) + (scan-line (1+ y)))))) -(defun find-part-number (map y x) - (extract-part-number map - y - (loop for px from x downto 0 - while (digit-at-p map y px) - finally (return (1+ px))))) +(declaim (ftype (function (input-map cons) fixnum) read-part-number)) +(defun read-part-number (map point) + (destructuring-bind (x . y) + point + (map-integer-at map (cons (loop for sx from x downto 0 + while (digit-at-p map (cons sx y)) + finally (return (1+ sx))) + y)))) -(defun gear-neighbouring-part-numbers (map y x) - (let ((left-open? (> x 0)) - (right-open? (< x (array-dimension map 1))) - (top-open? (> y 0)) - (bottom-open? (< y (array-dimension map 0))) - (numbers)) - (when (and left-open? - (digit-at-p map y (1- x))) - (push (find-part-number map y (1- x)) numbers) ) - (when (and right-open? - (digit-at-p map y (1+ x))) - (push (find-part-number map y (1+ x)) numbers)) - (when top-open? - (if (digit-at-p map (1- y) x) - (push (find-part-number map (1- y) x) numbers) - (progn - (when (and left-open? - (digit-at-p map (1- y) (1- x))) - (push (find-part-number map (1- y) (1- x)) numbers)) - (when (and right-open? - (digit-at-p map (1- y) (1+ x))) - (push (find-part-number map (1- y) (1+ x)) numbers))))) - (when bottom-open? - (if (digit-at-p map (1+ y) x) - (push (find-part-number map (1+ y) x) numbers) - (progn - (when (and left-open? - (digit-at-p map (1+ y) (1- x))) - (push (find-part-number map (1+ y) (1- x)) numbers)) - (when (and right-open? - (digit-at-p map (1+ y) (1+ x))) - (push (find-part-number map (1+ y) (1+ x)) numbers))))) - numbers)) - -(defun calculate-gear-ratio (map y x) - (let ((neighbouring-part-numbers (gear-neighbouring-part-numbers map y x))) - (if (= (length neighbouring-part-numbers) 2) - (apply #'* neighbouring-part-numbers) - 0))) +(defun get-gear-ratio (map point top-open? bottom-open? left-open? right-open?) + (macrolet ((push-neighbor-if-digit (check neighbour) + `(let ((p (point+ point ,neighbour))) + (when (and ,check + (digit-at-p map p)) + (push p number-points))))) + (let ((number-points)) + (push-neighbor-if-digit left-open? '(-1 . 0)) + (push-neighbor-if-digit right-open? '(1 . 0)) + (when top-open? + (unless (push-neighbor-if-digit t '(0 . -1)) + (push-neighbor-if-digit left-open? '(-1 . -1)) + (push-neighbor-if-digit right-open? '(1 . -1)))) + (when bottom-open? + (unless (push-neighbor-if-digit t '(0 . 1)) + (push-neighbor-if-digit left-open? '(-1 . 1)) + (push-neighbor-if-digit right-open? '(1 . 1)))) + (when (/= (length number-points) 2) + (return-from get-gear-ratio 0)) + (* (read-part-number map (first number-points)) + (read-part-number map (second number-points)))))) (defun day-3 (input) (loop with map = (make-map input) - with task-1 = 0 - with task-2 = 0 - for y from 0 below (array-dimension map 0) - do (loop with number-start = nil - for x from 0 below (array-dimension map 1) - for char = (aref map y x) - for digit? = (digit-char-p char) - when (and digit? (null number-start)) - do (setf number-start x) - unless digit? - do (setf number-start nil) - when (and digit? - (member-if #'schematic-symbol-p - (map-neighbours map y x))) - do (multiple-value-bind (number next) - (extract-part-number map y number-start) - (setf x next) - (incf task-1 number)) - when (char= char #\*) - do (incf task-2 (calculate-gear-ratio map y x))) + with task-1 fixnum = 0 + with task-2 fixnum = 0 + with width = (input-map-width map) + with height = (input-map-height map) + for y from 0 below height + for top-open? = (> y 0) + for bottom-open? = (< y (1- height)) + do (loop for x from 0 below (input-map-width map) + for left-open? = (> x 0) + for right-open? = (< x (1- width)) + for point = (cons x y) + for cell = (map-cell map point) + do (cond + ((digit-char-p cell) + (multiple-value-bind (number end) + (map-integer-at map point) + (decf end) + (when (number-borders-symbol map y x end) + (incf task-1 number)) + (setf x end))) + ((char= cell #\*) + (incf task-2 (get-gear-ratio map point + top-open? bottom-open? + left-open? right-open?))))) finally (return (values task-1 task-2)))) diff --git a/src/main.lisp b/src/main.lisp @@ -127,5 +127,5 @@ (input (or (and #1=(second args) (parse-namestring #1#)) (input-pathname today)))) - (dolist (task (multiple-value-list (run-day today input))) + (dolist (task (multiple-value-list (time (run-day today input)))) (format t "~A~%" task)))) diff --git a/src/utils.lisp b/src/utils.lisp @@ -7,7 +7,16 @@ #:read-input-match #:char-number #:make-map - #:map-neighbours)) + #:input-map + #:input-map-width + #:input-map-height + #:map-cell + #:map-integer-at + #:point+ + #:point-x + #:point-y + #:point-neighbours + #:do-map-neighbours)) (in-package #:aoc/utils) (defun normalize-type (type) @@ -72,30 +81,82 @@ (defun char-number (char) (- (char-int char) 48)) -(defun make-map (input &key (value #'identity) delimiter) +(defstruct input-map + (data nil :type (simple-array simple-string)) + (width 0 :type fixnum) + (height 0 :type fixnum)) + +(defun make-map (input) (loop with width = nil with data = nil for row = (read-line input nil) for height from 0 - while (and row (> (length row) 0)) - do (let ((fields (mapcar value (if delimiter - (split-sequence delimiter row :test #'string=) - (coerce row 'list))))) - (unless width - (setf width (length row))) - (push fields data)) - finally (return (make-array (list height width) - :initial-contents (nreverse data))))) - -(defun map-neighbours (map cy cx) - (loop with height = (array-dimension map 0) - with width = (array-dimension map 1) - for y from (1- cy) to (1+ cy) - nconc (loop for x from (1- cx) to (1+ cx) - when (and (not (and (= x cx) - (= y cy))) - (>= x 0) - (>= y 0) - (< x width) - (< y height)) - collect (aref map y x)))) + while row + when (= height 0) + do (setf width (length row)) + do (push row data) + finally (return (make-input-map :data (coerce (nreverse data) 'vector) + :width width + :height height)))) + +(declaim (inline point+ point-x point-y) + (ftype (function (cons) fixnum) point-x point-y)) + +(defun point-x (point) + (car point)) + +(defun point-y (point) + (cdr point)) + +(defun point+ (point-a point-b) + (cons (the fixnum (+ (point-x point-a) + (point-x point-b))) + (the fixnum (+ (point-y point-a) + (point-y point-b))))) + +(declaim (inline map-cell map-integer-at) + (ftype (function (input-map cons) character) map-cell)) + +(defun map-cell (map point) + (aref (aref (input-map-data map) + (point-y point)) + (point-x point))) + +(defun map-integer-at (map point) + (parse-integer (aref (input-map-data map) (point-y point)) + :start (point-x point) + :junk-allowed t)) + +(defparameter *map-neighbours* (loop for y from -1 to 1 + nconc (loop for x from -1 to 1 + when (not (and (= y 0) + (= x 0))) + collect (cons x y)))) + +(defun point-neighbours (point) + (mapcar (curry #'point+ point) + *map-neighbours*)) + +(defmacro do-map-neighbours ((neighbour-point map start-point) &body body) + (with-gensyms (width height lb? rb? tb? bb?) + (once-only ((sp start-point) + (mp map)) + `(let* ((,width (input-map-width ,mp)) + (,height (input-map-height ,mp)) + (,lb? (> (point-x ,sp) 0)) + (,rb? (< (point-x ,sp) (1- ,width))) + (,tb? (> (point-y ,sp) 0)) + (,bb? (< (point-y ,sp) (1- ,height)))) + ,@(loop for nb in *map-neighbours* + collect `(let ((,neighbour-point (point+ ,sp ',nb))) + (when (and ,@(let ((checks)) + (when (< (point-x nb) 0) + (push lb? checks)) + (when (< (point-y nb) 0) + (push tb? checks)) + (when (> (point-x nb) 0) + (push rb? checks)) + (when (> (point-y nb) 0) + (push bb? checks)) + checks)) + ,@body))))))) diff --git a/t/utils.lisp b/t/utils.lisp @@ -56,16 +56,3 @@ x: 2, y: 5") (read-input-match stream "(\\w+): (\\d+), (\\w+): (\\d+)" :types '(string integer string integer))))) - - -(define-test test-make-map - () - (with-input-from-string (stream "12345 -54321 -12345 -54321") - (assert-equalp #2A((1 2 3 4 5) - (5 4 3 2 1) - (1 2 3 4 5) - (5 4 3 2 1)) - (make-map stream :value #'char-number))))