adventofcode/src/2019/day18.lisp at master · iamFIREcracker/adventofcode · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
(defpackage :aoc/2019/18 #.cl-user::*aoc-use*)
(in-package :aoc/2019/18)

(defun read-map (data &aux (map (make-hash-table)))
  (prog1 map
    (loop
      :for str :in data
      :for i = 0 :then (1- i)
      :do (loop
            :for c :across str
            :for j = 0 :then (1+ j)
            :for pos = (complex j i)
            :do (hash-table-insert map pos c)))))

(defstruct state robots collected)

(defun keyp (c) (lower-case-p c))
(defun doorp (c) (upper-case-p c))
(defun wallp (c) (char= c #\#))

(defstruct (vault (:constructor make-vault%)
                  (:conc-name v-))
  map
  keys
  keys-sorted)

(defun make-vault (data &aux (keys (make-hash-table)))
  (let* ((map (read-map data)))
    (loop
      :for pos :in (hash-table-keys map)
      :for c = (gethash pos map)
      :when (keyp c) :do (hash-table-insert keys c pos))
    (make-vault% :map map
                 :keys keys
                 :keys-sorted (sort (hash-table-keys keys) #'char<))))

(defun v-start (v)
  (loop
    :for pos :in (hash-table-keys (v-map v))
    :for c = (v-cell v pos)
    :when (eql #\@ c) :collect pos))

(defun v-key-pos (v key)
  (gethash key (v-keys v)))

(defun v-cell (v pos)
  (gethash pos (v-map v)))

(defun v-neighbors (v pos)
  (loop
    :for next-pos :in (adjacents pos)
    :for c = (v-cell v next-pos)
    :unless (wallp c) :collect next-pos))

(defun char- (a b)
  (- (char-code a) (char-code b)))

(defun doors-along-the-way (v path)
  (let ((doors 0))
    (dolist (pos path)
      (let ((c (v-cell v pos)))
        (when (doorp c)
          (setf doors (logior doors (ash 1 (char- c #\A)))))))
    doors))

(defun/memo reach-key (v init-pos target-pos)
  (multiple-value-bind (end-state end-state-cost end-state-path)
      (a* init-pos
          :goal-state target-pos
          :neighbors (search-unit-cost (partial-1 #'v-neighbors v))
          :heuristic (partial-1 #'manhattan-distance _ target-pos))
    (declare (ignore end-state))
    (let* ((doors (doors-along-the-way v end-state-path)))
      (cons end-state-cost doors))))

(defun already-collected (keys i)
  (plusp (logand keys (ash 1 i))))

(defun doors-unlocked-p (doors keys)
  (= doors (logand doors keys)))

(defun change (orig i value)
  (let ((copy (copy-seq orig)))
    (setf (aref copy i) value)
    copy))

(defun v-reachable-keys (v state)
  (with-slots (robots collected) state
    (loop :for i :below (length robots)
          :for pos :across robots
          :append (loop :for key :in (v-keys-sorted v)
                        :for key-i :from 0
                        :for key-pos = (v-key-pos v key)
                        :for (steps . doors) = (reach-key v pos key-pos)
                        :when (and steps (doors-unlocked-p doors collected)
                                   (not (already-collected collected key-i)))
                        :collect (cons
                                   (make-state
                                     :robots (change robots i key-pos)
                                     :collected (logior collected (ash 1 key-i)))
                                   steps)))))

(defun solve (data &aux (v (make-vault data)))
  (let* ((num-keys (length (v-keys-sorted v)))
         (all-keys (1- (ash 1 num-keys)))
         (robots (coerce (v-start v) 'vector)))
    (reach-key/clear-memo)
    (search-cost (dijkstra (make-state :robots robots :collected 0)
                           :goalp (partial-1 #'= all-keys (state-collected _))
                           :neighbors (partial-1 #'v-reachable-keys v)
                           :test 'equalp))))

(defun prepare-part2 (data)
  (let* ((copy (copy-seq data))
         (vault-x (floor (length (first data)) 2))
         (vault-y (floor (length data) 2)))
    (setf (aref (nth (1- vault-y) copy) (1- vault-x)) #\@
          (aref (nth (1- vault-y) copy) vault-x) #\#
          (aref (nth (1- vault-y) copy) (1+ vault-x)) #\@
          (aref (nth vault-y copy) (1- vault-x)) #\#
          (aref (nth vault-y copy) vault-x) #\#
          (aref (nth vault-y copy) (1+ vault-x)) #\#
          (aref (nth (1+ vault-y) copy) (1- vault-x)) #\@
          (aref (nth (1+ vault-y) copy) vault-x) #\#
          (aref (nth (1+ vault-y) copy) (1+ vault-x)) #\@)
    copy))

(define-solution (2019 18) (data)
  (values
    (solve data)
    (solve (prepare-part2 data))))

(define-test (2019 18) (5068 1966))