src/utils.lisp @ a19c9e1fd077

(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))))


;;;; Problems -----------------------------------------------------------------
(defmacro define-problem ((year day)
                          (arg &optional (reader 'identity))
                          &body body)
  (multiple-value-bind (body declarations docstring)
      (alexandria:parse-body body :documentation t)
    (with-gensyms (file)
      (let ((run (symb 'run)))
        `(defun ,run (&optional ,arg)
           ,@(when docstring (list docstring))
           ,@declarations
           (let ((,file (unless ,arg (open (problem-data-path ,year ,day)))))
             (unwind-protect
                 (progn (setf ,arg (,reader (ensure-stream (or ,arg ,file))))
                        ,@body)
               (when ,file (close ,file)))))))))

(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-line (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-all (stream)
  "Read all forms from `stream` and return them as a fresh list."
  (read-and-collect stream #'read))

(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-line line))
           (when numbers
             (collect numbers))))


;;;; 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-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-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 manhattan-distance (point1 point2)
  "Return the Manhattan distance between the two points on the complex plane."
  (+ (abs (- (realpart point1)
             (realpart point2)))
     (abs (- (imagpart point1)
             (imagpart 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))))))))))