commit c036a3b56610fb1a2c76b77a871d2d29dd04a224
parent d577e6be7374ee8d749c64ed2a22dfa622fd41f8
Author: Lukas Henkel <lh@entf.net>
Date: Sun, 3 Dec 2023 11:48:36 +0100
Optimize day 3
Diffstat:
4 files changed, 170 insertions(+), 111 deletions(-)
diff --git a/src/day-3.lisp b/src/day-3.lisp
@@ -8,84 +8,95 @@
(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 task-2 (numbers number-positions gears)
+ (loop for gear in gears
+ for neighbours = (point-neighbours gear)
+ for number-neighbours = (remove
+ nil
+ (remove-duplicates
+ (mapcar (lambda (point)
+ (gethash point number-positions))
+ neighbours)
+ :test #'equal))
+ when (= (length number-neighbours) 2)
+ sum (the fixnum (apply #'* (mapcar (lambda (point)
+ (gethash point numbers))
+ number-neighbours))) fixnum))
-(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)))))
+(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 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))
+(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 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))))
