day-17.lisp (6983B)
1 (defpackage #:aoc/day-17 2 (:use #:cl #:aoc/utils) 3 (:export 4 #:*use-compiler* 5 #:make-registers 6 #:make-program 7 #:interpret 8 #:compile-program 9 #:day-17)) 10 (in-package #:aoc/day-17) 11 12 (defparameter *use-compiler* nil) 13 14 (defun parse-register (line) 15 (parse-integer line :start (1+ (position #\: line)))) 16 17 (defun make-registers (a &optional (b 0) (c 0)) 18 (make-array 3 19 :element-type 'fixnum 20 :initial-contents (list a b c))) 21 22 (defun parse-input (input) 23 (let ((a (parse-register (read-line input))) 24 (b (parse-register (read-line input))) 25 (c (parse-register (read-line input))) 26 (program-line (progn 27 (read-line input) 28 (read-line input)))) 29 (values (make-registers a b c) 30 (coerce (read-number-list program-line :start (1+ (position #\: program-line))) 31 'vector)))) 32 33 (declaim (inline combo-operand) 34 (ftype (function (fixnum (simple-array fixnum (3))) fixnum) combo-operand)) 35 36 (defun combo-operand (operand registers) 37 (if (<= operand 3) 38 operand 39 (if (<= operand 7) 40 (aref registers (- operand 4)) 41 (error "Invalid operand ~A for combo operator" operand)))) 42 43 (declaim (inline adv bxl bst bxc bdv cdv) 44 (ftype (function ((simple-array fixnum (3)) fixnum) null) adv bxl bst bxc bdv cdv)) 45 46 (defun adv (registers operand) 47 (setf (aref registers 0) 48 (floor (aref registers 0) 49 (the fixnum (expt 2 (the (integer 0 61) 50 (combo-operand operand registers)))))) 51 nil) 52 53 (defun bxl (registers operand) 54 (setf (aref registers 1) 55 (logxor (aref registers 1) 56 operand)) 57 nil) 58 59 (defun bst (registers operand) 60 (setf (aref registers 1) 61 (mod (combo-operand operand registers) 8)) 62 nil) 63 64 (defun bxc (registers operand) 65 (declare (ignore operand)) 66 (setf (aref registers 1) 67 (logxor (aref registers 1) 68 (aref registers 2))) 69 nil) 70 71 (defun bdv (registers operand) 72 (setf (aref registers 1) 73 (floor (aref registers 0) 74 (the fixnum (expt 2 (the (integer 0 61) 75 (combo-operand operand registers)))))) 76 nil) 77 78 (defun cdv (registers operand) 79 (setf (aref registers 2) 80 (floor (aref registers 0) 81 (the fixnum (expt 2 (the (integer 0 61) 82 (combo-operand operand registers)))))) 83 nil) 84 85 (defun make-jump (jump-tags registers op) 86 `(when (not (zerop (aref ,registers 0))) 87 (go ,(aref jump-tags op)))) 88 89 (defun make-output (output registers op) 90 `(push (mod (combo-operand ,op ,registers) 8) ,output)) 91 92 (defun compile-program (program) 93 (let* ((registers (gensym "REGISTERS")) 94 (jump-tags (coerce 95 (loop repeat (/ (length program) 2) 96 for i from 0 97 collect (gensym (format nil "INST-~A" i))) 98 'vector)) 99 (output (gensym "OUTPUT")) 100 (code (loop for i from 0 below (length program) by 2 101 for inst-id from 0 102 for inst = (aref program i) 103 for op = (aref program (1+ i)) 104 collect (aref jump-tags inst-id) 105 collect (case inst 106 (0 `(adv ,registers ,op)) 107 (1 `(bxl ,registers ,op)) 108 (2 `(bst ,registers ,op)) 109 (3 (make-jump jump-tags registers op)) 110 (4 `(bxc ,registers ,op)) 111 (5 (make-output output registers op)) 112 (6 `(bdv ,registers ,op)) 113 (7 `(cdv ,registers ,op)))))) 114 (compile nil 115 `(lambda (,registers) 116 (declare (optimize speed) 117 (type (simple-array fixnum (3)) ,registers)) 118 (let ((,output nil)) 119 (tagbody 120 ,@code) 121 ,output))))) 122 123 (declaim (ftype (function ((simple-array fixnum (3)) simple-vector) list) interpret)) 124 125 (defun interpret (registers code) 126 (loop with output = nil 127 for ip from 0 below (length code) by 2 128 for instruction = (aref code ip) 129 for operand = (aref code (1+ ip)) 130 do (case instruction 131 (0 (setf (aref registers 0) 132 (floor (aref registers 0) 133 (expt 2 (combo-operand operand registers))))) 134 (1 (setf (aref registers 1) 135 (logxor (aref registers 1) 136 operand))) 137 (2 (setf (aref registers 1) 138 (mod (combo-operand operand registers) 8))) 139 (3 (when (not (zerop (aref registers 0))) 140 (setf ip (- operand 2)))) 141 (4 (setf (aref registers 1) 142 (logxor (aref registers 1) 143 (aref registers 2)))) 144 (5 (push (mod (combo-operand operand registers) 8) output)) 145 (6 (setf (aref registers 1) 146 (floor (aref registers 0) 147 (expt 2 (combo-operand operand registers))))) 148 (7 (setf (aref registers 2) 149 (floor (aref registers 0) 150 (expt 2 (combo-operand operand registers)))))) 151 finally (return output))) 152 153 (defun reset-registers (registers original-registers register-a) 154 (setf (aref registers 0) register-a 155 (aref registers 1) (aref original-registers 1) 156 (aref registers 2) (aref original-registers 2))) 157 158 (defun task-2 (registers program code) 159 (let ((original-registers (copy-seq registers))) 160 (labels ((%solve (register-a depth) 161 (loop for n from 0 below 8 162 for nra = (+ register-a n) 163 do (reset-registers registers original-registers nra) 164 (let* ((res (funcall program registers)) 165 (value (nth depth res))) 166 (when (= value (aref code (- (length code) 1 depth))) 167 (when (= depth (1- (length code))) 168 (return-from %solve nra)) 169 (let ((solved-register-a (%solve (* nra 8) (1+ depth)))) 170 (when solved-register-a 171 (return-from %solve solved-register-a)))))))) 172 (%solve 1 0)))) 173 174 (defun make-program (code) 175 (if *use-compiler* 176 (compile-program code) 177 (lambda (registers) 178 (interpret registers code)))) 179 180 (defun day-17 (input) 181 (multiple-value-bind (registers code) 182 (parse-input input) 183 (let ((program (make-program code))) 184 (values 185 (format nil "~{~A~^,~}" (nreverse (funcall program (copy-seq registers)))) 186 (task-2 registers program code)))))