day17.lisp (5712B)
1 (defpackage #:adventofcode2022/day17 2 (:use #:cl #:adventofcode2022) 3 (:import-from #:alexandria 4 #:define-constant)) 5 (in-package #:adventofcode2022/day17) 6 7 (defclass rock () 8 ((shape :initarg :shape 9 :accessor shape))) 10 11 (defmethod width ((r rock)) 12 (array-dimension (shape r) 1)) 13 14 (defmethod height ((r rock)) 15 (array-dimension (shape r) 0)) 16 17 (defparameter *rocks* 18 (vector (make-instance 'rock 19 :shape #2A((1 1 1 1))) 20 (make-instance 'rock 21 :shape #2A((0 1 0) 22 (1 1 1) 23 (0 1 0))) 24 (make-instance 'rock 25 :shape #2A((0 0 1) 26 (0 0 1) 27 (1 1 1))) 28 (make-instance 'rock 29 :shape #2A((1) 30 (1) 31 (1) 32 (1))) 33 (make-instance 'rock 34 :shape #2A((1 1) 35 (1 1))))) 36 37 (defclass cave () 38 ((positions :initform (make-hash-table :test 'equal) 39 :reader positions) 40 (width :initarg :width 41 :reader width) 42 (tip-y :initform -1 43 :accessor tip-y))) 44 45 (defmethod put-rock ((c cave) (r rock) x y) 46 (loop for rock-y below (height r) 47 do (loop for rock-x below (width r) 48 for cave-x = (+ rock-x x) 49 for cave-y = (- y rock-y) 50 do (when (= (aref (shape r) rock-y rock-x) 1) 51 (when (> cave-y (tip-y c)) 52 (setf (tip-y c) cave-y)) 53 (setf (gethash (list cave-x cave-y) 54 (positions c)) 55 t))))) 56 57 (defmethod rock-collides-p ((c cave) (r rock) x y) 58 (when (or (< x 0) 59 (> (+ x (width r)) (width c)) 60 (< (- y (1- (height r))) 0)) 61 (return-from rock-collides-p t)) 62 (loop named outer 63 for rock-y below (height r) 64 do (loop for rock-x below (width r) 65 for cave-x = (+ rock-x x) 66 for cave-y = (- y rock-y) 67 when (and (= (aref (shape r) rock-y rock-x) 1) 68 (gethash (list cave-x cave-y) 69 (positions c))) 70 do (return-from outer t)))) 71 72 (defmethod print-cave ((c cave)) 73 (loop for y from (tip-y c) downto 0 74 do (loop initially (format t "|") 75 for x below (width c) 76 do (format t (if (gethash (list x y) (positions c)) 77 "#" ".")) 78 finally (format t "|~%")) 79 finally (loop initially (format t "+") 80 for x below (width c) 81 do (format t "-") 82 finally (format t "+~%")))) 83 84 (defun find-pattern (list) 85 (loop for start from 0 86 thereis (loop for length from 500 to (floor (/ (- (length list) start) 2)) 87 when (loop for i below length 88 for c-1 = (elt list (+ start i)) 89 for c-2 = (elt list (+ start i length)) 90 always (= c-1 c-2)) 91 do (return-from find-pattern (values start length))))) 92 93 (defun play-tetris (dirs n-rocks) 94 (loop with cave = (make-instance 'cave :width 7) 95 with round = 0 96 with history = nil 97 for i below n-rocks 98 for rock = (aref *rocks* (mod i (length *rocks*))) 99 do (loop with rock-x = 2 100 with rock-y = (+ (tip-y cave) 3 (height rock)) 101 with old-tip = (tip-y cave) 102 for dir = (aref dirs (mod round (length dirs))) 103 do (incf round) 104 do (cond 105 ((char= dir #\<) 106 (unless (rock-collides-p cave rock 107 (1- rock-x) 108 rock-y) 109 (decf rock-x))) 110 ((char= dir #\>) 111 (unless (rock-collides-p cave rock 112 (1+ rock-x) 113 rock-y) 114 (incf rock-x)))) 115 if (rock-collides-p cave rock rock-x (1- rock-y)) 116 do (put-rock cave rock rock-x rock-y) 117 and do (push (- (tip-y cave) old-tip) history) 118 and return nil 119 else 120 do (decf rock-y)) 121 ;;do (print-cave cave) 122 finally (return-from play-tetris 123 (values (1+ (tip-y cave)) 124 (coerce (reverse history) 125 'vector))))) 126 127 (defun task1 (input) 128 (play-tetris (car input) 2022)) 129 130 (defun task2 (input) 131 (let ((simulate-n-rounds 10000) 132 (simulation-target-rounds 1000000000000)) 133 (multiple-value-bind (height history) 134 (play-tetris (car input) simulate-n-rounds) 135 (declare (ignore height)) 136 (multiple-value-bind (start length) 137 (find-pattern history) 138 (let* ((initial (reduce #'+ (subseq history 0 start))) 139 (cycle (subseq history start (+ start length))) 140 (diff-per-cycle (reduce #'+ cycle))) 141 (multiple-value-bind (n-cycles n-rest) 142 (floor (- simulation-target-rounds start) length) 143 (+ initial 144 (* n-cycles diff-per-cycle) 145 (reduce #'+ (subseq cycle 0 n-rest))))))))) 146 147 (define-day 17 148 () 149 #'task1 150 #'task2)