path: root/day08.lisp

(defstruct mymap left right)

(defstruct problem instructions maps)

(defun remove-spaces (string)
  (coerce (loop for c across string
                if (char/= c #\Space)
                  collect c) 'string))

(defun parse-mymap (string)
  (let* ((string (remove-spaces string))
         (posequal (position #\= string :test #'char=))
         (poscomma (position #\, string :start (1+ posequal)))
         (key (subseq string 0 posequal))
         (left (subseq string (1+ (1+ posequal)) poscomma))
         (right (subseq string (1+ poscomma) (1- (length string)))))
    (values key (make-mymap :left left :right right))))

(defun parse-maps (stream)
  (let ((ht (make-hash-table :test 'equal)))
    (loop for line = (read-line stream nil)
          while line
          if (< 0 (length line))
            do (multiple-value-bind (key mymap) (parse-mymap line)
                 (setf (gethash key ht) mymap)))
    ht))

(defun parse-problem (filespec)
  (with-open-file (stream filespec)
    (let* ((instructions (read-line stream) )
           (maps (parse-maps stream)))
      (make-problem :instructions instructions :maps maps))))

(defun count-path (problem start end)
  (let ((instructions (problem-instructions problem))
        (maps (problem-maps problem)))
    (labels ((f (&optional (i 0) (current start) (acc 0))
               (if (equal current end)
                   acc
                   (let* ((instruction (aref instructions i))
                          (currentmap (gethash current maps))
                          (nxt (if (char= #\L instruction)
                                   (mymap-left currentmap)
                                   (mymap-right currentmap))))
                     (f (mod (1+ i) (array-total-size instructions)) nxt (1+ acc))))))
      (f))))

(defun solve1 (filespec)
  (let ((problem (parse-problem filespec)))
    (count-path problem (subseq "AAA" 0) (subseq "ZZZ" 0))))

(defun ends-with (string char)
  (char= char (aref string (1- (array-total-size string)))))

(defun find-starts (maps char)
  (loop for string being each hash-key of maps
        if (ends-with string char)
          collect string))

(defun find-possible (maps instructions start endchar)
  (loop with res = '()
        and vis = '()
        and n = (length instructions)
        for current = start then next
        for count = 0 then (1+ count)
        for i = 0 then (mod (1+ i) n)
        as final = (ends-with current endchar)
        as instruction = (aref instructions i)
        as cmap = (gethash current maps)
        as next = (if (char= instruction #\L) (mymap-left cmap) (mymap-right cmap))
        as mem = (member (list current i) vis :test #'equal :key #'cdr)
        if (and final mem)
          do (push (list (caar mem) (- count (caar mem))) res)
        if (and final mem (= (length vis) (length res)))
           return res
        if (and final (not mem))
          do (push (list count current i) vis)))

(defun count-multiple-paths (problem startchar endchar)
  (let* ((instructions (problem-instructions problem))
         (maps (problem-maps problem))
         (starts (find-starts maps startchar)))
    (let ((loops (mapcar (lambda (start) (find-possible maps instructions start endchar))
                         starts)))
      (when (every (lambda (l) (and (= 1 (length l)) (= (caar l) (cadar l)))) loops)
        ;; LCM only makes sense if there is exactly 1 loop for each
        ;; path and that loop has the same start and period (which is
        ;; the case for the input)
        (apply #'lcm (mapcar #'caar loops))))))

(defun solve2 (filespec)
  (let ((problem (parse-problem filespec)))
    (count-multiple-paths problem #\A #\Z)))

(print (solve1 "data/08/example.txt"))  ;; 2
(print (solve1 "data/08/example2.txt")) ;; 6
(print (solve1 "data/08/input.txt"))    ;; 21883
(print (solve2 "data/08/example3.txt")) ;; 6 (nil for this code)
(print (solve2 "data/08/input.txt"))    ;; 12833235391111