day-14.lisp (4112B)
1 (defpackage #:aoc/day-14 2 (:use #:cl #:aoc/utils) 3 (:export 4 #:day-14 5 #:*minimum-pattern-length*)) 6 (in-package #:aoc/day-14) 7 8 (defun point-x-constructor (y) 9 (lambda (x) 10 (cons x y))) 11 12 (defun point-y-constructor (x) 13 (lambda (y) 14 (cons x y))) 15 16 (defun make-in-range-p (to) 17 (lambda (i) 18 (and (>= i 0) 19 (< i to)))) 20 21 (defun slide-rock-direction-configuration (map point direction) 22 (ecase direction 23 (:north 24 (values (1- (point-y point)) 25 #'1- #'1+ 26 (make-in-range-p (input-map-height map)) 27 (point-y-constructor (point-x point)))) 28 (:west 29 (values (1- (point-x point)) 30 #'1- #'1+ 31 (make-in-range-p (input-map-width map)) 32 (point-x-constructor (point-y point)))) 33 (:south 34 (values (1+ (point-y point)) 35 #'1+ #'1- 36 (make-in-range-p (input-map-height map)) 37 (point-y-constructor (point-x point)))) 38 (:east 39 (values (1+ (point-x point)) 40 #'1+ #'1- 41 (make-in-range-p (input-map-width map)) 42 (point-x-constructor (point-y point)))))) 43 44 (defun slide-rock (map pos direction) 45 (multiple-value-bind (start-pos by final in-range-p make-point) 46 (slide-rock-direction-configuration map pos direction) 47 (loop for i = start-pos then (funcall by i) 48 while (funcall in-range-p i) 49 for cell = (map-cell map (funcall make-point i)) 50 while (char= cell #\.) 51 finally (setf (map-cell map pos) #\. 52 (map-cell map (funcall make-point (funcall final i))) #\O)))) 53 54 (defun slide-direction-configuration (map direction) 55 (ecase direction 56 (:north 57 (values 0 #'1+ 58 (curry #'> (input-map-height map)) (input-map-width map) 59 (lambda (d-1 d-2) 60 (cons d-2 d-1)))) 61 (:west 62 (values 0 #'1+ 63 (curry #'> (input-map-width map)) (input-map-height map) 64 (lambda (d-1 d-2) 65 (cons d-1 d-2)))) 66 (:south 67 (values (1- (input-map-height map)) #'1- 68 (curry #'<= 0) (input-map-width map) 69 (lambda (d-1 d-2) 70 (cons d-2 d-1)))) 71 (:east 72 (values (1- (input-map-width map)) #'1- 73 (curry #'<= 0) (input-map-height map) 74 (lambda (d-1 d-2) 75 (cons d-1 d-2)))))) 76 77 (defun slide-rocks (map direction) 78 (multiple-value-bind (d-1-from d-1-by d-1-while-p d-2-below make-point) 79 (slide-direction-configuration map direction) 80 (loop for d-1 = d-1-from then (funcall d-1-by d-1) 81 while (funcall d-1-while-p d-1) 82 do (loop for d-2 from 0 below d-2-below 83 for pos = (funcall make-point d-1 d-2) 84 for cell = (map-cell map pos) 85 when (char= cell #\O) 86 do (slide-rock map pos direction))))) 87 88 (defun total-load (map) 89 (loop for y from 0 below (input-map-height map) 90 for load-multiplier downfrom (input-map-height map) 91 sum (loop for x from 0 below (input-map-width map) 92 when (char= (map-cell map (cons x y)) #\O) 93 sum load-multiplier))) 94 95 (defun spin-cycle (map &optional (cycle '(:north :west :south :east))) 96 (loop for direction in cycle 97 do (slide-rocks map direction))) 98 99 (defparameter *minimum-pattern-length* 100) 100 101 (defun day-14 (input) 102 (let ((map (make-map input)) 103 task-1 task-2) 104 (slide-rocks map :north) 105 (setf task-1 (total-load map)) 106 (spin-cycle map '(:west :south :east)) 107 (loop with history = nil 108 for cycles from 1 109 do (spin-cycle map) 110 do (push (total-load map) history) 111 do (let ((pattern-length (find-pattern history *minimum-pattern-length*))) 112 (when pattern-length 113 (setf task-2 114 (elt history 115 (1+ (- pattern-length 116 (- (mod 1000000000 pattern-length) 117 (- cycles (* pattern-length 2))))))) 118 (return)))) 119 (values task-1 task-2)))