commit - a757f2ccecb5b65c1c76e6099f2ae82a0d934f08
commit + 0372dbdec3d209ba51f73f4a8572505fed15b415
blob - 36f4d0d9cc3b26f7b345fd09053b10a3c62ff345
blob + 7e73376903a354528d09ed3b9a1abdcca5067893
--- src/day-17.lisp
+++ src/day-17.lisp
(defpackage #:aoc/day-17
(:use #:cl #:aoc/utils)
(:export
+ #:*use-compiler*
#:make-registers
- #:run-program
+ #:make-program
+ #:interpret
+ #:compile-program
#:day-17))
(in-package #:aoc/day-17)
+(defparameter *use-compiler* nil)
+
(defun parse-register (line)
(parse-integer line :start (1+ (position #\: line))))
(aref registers (- operand 4))
(error "Invalid operand ~A for combo operator" operand))))
-(defun run-program (registers program)
+(declaim (inline adv bxl bst bxc bdv cdv)
+ (ftype (function ((simple-array fixnum (3)) fixnum) null) adv bxl bst bxc bdv cdv))
+
+(defun adv (registers operand)
+ (setf (aref registers 0)
+ (floor (aref registers 0)
+ (the fixnum (expt 2 (the (integer 0 61)
+ (combo-operand operand registers))))))
+ nil)
+
+(defun bxl (registers operand)
+ (setf (aref registers 1)
+ (logxor (aref registers 1)
+ operand))
+ nil)
+
+(defun bst (registers operand)
+ (setf (aref registers 1)
+ (mod (combo-operand operand registers) 8))
+ nil)
+
+(defun bxc (registers operand)
+ (declare (ignore operand))
+ (setf (aref registers 1)
+ (logxor (aref registers 1)
+ (aref registers 2)))
+ nil)
+
+(defun bdv (registers operand)
+ (setf (aref registers 1)
+ (floor (aref registers 0)
+ (the fixnum (expt 2 (the (integer 0 61)
+ (combo-operand operand registers))))))
+ nil)
+
+(defun cdv (registers operand)
+ (setf (aref registers 2)
+ (floor (aref registers 0)
+ (the fixnum (expt 2 (the (integer 0 61)
+ (combo-operand operand registers))))))
+ nil)
+
+(defun make-jump (jump-tags registers op)
+ `(when (not (zerop (aref ,registers 0)))
+ (go ,(aref jump-tags op))))
+
+(defun make-output (output registers op)
+ `(push (mod (combo-operand ,op ,registers) 8) ,output))
+
+(defun compile-program (program)
+ (let* ((registers (gensym "REGISTERS"))
+ (jump-tags (coerce
+ (loop repeat (/ (length program) 2)
+ for i from 0
+ collect (gensym (format nil "INST-~A" i)))
+ 'vector))
+ (output (gensym "OUTPUT"))
+ (code (loop for i from 0 below (length program) by 2
+ for inst-id from 0
+ for inst = (aref program i)
+ for op = (aref program (1+ i))
+ collect (aref jump-tags inst-id)
+ collect (case inst
+ (0 `(adv ,registers ,op))
+ (1 `(bxl ,registers ,op))
+ (2 `(bst ,registers ,op))
+ (3 (make-jump jump-tags registers op))
+ (4 `(bxc ,registers ,op))
+ (5 (make-output output registers op))
+ (6 `(bdv ,registers ,op))
+ (7 `(cdv ,registers ,op))))))
+ (compile nil
+ `(lambda (,registers)
+ (declare (optimize speed)
+ (type (simple-array fixnum (3)) ,registers))
+ (let ((,output nil))
+ (tagbody
+ ,@code)
+ ,output)))))
+
+(declaim (ftype (function ((simple-array fixnum (3)) simple-vector) list) interpret))
+
+(defun interpret (registers code)
(loop with output = nil
- for ip from 0 below (length program) by 2
- for instruction = (aref program ip)
- for operand = (aref program (1+ ip))
+ for ip from 0 below (length code) by 2
+ for instruction = (aref code ip)
+ for operand = (aref code (1+ ip))
do (case instruction
(0 (setf (aref registers 0)
(floor (aref registers 0)
(aref registers 1) (aref original-registers 1)
(aref registers 2) (aref original-registers 2)))
-(defun task-2 (registers code)
+(defun task-2 (registers program code)
(let ((original-registers (copy-seq registers)))
(labels ((%solve (register-a depth)
(loop for n from 0 below 8
for nra = (+ register-a n)
do (reset-registers registers original-registers nra)
- (let* ((res (run-program registers code))
+ (let* ((res (funcall program registers))
(value (nth depth res)))
(when (= value (aref code (- (length code) 1 depth)))
(when (= depth (1- (length code)))
(return-from %solve solved-register-a))))))))
(%solve 1 0))))
+(defun make-program (code)
+ (if *use-compiler*
+ (compile-program code)
+ (lambda (registers)
+ (interpret registers code))))
+
(defun day-17 (input)
(multiple-value-bind (registers code)
(parse-input input)
- (values
- (format nil "~{~A~^,~}" (nreverse (run-program (copy-seq registers) code)))
- (task-2 registers code))))
+ (let ((program (make-program code)))
+ (values
+ (format nil "~{~A~^,~}" (nreverse (funcall program (copy-seq registers))))
+ (task-2 registers program code)))))
blob - 52665687fc58e4471b012f298f9155f03148cad2
blob + 54d9eae63d17f5c7b0d1a0099ad4d41632fe8b09
--- t/day-17.lisp
+++ t/day-17.lisp
(:use #:cl #:lisp-unit2 #:aoc/day-17))
(in-package #:aoc-test/day-17)
-(define-test test-day-17
- ()
+(defun day-17-tests ()
(let ((registers (make-registers 0 0 9))
- (program (vector 2 6)))
- (aoc/day-17:run-program registers program)
+ (program (make-program (vector 2 6))))
+ (funcall program registers)
(assert= 1 (aref registers 1)))
(let ((registers (make-registers 10 0 0))
- (program (vector 5 0 5 1 5 4)))
+ (program (make-program (vector 5 0 5 1 5 4))))
(assert-equal (list 0 1 2)
- (nreverse (run-program registers program))))
+ (nreverse (funcall program registers))))
(let ((registers (make-registers 2024 0 0))
- (program (vector 0 1 5 4 3 0)))
+ (program (make-program (vector 0 1 5 4 3 0))))
(assert-equal (list 4 2 5 6 7 7 7 7 3 1 0)
- (nreverse (run-program registers program)))
+ (nreverse (funcall program registers)))
(assert= 0 (aref registers 0)))
(let ((registers (make-registers 0 29 0))
- (program (vector 1 7)))
- (run-program registers program)
+ (program (make-program (vector 1 7))))
+ (funcall program registers)
(assert= 26 (aref registers 1)))
(let ((registers (make-registers 0 2024 43690))
- (program (vector 4 0)))
- (run-program registers program)
+ (program (make-program (vector 4 0))))
+ (funcall program registers)
(assert= 44354 (aref registers 1)))
(let ((registers (make-registers 729))
- (program (vector 0 1 5 4 3 0)))
+ (program (make-program (vector 0 1 5 4 3 0))))
(assert-equal (list 4 6 3 5 6 3 5 2 1 0)
- (nreverse (run-program registers program)))))
+ (nreverse (funcall program registers)))))
+
+(define-test test-day-17
+ ()
+ (day-17-tests)
+ (let ((*use-compiler* t))
+ (day-17-tests)))
