ebd2a1bb4889
Add a few more days
| author | Steve Losh <steve@stevelosh.com> |
|---|---|
| date | Wed, 11 Dec 2019 18:48:20 -0500 |
| parents | d692b61fbee1 |
| children | af91bed748cd f4f8705ccf34 |
| branches/tags | (none) |
| files | data/2019/09.txt data/2019/10.txt data/2019/11.txt package.lisp src/2016/days/day-05.lisp src/2018/days/day-10.lisp src/2019/days/day-03.lisp src/2019/days/day-08.lisp src/2019/days/day-09.lisp src/2019/days/day-10.lisp src/2019/days/day-11.lisp src/2019/intcode.lisp src/utils.lisp vendor/make-quickutils.lisp vendor/quickutils.lisp |
Changes
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/data/2019/09.txt Wed Dec 11 18:48:20 2019 -0500 @@ -0,0 +1,1 @@ +1102,34463338,34463338,63,1007,63,34463338,63,1005,63,53,1101,3,0,1000,109,988,209,12,9,1000,209,6,209,3,203,0,1008,1000,1,63,1005,63,65,1008,1000,2,63,1005,63,904,1008,1000,0,63,1005,63,58,4,25,104,0,99,4,0,104,0,99,4,17,104,0,99,0,0,1102,35,1,1010,1102,1,33,1013,1101,0,715,1022,1102,1,20,1004,1102,1,24,1012,1101,36,0,1005,1101,0,655,1024,1102,32,1,1014,1101,0,499,1026,1102,1,242,1029,1101,0,25,1002,1101,0,27,1017,1101,708,0,1023,1101,0,21,1016,1101,0,28,1000,1101,0,492,1027,1102,34,1,1015,1102,29,1,1007,1102,247,1,1028,1101,0,39,1011,1102,1,31,1018,1102,1,0,1020,1102,1,37,1006,1101,1,0,1021,1102,26,1,1009,1102,1,38,1008,1101,30,0,1019,1102,1,23,1001,1102,650,1,1025,1101,22,0,1003,109,7,2101,0,-7,63,1008,63,29,63,1005,63,205,1001,64,1,64,1105,1,207,4,187,1002,64,2,64,109,-1,1202,-1,1,63,1008,63,35,63,1005,63,227,1106,0,233,4,213,1001,64,1,64,1002,64,2,64,109,17,2106,0,5,4,239,1105,1,251,1001,64,1,64,1002,64,2,64,109,-1,21108,40,39,-4,1005,1018,271,1001,64,1,64,1106,0,273,4,257,1002,64,2,64,109,-9,1206,8,285,1106,0,291,4,279,1001,64,1,64,1002,64,2,64,109,-13,2108,27,0,63,1005,63,307,1106,0,313,4,297,1001,64,1,64,1002,64,2,64,109,11,2101,0,-5,63,1008,63,37,63,1005,63,339,4,319,1001,64,1,64,1105,1,339,1002,64,2,64,109,13,21101,41,0,-9,1008,1015,41,63,1005,63,365,4,345,1001,64,1,64,1106,0,365,1002,64,2,64,109,-14,1201,-6,0,63,1008,63,22,63,1005,63,385,1106,0,391,4,371,1001,64,1,64,1002,64,2,64,109,-10,1202,3,1,63,1008,63,22,63,1005,63,417,4,397,1001,64,1,64,1105,1,417,1002,64,2,64,109,6,1207,-3,21,63,1005,63,437,1001,64,1,64,1105,1,439,4,423,1002,64,2,64,109,16,21107,42,41,-8,1005,1014,455,1105,1,461,4,445,1001,64,1,64,1002,64,2,64,109,-28,2107,24,7,63,1005,63,481,1001,64,1,64,1106,0,483,4,467,1002,64,2,64,109,33,2106,0,0,1001,64,1,64,1106,0,501,4,489,1002,64,2,64,109,-18,2108,38,-1,63,1005,63,519,4,507,1105,1,523,1001,64,1,64,1002,64,2,64,109,-3,1208,-4,25,63,1005,63,545,4,529,1001,64,1,64,1106,0,545,1002,64,2,64,109,12,21102,43,1,-8,1008,1010,43,63,1005,63,571,4,551,1001,64,1,64,1106,0,571,1002,64,2,64,109,-1,1207,-8,27,63,1005,63,593,4,577,1001,64,1,64,1106,0,593,1002,64,2,64,109,-7,21101,44,0,8,1008,1018,42,63,1005,63,617,1001,64,1,64,1105,1,619,4,599,1002,64,2,64,109,-4,1208,-1,39,63,1005,63,639,1001,64,1,64,1105,1,641,4,625,1002,64,2,64,109,13,2105,1,5,4,647,1106,0,659,1001,64,1,64,1002,64,2,64,109,4,1206,-3,673,4,665,1106,0,677,1001,64,1,64,1002,64,2,64,109,-22,21108,45,45,10,1005,1011,699,4,683,1001,64,1,64,1105,1,699,1002,64,2,64,109,29,2105,1,-7,1001,64,1,64,1105,1,717,4,705,1002,64,2,64,109,-19,21107,46,47,5,1005,1016,739,4,723,1001,64,1,64,1106,0,739,1002,64,2,64,109,-8,2102,1,2,63,1008,63,33,63,1005,63,763,1001,64,1,64,1106,0,765,4,745,1002,64,2,64,109,1,1201,-2,0,63,1008,63,25,63,1005,63,791,4,771,1001,64,1,64,1105,1,791,1002,64,2,64,109,16,1205,0,803,1105,1,809,4,797,1001,64,1,64,1002,64,2,64,109,-8,1205,9,827,4,815,1001,64,1,64,1106,0,827,1002,64,2,64,109,-4,2102,1,-3,63,1008,63,36,63,1005,63,853,4,833,1001,64,1,64,1106,0,853,1002,64,2,64,109,17,21102,47,1,-6,1008,1019,50,63,1005,63,877,1001,64,1,64,1105,1,879,4,859,1002,64,2,64,109,-29,2107,22,5,63,1005,63,897,4,885,1106,0,901,1001,64,1,64,4,64,99,21102,27,1,1,21101,0,915,0,1106,0,922,21201,1,25338,1,204,1,99,109,3,1207,-2,3,63,1005,63,964,21201,-2,-1,1,21101,942,0,0,1105,1,922,22102,1,1,-1,21201,-2,-3,1,21102,957,1,0,1106,0,922,22201,1,-1,-2,1105,1,968,21202,-2,1,-2,109,-3,2106,0,0
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/data/2019/10.txt Wed Dec 11 18:48:20 2019 -0500 @@ -0,0 +1,26 @@ +##.#..#..###.####...###### +#..#####...###.###..#.###. +..#.#####....####.#.#...## +.##..#.#....##..##.#.#.... +#.####...#.###..#.##.#..#. +..#..#.#######.####...#.## +#...####.#...#.#####..#.#. +.#..#.##.#....########..## +......##.####.#.##....#### +.##.#....#####.####.#.#### +..#.#.#.#....#....##.#.... +....#######..#.##.#.##.### +###.#######.#..#########.. +###.#.#..#....#..#.##..##. +#####.#..#.#..###.#.##.### +.#####.#####....#..###...# +##.#.......###.##.#.##.... +...#.#.#.###.#.#..##..#### +#....#####.##.###...####.# +#.##.#.######.##..#####.## +#.###.##..##.##.#.###..### +#.####..######...#...##### +#..#..########.#.#...#..## +.##..#.####....#..#..#.... +.###.##..#####...###.#.#.# +.##..######...###..#####.#
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/data/2019/11.txt Wed Dec 11 18:48:20 2019 -0500 @@ -0,0 +1,1 @@ +3,8,1005,8,298,1106,0,11,0,0,0,104,1,104,0,3,8,1002,8,-1,10,1001,10,1,10,4,10,108,1,8,10,4,10,101,0,8,28,3,8,102,-1,8,10,1001,10,1,10,4,10,1008,8,1,10,4,10,1002,8,1,51,1006,0,37,1006,0,65,1,4,9,10,3,8,1002,8,-1,10,101,1,10,10,4,10,1008,8,0,10,4,10,102,1,8,83,2,3,9,10,1006,0,39,1,1,0,10,1,104,11,10,3,8,102,-1,8,10,1001,10,1,10,4,10,1008,8,0,10,4,10,1002,8,1,120,2,104,13,10,1,1007,18,10,1006,0,19,1,107,2,10,3,8,102,-1,8,10,101,1,10,10,4,10,1008,8,0,10,4,10,1001,8,0,157,3,8,1002,8,-1,10,1001,10,1,10,4,10,1008,8,0,10,4,10,1001,8,0,179,2,108,16,10,2,1108,14,10,1006,0,70,3,8,102,-1,8,10,1001,10,1,10,4,10,108,1,8,10,4,10,101,0,8,211,3,8,1002,8,-1,10,1001,10,1,10,4,10,1008,8,1,10,4,10,101,0,8,234,3,8,102,-1,8,10,1001,10,1,10,4,10,1008,8,0,10,4,10,102,1,8,256,3,8,1002,8,-1,10,101,1,10,10,4,10,1008,8,1,10,4,10,1002,8,1,278,101,1,9,9,1007,9,957,10,1005,10,15,99,109,620,104,0,104,1,21101,387508441896,0,1,21101,0,315,0,1105,1,419,21101,666412880532,0,1,21102,1,326,0,1106,0,419,3,10,104,0,104,1,3,10,104,0,104,0,3,10,104,0,104,1,3,10,104,0,104,1,3,10,104,0,104,0,3,10,104,0,104,1,21101,106341436456,0,1,21101,373,0,0,1106,0,419,21101,46211886299,0,1,21101,384,0,0,1106,0,419,3,10,104,0,104,0,3,10,104,0,104,0,21101,0,838433923860,1,21102,1,407,0,1105,1,419,21102,1,988224946540,1,21102,1,418,0,1106,0,419,99,109,2,21201,-1,0,1,21101,40,0,2,21102,1,450,3,21101,440,0,0,1105,1,483,109,-2,2106,0,0,0,1,0,0,1,109,2,3,10,204,-1,1001,445,446,461,4,0,1001,445,1,445,108,4,445,10,1006,10,477,1101,0,0,445,109,-2,2105,1,0,0,109,4,1201,-1,0,482,1207,-3,0,10,1006,10,500,21101,0,0,-3,21201,-3,0,1,21202,-2,1,2,21101,1,0,3,21102,1,519,0,1105,1,524,109,-4,2106,0,0,109,5,1207,-3,1,10,1006,10,547,2207,-4,-2,10,1006,10,547,22102,1,-4,-4,1106,0,615,21202,-4,1,1,21201,-3,-1,2,21202,-2,2,3,21102,1,566,0,1105,1,524,21201,1,0,-4,21101,0,1,-1,2207,-4,-2,10,1006,10,585,21101,0,0,-1,22202,-2,-1,-2,2107,0,-3,10,1006,10,607,22101,0,-1,1,21102,1,607,0,105,1,482,21202,-2,-1,-2,22201,-4,-2,-4,109,-5,2105,1,0
--- a/package.lisp Sun Dec 08 14:50:54 2019 -0500 +++ b/package.lisp Wed Dec 11 18:48:20 2019 -0500 @@ -10,6 +10,7 @@ :read-numbers :read-numbers-from-string :read-comma-separated-values + :read-2d-array :ensure-string :ensure-stream @@ -37,6 +38,8 @@ :let-result :let-complex :queue-thunk + :bounds + :draw-bitmap :bytes->hex :bytes->integer
--- a/src/2016/days/day-05.lisp Sun Dec 08 14:50:54 2019 -0500 +++ b/src/2016/days/day-05.lisp Wed Dec 11 18:48:20 2019 -0500 @@ -26,17 +26,13 @@ (with part2 = (make-string 8 :initial-element #\_)) (returning part1 part2) - ;; Instead create a fresh string of the entire ID every time, we keep - ;; a buffer and just replace the numeric portion on each iteration. - (with n = (length data)) - (with buffer = (make-array 1024 :fill-pointer n :element-type '(unsigned-byte 8))) - (initially (replace buffer (string->bytes data))) + (for i :from 0) - (for i :from 0) - (for id = (string->bytes (princ-to-string i))) - (setf (fill-pointer buffer) (+ n (length id))) - (replace buffer id :start1 n) - (for hash = (md5:md5sum-sequence buffer)) + ;; Instead create a fresh string of the entire ID every time, we could keep + ;; a buffer and just replace the numeric portion on each iteration. + ;; Unfortunately CCL's MD5 implementation wants a simple-array, not one with + ;; a fill pointer. Welp. + (for hash = (md5:md5sum-string (format nil "~A~D" data i))) (when (dividesp i 100000) (progress i))
--- a/src/2018/days/day-10.lisp Sun Dec 08 14:50:54 2019 -0500 +++ b/src/2018/days/day-10.lisp Wed Dec 11 18:48:20 2019 -0500 @@ -1,5 +1,5 @@ (defpackage :advent/2018/10 #.cl-user::*advent-use* - (:shadow :x :y)) + (:shadow :x :y :bounds)) (in-package :advent/2018/10) (defun parse-line (line)
--- a/src/2019/days/day-03.lisp Sun Dec 08 14:50:54 2019 -0500 +++ b/src/2019/days/day-03.lisp Wed Dec 11 18:48:20 2019 -0500 @@ -1,18 +1,9 @@ (defpackage :advent/2019/03 #.cl-user::*advent-use*) (in-package :advent/2019/03) -(defun bounds (grid) - (multiple-value-bind (bottom top) - (losh:extrema #'< (alexandria:hash-table-keys grid) :key #'y) - (multiple-value-bind (left right) - (losh:extrema #'< (alexandria:hash-table-keys grid) :key #'x) - (values (x left) - (x right) - (y top) - (y bottom))))) - (defun print-grid (grid) - (multiple-value-bind (left right top bottom) (bounds grid) + (multiple-value-bind (left right bottom top) + (bounds (alexandria:hash-table-keys grid)) (iterate (for y :from (1+ top) :downto (1- bottom)) (iterate
--- a/src/2019/days/day-08.lisp Sun Dec 08 14:50:54 2019 -0500 +++ b/src/2019/days/day-08.lisp Wed Dec 11 18:48:20 2019 -0500 @@ -23,18 +23,15 @@ (#\0 0))))) (defun decode-image (layers) - (destructuring-bind (height width) (array-dimensions (first layers)) - (let-result (image (make-array (list width height))) + (gathering + (destructuring-bind (height width) (array-dimensions (first layers)) (do-range ((y 0 height) (x 0 width)) - (setf (aref image x y) - (pixel-color layers y x)))))) + (gather (cons (complex x y) (pixel-color layers y x))))))) (define-problem (2019 8) (stream) (1806) (let ((image (read-image stream 25 6))) - (netpbm:write-to-file "out/2019-08.pbm" (decode-image image) - :if-exists :supersede - :format :pbm) + (draw-bitmap (decode-image image) "out/2019-08.pbm") (iterate (for layer :in image) (finding (* (count-digit layer #\1)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/2019/days/day-09.lisp Wed Dec 11 18:48:20 2019 -0500 @@ -0,0 +1,25 @@ +(defpackage :advent/2019/09 #.cl-user::*advent-use*) +(in-package :advent/2019/09) + +(define-problem (2019 9) (data read-numbers) (2955820355 46643) + (values + (first (gathering + (advent/intcode:run data + :input (constantly 1) + :output #'gather))) + (first (gathering + (advent/intcode:run data + :input (constantly 2) + :output #'gather))))) + + +#; Scratch -------------------------------------------------------------------- + +(let ((advent/intcode:*trace* nil)) + (run '(109 1 204 -1 1001 100 1 100 1008 100 16 101 1006 101 0 99))) + +(let ((advent/intcode:*trace* nil)) + (run '(1102 34915192 34915192 7 4 7 99 0))) + +(let ((advent/intcode:*trace* t)) + (run '(104 1125899906842624 99)))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/2019/days/day-10.lisp Wed Dec 11 18:48:20 2019 -0500 @@ -0,0 +1,87 @@ +(defpackage :advent/2019/10 #.cl-user::*advent-use*) +(in-package :advent/2019/10) + +(defun asteroid-positions (map) + "Return a list of the asteroid positions in the 2D input `map`." + (destructuring-bind (rows cols) (array-dimensions map) + (iterate + (for-nested ((row :from 0 :below rows) + (col :from 0 :below cols))) + (when (char= #\# (aref map row col)) + ;; swap axes to match the problem text + (collect (complex col row)))))) + +(defun slope (v) + (let-complex (v) + (if (zerop vy) + nil + (/ vx vy)))) + +(defun slope= (a b) + (eql (slope a) + (slope b))) + +(defun sign= (a b) + (and (= (signum (x a)) (signum (x b))) + (= (signum (y a)) (signum (y b))))) + +(defun colinearp (origin a b) + (let ((va (- a origin)) + (vb (- b origin))) + (and (sign= va vb) + (slope= va vb)))) + +(defun group (asteroids origin) + (equivalence-classes (curry #'colinearp origin) + (remove origin asteroids))) + +(defun count-seen (asteroids pos) + (length (group asteroids pos))) + +(defun angle (a b) + (mod (- (atan (y a) (x a)) + (atan (y b) (x b))) + tau)) + +(defun distance (a b) + (abs (- a b))) + +(defun splice (list) + "Splice `list` into a circular list." + (setf (cdr (last list)) list)) + +(defun part1 (data) + (iterate + (with asteroids = (asteroid-positions data)) + (for pos :in asteroids) + (finding pos :maximizing (count-seen asteroids pos) :into (best score)) + (returning best score))) + +(defun part2 (data origin &optional (n 200)) + (flet ((group-angle (group) + (angle #c(0 -1) (- (first group) origin))) + (sort-group (group) + (sort group #'< :key (curry #'distance origin)))) + (iterate + (with groups = (_ data + asteroid-positions + (group _ origin) + (mapcar #'sort-group _) + (sort _ #'< :key #'group-angle) + (apply #'ring _))) + (repeat n) + (for pos = (pop (ring-data groups))) + (if (null (ring-data groups)) + ;; We go in the opposite direction than expected because the Y axis is + ;; annoyingly flipped in the problem. + (ring-cutf groups :prev t) + (ring-prevf groups)) + (returning pos)))) + +(define-problem (2019 10) (data read-2d-array) (284 404) + (multiple-value-bind (origin score) (part1 data) + (let ((lucky (part2 data origin))) + (values score (+ (* (x lucky) 100) (y lucky)))))) + + +#; Scratch --------------------------------------------------------------------
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/2019/days/day-11.lisp Wed Dec 11 18:48:20 2019 -0500 @@ -0,0 +1,41 @@ +(defpackage :advent/2019/11 #.cl-user::*advent-use*) +(in-package :advent/2019/11) + +(defun run-robot (program &key (origin 'black)) + (let ((panels (make-hash-table)) + (mode '#1=(paint walk . #1#)) + (pos #c(0 0)) + (heading #c(0 1))) + (labels ((color () + (gethash pos panels 0)) + (paint (color) + (setf (gethash pos panels) color)) + (turn (direction) + (mulf heading + (ecase direction + (0 #c(0 1)) + (1 #c(0 -1))))) + (walk (direction) + (turn direction) + (incf pos heading)) + (exec (input) + (ecase (pop mode) + (paint (paint input)) + (walk (walk input))))) + (paint (ecase origin + (black 0) + (white 1))) + (advent/intcode:run program :input #'color :output #'exec)) + panels)) + +(defun draw-panels (panels) + (draw-bitmap (alexandria:hash-table-alist panels) + "out/2019-11.pbm" + :flip-vertically t)) + +(define-problem (2019 11) (data read-numbers) (1907) + (draw-panels (run-robot data :origin 'white)) + (hash-table-count (run-robot data))) + + +#; Scratch --------------------------------------------------------------------
--- a/src/2019/intcode.lisp Sun Dec 08 14:50:54 2019 -0500 +++ b/src/2019/intcode.lisp Wed Dec 11 18:48:20 2019 -0500 @@ -1,20 +1,30 @@ (defpackage :advent/intcode #.cl-user::*advent-use* (:shadow :step :trace) - (:export :init :step :run :run-machine)) + (:export :init :step :run :run-machine :*trace*)) (in-package :advent/intcode) +(defparameter *trace* nil) (defparameter *trace-lock* (bt:make-lock "intcode trace lock")) + ;;;; Data Structures ---------------------------------------------------------- (defclass* machine () ((pc :type (integer 0) :initform 0) - (memory :type (vector integer)) + (rb :type (integer 0) :initform 0) + (memory :type hash-table) (input :type function) (output :type function))) -(define-with-macro machine pc memory input output) +(define-with-macro machine pc rb memory input output) + +(defun mref (machine address &optional (default 0)) + (gethash address (memory machine) default)) + +(defun (setf mref) (new-value machine address &optional (default 0)) + (setf (gethash address (memory machine) default) + new-value)) (defclass* operation () @@ -22,7 +32,7 @@ (name :type symbol) (size :type (integer 1)) (parameters :type list) - (perform :type function))) + (perform :type (or symbol function)))) (defun perform-operation (opcode parameter-modes machine) (funcall (perform (gethash opcode *operations*)) @@ -30,12 +40,7 @@ ;;;; Opcode Definition -------------------------------------------------------- -(defun retrieve (machine parameter-mode operand) - (ecase parameter-mode - (0 (aref (memory machine) operand)) - (1 operand))) - -(defmacro define-opcode ((opcode name) parameters &body body) +(defun retrieve (machine parameter-mode operand &key out) ;; Note that (confusingly) output parameters don't use the same addressing ;; scheme as input parameters. For example: in the instruction 00002,1,2,99 ;; all the parameter modes are 0, which means "look up the value at address @@ -45,6 +50,16 @@ ;; 1 (immediate mode). So we need to handle output parameters specially. ;; ;; Sigh. + (ecase parameter-mode + (0 (if out ; position + operand + (mref machine operand))) + (1 operand) ; immediate + (2 (if out ; relative + (+ (rb machine) operand) + (mref machine (+ (rb machine) operand)))))) + +(defmacro define-opcode ((opcode name) parameters &body body) (setf parameters (mapcar (lambda (param) (if (symbolp param) `(,param in) @@ -66,15 +81,16 @@ (for (param kind) :in parameters) (for offset :from 0) (collect - (ecase kind - (in `(,param (retrieve ,machine - (pop-mode) - (aref memory (+ pc ,offset))))) - (out `(,param (progn - (pop-mode) - (aref memory (+ pc ,offset))))))))) + `(,param (retrieve ,machine + (pop-mode) + (mref ,machine (+ pc ,offset)) + :out ,(ecase kind + (in nil) + (out t))))))) (incf pc ,(length parameters)) - ,@body)))) + (macrolet ((mem (addr) + `(mref ,',machine ,addr))) + ,@body))))) (setf (gethash ,opcode *operations*) (make-instance 'operation :opcode ,opcode @@ -92,13 +108,13 @@ :halt) (define-opcode (1 ADD) (x y (dest out)) - (setf (aref memory dest) (+ x y))) + (setf (mem dest) (+ x y))) (define-opcode (2 MUL) (x y (dest out)) - (setf (aref memory dest) (* x y))) + (setf (mem dest) (* x y))) (define-opcode (3 INP) ((dest out)) - (setf (aref memory dest) (funcall input))) + (setf (mem dest) (funcall input))) (define-opcode (4 OUT) (val) (funcall output val)) @@ -112,83 +128,105 @@ (setf pc addr))) (define-opcode (7 LES) (x y (dest out)) - (setf (aref memory dest) + (setf (mem dest) (if (< x y) 1 0))) (define-opcode (8 EQL) (x y (dest out)) - (setf (aref memory dest) + (setf (mem dest) (if (= x y) 1 0))) +(define-opcode (9 ARB) (val) + (incf rb val)) + ;;;; Disassembly -------------------------------------------------------------- (defun parse-op (n) (multiple-value-bind (parameter-modes opcode) (truncate n 100) (values opcode parameter-modes))) -(defun disassemble-operation (program address) +(defun disassemble-operation (machine address) (multiple-value-bind (opcode parameter-modes) - (parse-op (aref program address)) + (parse-op (mref machine address)) (let ((op (gethash opcode *operations*))) (if op (values `(,(name op) ,@(iterate (for (param kind) :in (parameters op)) - (for value :in-vector program :from (1+ address)) + (for addr :from (1+ address)) + (for value = (mref machine addr)) (for mode = (mod parameter-modes 10)) (collect `(,param ,(ecase kind (in (ecase mode (0 (vector value)) - (1 value))) - (out value)))) + (1 value) + (2 (list :r value)))) + (out (ecase mode + ((0 1) value) + (2 (list :r value))))))) (setf parameter-modes (truncate parameter-modes 10)))) (size op)) - (values `(data ,(aref program address)) 1))))) + (values `(data ,(mref machine address)) 1))))) -(defun disassemble-program (program &key (start 0) (limit nil)) +(defun disassemble-program (machine &key (start 0) (limit nil)) (iterate (when limit (if (zerop limit) (return) (decf limit))) (with address = start) - (with bound = (length program)) - (while (< address bound)) - (for (values instruction size) = (disassemble-operation program address)) + (with addresses = (-<> (memory machine) + alexandria:hash-table-keys + (sort <> #'<))) + (with bound = (1+ (elt addresses (1- (length addresses))))) + (flet ((advance (addr) + (iterate + (until (null addresses)) + (while (> addr (first addresses))) + (pop addresses)))) + (advance address)) + (while addresses) + (for (values instruction size) = (disassemble-operation machine address)) (for end = (+ address size)) (when (> end bound) ; hack to handle trailing data that looks instructionish - (setf instruction `(data ,(aref program address)) + (setf instruction `(data ,(mref machine address)) size 1 end (1+ address))) - (for bytes = (coerce (subseq program address end) 'list)) - (format t "~4D | ~{~5D~^ ~} ~36T| ~{~A~^ ~}~%" address bytes instruction) + (for bytes = (iterate (for i :from address :below end) + (collect (mref machine i)))) + (format t "~4D | ~4D | ~{~5D~^ ~} ~42T| ~{~A~^ ~}~%" address (rb machine) bytes instruction) (incf address size))) ;;;; Running ------------------------------------------------------------------ +(defun program->hash-table (program &key (test #'eql)) + (iterate (for x :in-whatever program) + (for i :from 0) + (collect-hash (i x) :test test))) + (defun init (program &key input output) (make-instance 'machine - :memory (fresh-vector program) + :memory (program->hash-table program) :input (or input #'read) :output (or output #'print))) -(defun step (machine &key trace) +(defun step (machine &key (trace *trace*)) (with-machine (machine) (when trace (bt:with-lock-held (*trace-lock*) - (when (numberp trace) - (format t "~D: " trace)) - (disassemble-program (memory machine) :start pc :limit 1))) - (multiple-value-bind (opcode parameter-modes) (parse-op (aref memory pc)) + (unless (member trace '(t nil)) + (format t "~A: " trace)) + (disassemble-program machine :start pc :limit 1))) + (multiple-value-bind (opcode parameter-modes) (parse-op (mref machine pc)) (incf pc) (perform-operation opcode parameter-modes machine)))) -(defun run-machine (machine &key trace) +(defun run-machine (machine &key (trace *trace*)) (iterate (case (step machine :trace trace) - (:halt (return (aref (memory machine) 0)))))) + (:halt (return (mref machine 0)))))) -(defun run (program &key input output trace) +(defun run (program &key input output (trace *trace*)) (run-machine (init program :input input :output output) :trace trace)) ;; #; Scratch --------------------------------------------------------------------
--- a/src/utils.lisp Sun Dec 08 14:50:54 2019 -0500 +++ b/src/utils.lisp Wed Dec 11 18:48:20 2019 -0500 @@ -114,6 +114,18 @@ (defun read-comma-separated-values (stream) (str:split #\, (alexandria:read-stream-content-into-string stream))) +(defun read-2d-array (stream) + (iterate + (with lines = (read-lines stream)) + (with result = (make-array (list (length lines) (length (first lines))))) + (for row :from 0) + (for line :in lines) + (iterate + (for col :from 0) + (for char :in-string line) + (setf (aref result row col) char)) + (returning result))) + ;;;; Rings -------------------------------------------------------------------- (declaim (inline ring-prev ring-next ring-data)) @@ -466,11 +478,18 @@ ,symbol)) (defmacro let-complex (bindings &body body) - `(let* (,@(iterate (for (x y val) :in bindings) - (for v = (gensym)) - (collect `(,v ,val)) - (collect `(,x (realpart ,v))) - (collect `(,y (imagpart ,v))))) + `(let* (,@(iterate + (for binding :in bindings) + (for (x y val) = (etypecase binding + (symbol (list + (alexandria:symbolicate binding 'x) + (alexandria:symbolicate binding 'y) + binding)) + (cons binding))) + (for v = (gensym)) + (collect `(,v ,val)) + (collect `(,x (realpart ,v))) + (collect `(,y (imagpart ,v))))) ,@body)) @@ -488,6 +507,44 @@ (returning result))) +(defun bounds (coords) + "Return the left, right, bottom, and top bounds of `coords`." + (multiple-value-bind (bottom top) (losh:extrema #'< coords :key #'y) + (multiple-value-bind (left right) (losh:extrema #'< coords :key #'x) + (values (x left) + (x right) + (y bottom) + (y top))))) + + +(defun flip-vertically (image-array) + (destructuring-bind (width height) (array-dimensions image-array) + (dotimes (y (truncate height 2)) + (dotimes (x width) + (rotatef (aref image-array x y) + (aref image-array x (- height y 1))))))) + +(defun draw-bitmap (pixels path &key flip-vertically) + "Draw `pixels` to `path`. + + `pixels` must be a sequence of `(position . color)` conses. + + " + (multiple-value-bind (left right bottom top) (bounds (mapcar #'car pixels)) + (let ((origin (complex left bottom)) + (image (make-array (list (1+ (- right left)) + (1+ (- top bottom))) + :initial-element 0))) + (iterate + (for (pos . color) :in-whatever pixels) + (for pixel = (- pos origin)) + (setf (aref image (x pixel) (y pixel)) color)) + (when flip-vertically + (flip-vertically image)) + (netpbm:write-to-file path image + :if-exists :supersede + :format :pbm)))) + ;;;; A* Search ---------------------------------------------------------------- (defstruct path state
--- a/vendor/make-quickutils.lisp Sun Dec 08 14:50:54 2019 -0500 +++ b/vendor/make-quickutils.lisp Wed Dec 11 18:48:20 2019 -0500 @@ -10,6 +10,7 @@ :deletef :ensure-gethash :extremum + :equivalence-classes :flatten-once :hash-table-keys :hash-table-values
--- a/vendor/quickutils.lisp Sun Dec 08 14:50:54 2019 -0500 +++ b/vendor/quickutils.lisp Wed Dec 11 18:48:20 2019 -0500 @@ -2,7 +2,7 @@ ;;;; See http://quickutil.org for details. ;;;; To regenerate: -;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:COMPOSE :COPY-HASH-TABLE :CURRY :DELETEF :ENSURE-GETHASH :EXTREMUM :FLATTEN-ONCE :HASH-TABLE-KEYS :HASH-TABLE-VALUES :ONCE-ONLY :RCURRY :READ-FILE-INTO-STRING :REMOVEF :SYMB :WITH-GENSYMS) :ensure-package T :package "ADVENT.QUICKUTILS") +;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:COMPOSE :COPY-HASH-TABLE :CURRY :DELETEF :ENSURE-GETHASH :EXTREMUM :EQUIVALENCE-CLASSES :FLATTEN-ONCE :HASH-TABLE-KEYS :HASH-TABLE-VALUES :ONCE-ONLY :RCURRY :READ-FILE-INTO-STRING :REMOVEF :SYMB :WITH-GENSYMS) :ensure-package T :package "ADVENT.QUICKUTILS") (eval-when (:compile-toplevel :load-toplevel :execute) (unless (find-package "ADVENT.QUICKUTILS") @@ -13,15 +13,13 @@ (in-package "ADVENT.QUICKUTILS") (when (boundp '*utilities*) - (setf *utilities* (union *utilities* '(:MAKE-GENSYM-LIST :ENSURE-FUNCTION - :COMPOSE :COPY-HASH-TABLE :CURRY - :DELETEF :ENSURE-GETHASH :EXTREMUM - :FLATTEN-ONCE :MAPHASH-KEYS - :HASH-TABLE-KEYS :MAPHASH-VALUES - :HASH-TABLE-VALUES :ONCE-ONLY :RCURRY - :WITH-OPEN-FILE* :WITH-INPUT-FROM-FILE - :READ-FILE-INTO-STRING :REMOVEF :MKSTR - :SYMB :STRING-DESIGNATOR :WITH-GENSYMS)))) + (setf *utilities* (union *utilities* '(:MAKE-GENSYM-LIST :ENSURE-FUNCTION :COMPOSE + :COPY-HASH-TABLE :CURRY :DELETEF :ENSURE-GETHASH :EXTREMUM + :EQUIVALENCE-CLASSES :FLATTEN-ONCE :MAPHASH-KEYS + :HASH-TABLE-KEYS :MAPHASH-VALUES :HASH-TABLE-VALUES + :ONCE-ONLY :RCURRY :WITH-OPEN-FILE* :WITH-INPUT-FROM-FILE + :READ-FILE-INTO-STRING :REMOVEF :MKSTR :SYMB + :STRING-DESIGNATOR :WITH-GENSYMS)))) (eval-when (:compile-toplevel :load-toplevel :execute) (defun make-gensym-list (length &optional (x "G")) "Returns a list of `length` gensyms, each generated as if with a call to `make-gensym`, @@ -182,6 +180,32 @@ :end end))))) + (defun equivalence-classes (equiv seq) + "Partition the sequence `seq` into a list of equivalence classes +defined by the equivalence relation `equiv`." + (let ((classes nil)) + (labels ((find-equivalence-class (x) + (member-if (lambda (class) + (funcall equiv x (car class))) + classes)) + + (add-to-class (x) + (let ((class (find-equivalence-class x))) + (if class + (push x (car class)) + (push (list x) classes))))) + (declare (dynamic-extent (function find-equivalence-class) + (function add-to-class)) + (inline find-equivalence-class + add-to-class)) + + ;; Partition into equivalence classes. + (map nil #'add-to-class seq) + + ;; Return the classes. + classes))) + + (defun flatten-once (list) "Flatten `list` once." (loop :for x :in list @@ -399,8 +423,8 @@ `(with-gensyms ,names ,@forms)) (eval-when (:compile-toplevel :load-toplevel :execute) - (export '(compose copy-hash-table curry deletef ensure-gethash extremum - flatten-once hash-table-keys hash-table-values once-only rcurry - read-file-into-string removef symb with-gensyms with-unique-names))) + (export '(compose copy-hash-table curry deletef ensure-gethash extremum equivalence-classes + flatten-once hash-table-keys hash-table-values once-only rcurry read-file-into-string + removef symb with-gensyms with-unique-names))) ;;;; END OF quickutils.lisp ;;;;