aoc2019 day25

aoc2019-day25.lisp

;;;; +----------------------------------------------------------------+
;;;; | Advent of Code 2019                                            |
;;;; +----------------------------------------------------------------+

(defpackage #:snippets/aoc2019/day25
  (:use #:cl)
  (:import-from
   #:snippets/aoc2019/intcode
   #:intcode-run)
  (:shadow
   #:room)
  (:import-from
   #:snippets/slhelpers
   #:bfs)
  (:import-from
   #:snippets/pipe-streams
   #:make-pipe-streams)
  (:import-from
   #:alexandria
   #:emptyp
   #:make-keyword
   #:destructuring-ecase
   #:map-combinations
   #:starts-with-subseq)
  (:export
   #:day25))

(in-package #:snippets/aoc2019/day25)

(defun verbose (format-control &rest format-args)
  (apply #'format *debug-io* format-control format-args))

(defun play (program &optional (input-stream *standard-input*)
                               (output-stream *standard-output*))
  (intcode-run program
               :input (lambda () (char-code (read-char input-stream)))
               :output (lambda (x) (write-char (code-char x) output-stream))))

(defun ai-play (program function)
  (multiple-value-bind (input-read input-write)
      (make-pipe-streams :element-type 'character)
    (unwind-protect
         (multiple-value-bind (output-read output-write)
             (make-pipe-streams :element-type 'character)
           (unwind-protect
                (let ((thread (bt:make-thread (lambda () (play program input-read output-write))
                                              :name "quest thread")))
                  (unwind-protect
                       (funcall function output-read input-write)
                    (when (bt:thread-alive-p thread)
                      (ignore-errors (bt:destroy-thread thread)))))
             (ignore-errors (close output-write))
             (ignore-errors (close output-read))))
      (ignore-errors (close input-write))
      (ignore-errors (close input-read)))))

(defstruct room
  name
  extra
  doors
  items)

(defstruct item
  name
  room)

(defun explore (program)
  (ai-play program
           (lambda (see-stream do-stream)
             (let ((rooms (make-hash-table :test 'equal)))
               (explore-dfs (expect-room see-stream) see-stream do-stream rooms)
               rooms))))

(defun explore-dfs (current see-stream do-stream rooms)
  (unless (gethash (room-name current) rooms)
    (setf (gethash (room-name current) rooms) current)
    (unless (equal (room-name current) "Security Checkpoint")
      (dolist (door (room-doors current))
        (when (null (cdr door))
          (write-line (string-downcase (car door)) do-stream)
          (let ((new (expect-room see-stream)))
            (explore-dfs new see-stream do-stream rooms)
            (setf (cdr door) new))
          (write-line (string-downcase (opposite-direction (car door))) do-stream)
          (let ((back (expect-room see-stream)))
            (assert (equal (room-name current) (room-name back)))))))))

(defun read-event (see-stream)
  (loop for line = (read-line see-stream nil nil)
        while (and line (not (equal line "Command?")))
        do (cond ((emptyp line))
                 ((starts-with-subseq "== " line)
                  (return-from read-event
                    (list :room (read-room (subseq line 3 (- (length line) 3)) see-stream))))
                 ((starts-with-subseq "You take the " line)
                  (loop while (peek-char nil see-stream nil)
                        for extra = (read-line see-stream)
                        do (cond ((emptyp extra))
                                 ((equal extra "Command?")
                                  (return))
                                 (t
                                  (verbose "Take Line: ~S~%" extra))))
                  (return-from read-event
                    (list :take (subseq line 13 (1- (length line))))))
                 (t
                  (verbose "Event Line: ~S~%" line))))
  (list :eof))

(defun expect-room (stream)
  (destructuring-ecase (read-event stream)
    ((:room room) room)))

(defun read-room (name stream)
  (let ((room (make-room :name name))
        (state :want-extra))
    (loop for line = (read-line stream nil nil)
          until (or (null line) (equal line "Command?"))
          do (verbose "Room Line: ~S~%" line)
             (cond ((emptyp line))
                   ((starts-with-subseq "Doors here lead:" line)
                    (setf state :want-doors))
                   ((starts-with-subseq "Items here:" line)
                    (setf state :want-items))
                   ((starts-with-subseq "\"Oh, hello!" line)
                    (throw :got-it (values (parse-integer line :start 51 :junk-allowed t))))
                   ((eq state :want-extra)
                    (push line (room-extra room)))
                   ((starts-with-subseq "- " line)
                    (ecase state
                      (:want-doors
                       (push (list (make-keyword (string-upcase (subseq line 2))))
                             (room-doors room)))
                      (:want-items
                       (push (make-item :name (subseq line 2)
                                        :room room)
                             (room-items room)))))))
    (setf (room-extra room) (nreverse (room-extra room)))
    room))

(defun opposite-direction (dir)
  (ecase dir
    (:east :west)
    (:north :south)
    (:south :north)
    (:west :east)))

(defun all-items (rooms)
  (loop for room being each hash-value of rooms
        append (room-items room)))

(defun follow-plan (program plan &optional (rooms (explore program)))
  (ai-play program
           (lambda (see-stream do-stream)
             (plan-follower plan rooms see-stream do-stream))))

(defun plan-follower (plan rooms see-stream do-stream)
  (let ((current-room (expect-room see-stream)))
    (verbose "Room: ~S~%" (room-name current-room))
    (loop while plan
          do (destructuring-ecase (pop plan)
               ((:go destination)
                (etypecase destination
                  (symbol
                   (write-line (string-downcase destination) do-stream)
                   (let ((event (read-event see-stream)))
                     (destructuring-ecase event
                       ((:room room)
                        (setf current-room room))))
                   (verbose "Room: ~S~%" (room-name current-room)))
                  (string
                   (let ((target-room (gethash destination rooms)))
                     (when (null target-room)
                       (error "No room named ~S." destination))
                     (push (list :go target-room) plan)))
                  (room
                   (setf plan (append (path-steps current-room destination rooms) plan)))))
               ((:take item)
                (cond ((stringp item)
                       (let ((item-object (or (find item (room-items current-room) :key #'item-name :test #'equal)
                                              (find item (all-items rooms) :key #'item-name :test #'equal)
                                              (error "Can't find item ~S." item))))
                         (push (list :take item-object) plan)))
                      ((member (item-name item) (room-items current-room) :key #'item-name :test #'equal)
                       (format do-stream "take ~A~%" (item-name item))
                       (verbose "Take Event: ~S~%" (read-event see-stream)))
                      (t
                       (setf plan
                             (list* (list :go (item-room item))
                                    (list :take item)
                                    plan)))))))))

(defun path-steps (source destination rooms)
  (let ((path (bfs (cons :here source)
                   (lambda (node)
                     (equal (room-name (cdr node))
                            (room-name destination)))
                   (lambda (node)
                     (let ((room (gethash (room-name (cdr node)) rooms)))
                       (assert room)
                       (loop for door in (room-doors room)
                             when (cdr door)
                             collect door)))
                   :key (lambda (node) (room-name (cdr node)))
                   :test #'equal)))
    (mapcar (lambda (node) (list :go (car node))) (cdr path))))

(defun dangerous-item-p (item)
  (member (item-name item)
          '("infinite loop" "molten lava" "photons" "escape pod" "giant electromagnet")
          :test #'equal))

(defun take-em-all (program)
  "Put them up against the wall and shoot'em..."
  (catch :got-it
    (let* ((rooms (explore program))
           (items (all-items rooms)))
      (setf items (remove-if #'dangerous-item-p items))
      (loop for n from 1 to (length items)
            do (map-combinations
                (lambda (to-take)
                  (verbose "Taking: ~S~%" (mapcar #'item-name to-take))
                  (follow-plan program
                               (append (mapcar (lambda (item) (list :take item)) to-take)
                                       (list (list :go "Security Checkpoint")
                                             (list :go :west)))
                               rooms))
                items
                :copy nil
                :length n)))))

(defun day25 (input &optional verbose)
  (let ((*debug-io* (if verbose *debug-io* (make-broadcast-stream))))
    (list (take-em-all input))))