| author |
Steve Losh <steve@stevelosh.com> |
| date |
Fri, 13 Dec 2019 13:51:53 -0500 |
| parents |
32db20d16280 |
| children |
03d0cc3a648f |
(in-package :advent)
;;;; Clipboard ----------------------------------------------------------------
(defun sh (command &key (input "") output)
(uiop:run-program command
:output (when output :string)
:input (make-string-input-stream input)))
(defun pbcopy (object)
(sh '("pbcopy") :input (aesthetic-string object))
(values))
(defun pbpaste ()
(values (sh '("pbpaste") :output t)))
;;;; Streams ------------------------------------------------------------------
(defun ensure-stream (input)
(ctypecase input
(stream input)
(string (make-string-input-stream input))))
(defun ensure-string (input)
(ctypecase input
(stream (alexandria:read-stream-content-into-string input))
(string (copy-seq input))))
(defun ensure-keyword (input)
(values
(ctypecase input
(keyword input)
(symbol (alexandria:make-keyword input))
(string (alexandria:make-keyword (string-upcase (str:trim input)))))))
(defun ensure-list (input)
(if (listp input) input (list input)))
;;;; Problems -----------------------------------------------------------------
(defmacro define-problem-tests ((year day) part1 part2)
`(1am:test ,(alexandria:symbolicate 'test-
(princ-to-string year)
'/
(princ-to-string day))
(multiple-value-bind (part1 part2) (,(alexandria:symbolicate 'run))
(1am:is (equal ,part1 part1))
(1am:is (equal ,part2 part2)))))
(defmacro define-problem ((year day)
(arg &optional (reader 'identity))
(&optional answer1 answer2)
&body body)
(multiple-value-bind (body declarations docstring)
(alexandria:parse-body body :documentation t)
(with-gensyms (file)
(let ((run (symb 'run)))
`(progn
(defun ,run (&optional ,arg)
,@(when docstring (list docstring))
,@declarations
(let ((,file (unless ,arg (open (problem-data-path ,year ,day)))))
(unwind-protect
(progn (unless ,arg
(setf ,arg (,reader (ensure-stream (or ,arg ,file)))))
,@body)
(when ,file (close ,file)))))
,@(when answer1
(list `(define-problem-tests (,year ,day) ,answer1 ,answer2)))
'run)))))
(defun problem-data-path (year day)
(make-pathname
:directory `(:relative "data" ,(aesthetic-string year))
:name (format nil "~2,'0D" day)
:type "txt"))
;;;; Readers ------------------------------------------------------------------
(defun read-numbers-from-string (line)
(mapcar #'parse-integer (ppcre:all-matches-as-strings "-?\\d+" line)))
(defun read-and-collect (stream reader)
(iterate (for value :in-stream stream :using reader)
(collect value)))
(defun read-before (char &optional (discard-delimiter t) (stream *standard-input*) (eof-error-p t) eof-value)
"Read characters from `stream` up to, but *not* including, `char`.
A string of the characters read will be returned.
If `discard-delimiter` is true, the `char` (if any) will be consumed from the
stream. It will not be included in the results — use `read-to` for that.
EOF is only reported when an EOF is encountered immediately. Otherwise the
remaining characters will be read and returned (and EOF reported on the next
invocation).
"
(if (null (peek-char nil stream nil))
(if eof-error-p
(error 'end-of-file)
eof-value)
(iterate
(for c = (peek-char nil stream nil))
(until (null c))
(when (char= char c)
(when discard-delimiter
(read-char stream))
(finish))
(collect (read-char stream) :result-type 'string))))
(defun read-to (char &optional (stream *standard-input*) (eof-error-p t) eof-value)
"Read characters from `stream` up to and including `char`.
A string of the characters read will be returned.
EOF is only reported when an EOF is encountered immediately. Otherwise the
remaining characters will be read and returned (and EOF reported on the next
invocation).
"
(if (null (peek-char nil stream nil))
(if eof-error-p
(error 'end-of-file)
eof-value)
(iterate
(for c = (peek-char nil stream nil))
(until (null c))
(collect (read-char stream) :result-type 'string)
(until (char= char c)))))
(defun read-all (stream)
"Read all forms from `stream` and return them as a fresh list."
(read-and-collect stream #'read))
(defun read-numbers (stream)
(read-numbers-from-string (alexandria:read-stream-content-into-string stream)))
(defun read-lines (stream)
"Read all lines from `stream` and return them as a fresh list of strings."
(read-and-collect stream #'read-line))
(defun read-lines-of-numbers-and-garbage (stream)
"Read the lines of numbers in `stream` into a list of lists of numbers.
Numbers can be separated by anything, even garbage.
Lines without any numbers will be discarded.
"
(iterate (for line :in-stream stream :using #'read-line)
(for numbers = (read-numbers-from-string line))
(when numbers
(collect numbers))))
(defun read-lines-of-words (stream)
(mapcar (lambda (line) (split-sequence:split-sequence #\space line))
(read-lines stream)))
(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))
(defstruct (ring (:constructor make-ring%))
(data)
(prev nil :type (or null ring))
(next nil :type (or null ring)))
(defmethod print-object ((ring ring) stream)
(print-unreadable-object (ring stream :type t :identity t)
(format stream "~S" (ring-list ring))))
(defun map-ring (function ring)
(if (null ring)
nil
(cons (funcall function (ring-data ring))
(loop
:for r = (ring-next ring) :then (ring-next r)
:until (eql r ring)
:collect (funcall function (ring-data r))))))
(defmacro do-ring ((el ring) &body body)
(once-only (ring)
(with-gensyms (r started)
`(if (null ,ring)
nil
(do* ((,r ,ring (ring-next ,r))
(,started nil t))
((and ,started (eql ,ring ,r)) (values))
(let ((,el (ring-data ring)))
,@body))))))
(defun ring-find (ring el)
(cond
((null ring) nil)
((eql (ring-data ring) el) ring)
(t (loop
:for r = (ring-next ring) :then (ring-next r)
:until (eql r ring)
:when (eql (ring-data r) el) :return r))))
(defun ring-list (ring)
(map-ring #'identity ring))
(defun ring-length (ring)
(let ((result 0))
(do-ring (el ring)
(declare (ignore el))
(incf result))
result))
(defun ring-move (ring n)
(check-type n fixnum)
(if (minusp n)
(loop :repeat (- n) :do (setf ring (ring-prev ring)))
(loop :repeat n :do (setf ring (ring-next ring))))
ring)
(defun ring-insert-after (ring element)
(if (null ring)
(ring element)
(let* ((p ring)
(n (ring-next ring))
(new (make-ring% :data element :prev p :next n)))
(setf (ring-next p) new
(ring-prev n) new)
new)))
(defun ring-insert-before (ring element)
(if (null ring)
(ring element)
(let* ((p (ring-prev ring))
(n ring)
(new (make-ring% :data element :prev p :next n)))
(setf (ring-next p) new
(ring-prev n) new)
new)))
(defun ring-cut (ring &key prev)
(assert (not (null ring)) (ring) "Cannot cut from empty ring ~S" ring)
(let ((n (ring-next ring)))
(if (eql ring n)
nil
(let ((p (ring-prev ring)))
(setf (ring-next p) n
(ring-prev n) p
(ring-next ring) nil
(ring-prev ring) nil)
(if prev p n)))))
(define-modify-macro ring-findf (el) ring-find)
(define-modify-macro ring-cutf (&rest keywords) ring-cut)
(define-modify-macro ring-movef (n) ring-move)
(define-modify-macro ring-nextf () ring-next)
(define-modify-macro ring-prevf () ring-prev)
(define-modify-macro ring-insertf-after (element) ring-insert-after)
(define-modify-macro ring-insertf-before (element) ring-insert-before)
(defun ring (&rest elements)
(if (null elements)
nil
(iterate
(with start)
(for element :in elements)
(for prev = ring)
(for ring = (if-first-time
(setf start (make-ring% :data element))
(make-ring% :data element :prev prev)))
(when prev
(setf (ring-next prev) ring
(ring-prev ring) prev))
(finally (setf (ring-next ring) start
(ring-prev start) ring)
(return start)))))
;;;; Miscellaneous ------------------------------------------------------------
(defun hash-table= (h1 h2 &optional (test #'eql))
"Return whether `h1` and `h2` have the same keys and values.
The consequences are undefined if `h1` and `h2` use different key tests.
`test` is used to compare values.
"
(and (= (hash-table-count h1)
(hash-table-count h2))
(iterate (for (k v) :in-hashtable h1)
(always (funcall test v (gethash k h2))))))
(defun hamming-distance (sequence1 sequence2 &key (test #'eql))
"Return the Hamming distance between `sequence1` and `sequence2`."
;; todo assert length=?
(let ((result 0))
(map nil (lambda (x y)
(unless (funcall test x y)
(incf result)))
sequence1
sequence2)
result))
(defun unique (list &key (test #'eql))
"Return a fresh list of the unique elements in `LIST`.
This differs from REMOVE-DUPLICATES in that *all* duplicate elements will be
removed, not just all-but-the-last.
This is O(n²).
Example:
(remove-duplicates '(3 1 3 2 3))
; => (1 2 3)
(unique '(3 1 3 2 3))
; => (1 2)
"
(iterate
(for a :in list)
(for i :from 0)
(unless (iterate (for b :in list)
(for j :from 0)
(unless (= i j)
(thereis (funcall test a b))))
(collect a))))
(defun extremum+ (sequence predicate)
"Like ALEXANDRIA:EXTREMUM but also return the position as a second value."
(iterate
(with value = nil)
(with position = nil)
(for i :from 0)
(for v :in-whatever sequence)
(if-first-time
(setf value v
position i)
(when (funcall predicate v value)
(setf value v
position i)))
(finally (return (values value position)))))
(defun extremums (sequence predicate &key (key #'identity))
"Like ALEXANDRIA:EXTREMUM but return *all* values in case of a tie."
(iterate
(with results = nil)
(with prev = nil)
(for v :in-whatever sequence)
(for k = (funcall key v))
(if-first-time
(progn (push v results)
(setf prev k))
(cond
((funcall predicate k prev) (setf results (list v)
prev k))
((funcall predicate prev k) nil) ; noop
(t (progn (push v results)
(setf prev k)))))
(finally (return results))))
(defun char-invertcase (char)
"Return `char` with its case inverted, if possible."
(if (lower-case-p char)
(char-upcase char)
(char-downcase char)))
(defun-inline x (point)
(realpart point))
(defun-inline y (point)
(imagpart point))
(defun manhattan-distance (point1 &optional (point2 #c(0 0)))
"Return the Manhattan distance between the two points on the complex plane."
(+ (abs (- (x point1)
(x point2)))
(abs (- (y point1)
(y point2)))))
(defun manhattan-neighbors (point)
"Return points adjacent to point (excluding diagonals) on the complex plane."
(list (+ point #c(0 1))
(+ point #c(1 0))
(+ point #c(0 -1))
(+ point #c(-1 0))))
(defgeneric emptyp (collection)
(:documentation "Return whether `collection` is empty."))
(defmethod emptyp ((list list))
(null list))
(defmethod emptyp ((vector vector))
(zerop (length vector)))
(defmethod emptyp ((hash-table hash-table))
(zerop (hash-table-count hash-table)))
(defmethod emptyp ((digraph digraph:digraph))
(digraph:emptyp digraph))
(defmethod emptyp ((hset hash-set))
(hset-empty-p hset))
(defun-inline nth-digit (n integer &optional (radix 10))
"Return the `n`th digit of `integer` in base `radix`, counting from the right."
(mod (truncate integer (expt radix n)) radix))
(defun-inlineable integral-image (width height value-function)
;; https://en.wikipedia.org/wiki/Summed-area_table
(let ((image (make-array (list width height)))
(last-row (1- height))
(last-col (1- width)))
(dotimes (x width)
(dotimes (y height)
(setf (aref image x y)
(+ (funcall value-function x y)
(if (= x last-col) 0 (aref image (1+ x) y))
(if (= y last-row) 0 (aref image x (1+ y)))
(if (or (= x last-col) (= y last-row))
0
(- (aref image (1+ x) (1+ y))))))))))
(defun positions-if (predicate sequence &key (start 0) end key)
"Return a fresh list of all positions in `sequence` that satisfy `predicate`.
Like `cl:position-if`, but returns a list of all the results.
Example:
(positions-if #'upper-case-p \"aBCdeF\")
; =>
(1 2 5)
"
(let ((pos start))
(nreverse (reduce (lambda (result value)
(prog1 (if (funcall predicate value)
(cons pos result)
result)
(incf pos)))
sequence
:start start
:end end
:key key
:initial-value nil))))
(defun digits (n &key (radix 10) from-end (result-type 'list))
"Return a fresh list of the digits of `n` in base `radix`.
By default, the digits are returned high-order first, as you would read them.
Use `from-end` to get them low-order first:
(digits 123) ; => (1 2 3)
(digits 123 :from-end t) ; => (3 2 1)
"
(let ((result (iterate
(for (values remaining digit) = (truncate n radix))
(collect digit)
(setf n remaining)
(until (zerop n)))))
(coerce (if from-end
result
(nreverse result))
result-type)))
(defun fresh-vector (sequence)
(if (typep sequence 'vector)
(copy-seq sequence)
(coerce sequence 'vector)))
(defun first-character (string)
"Return the first character of `string`."
(char string 0))
(defmacro let-result ((symbol initform) &body body)
"Bind `symbol` to initform, execute `body`, and return `symbol`.
This is useful for creating a object, doing some work on it, and returning the
object. For example:
(let-result (table (make-hash-table))
(setf (gethash 0 table) 'foo))
; ==>
(let ((table (make-hash-table)))
(setf (gethash 0 table) 'foo)
table)
"
`(let ((,symbol ,initform))
,@body
,symbol))
(defmacro let-complex (bindings &body body)
`(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))
(defun queue-thunk (&rest elements)
(lambda () (pop elements)))
(defun bytes->hex (bytes)
(format nil "~(~{~2,'0X~}~)" (coerce bytes 'list)))
(defun bytes->integer (bytes)
(iterate
(for byte :in (coerce bytes 'list))
(for result :seed 0 :then (+ (ash result 8) byte))
(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
(estimate 0)
(cost 0)
(previous nil))
(defun path-to-list (path &aux result)
(recursively ((path path))
(unless (null path)
(push (path-state path) result)
(recur (path-previous path))))
result)
(defun astar (&key start neighbors goalp cost heuristic test limit)
"Search for a path from `start` to a goal using A★.
The following parameters are all required:
* `start`: the starting state.
* `neighbors`: a function that takes a state and returns all states reachable
from it.
* `goalp`: a predicate that takes a state and returns whether it is a goal.
* `cost`: a function that takes two states `a` and `b` and returns the cost
to move from `a` to `b`.
* `heuristic`: a function that takes a state and estimates the distance
remaining to the goal.
* `test`: an equality predicate for comparing nodes. It must be suitable for
passing to `make-hash-table`.
If the heuristic function is admissable (i.e. it never overestimates the
remaining distance) the algorithm will find the shortest path.
Note that `test` is required. The only sensible default would be `eql`, but
if you were using states that need a different predicate and forgot to pass it
the algorithm would end up blowing the heap, which is unpleasant.
The following parameters are optional:
* `limit`: a maximum cost. Any paths that exceed this cost will not be
considered.
"
(let ((seen (make-hash-table :test test))
(frontier (pileup:make-heap #'< :key #'path-estimate)))
(labels ((mark-seen (path)
(setf (gethash (path-state path) seen) (path-cost path)))
(push-path (path)
(mark-seen path)
(pileup:heap-insert path frontier)))
(iterate
(initially (push-path (make-path :state start)))
(for (values current found) = (pileup:heap-pop frontier))
(unless found
(return (values nil nil)))
(for current-state = (path-state current))
(when (funcall goalp current-state)
(return (values (path-to-list current) t)))
(for current-cost = (path-cost current))
(iterate
(for next-state :in (funcall neighbors current-state))
(for next-cost = (+ current-cost (funcall cost current-state next-state)))
(for (values seen-cost previously-seen) = (gethash next-state seen))
(unless (and limit (> next-cost limit))
(when (or (not previously-seen)
(< next-cost seen-cost))
(for next-estimate = (+ next-cost (funcall heuristic next-state)))
(push-path (make-path :state next-state
:cost next-cost
:estimate next-estimate
:previous current)))))))))