adventofcode/src/2019/day20.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
134
135
136
137
138
139
140
141
142
143
144
145
(defpackage :aoc/2019/20 #.cl-user::*aoc-use*)
(in-package :aoc/2019/20)

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

(defun wallp (c)
  (and c (char= c #\#)))

(defun passagep (c)
  (and c (char= c #\.)))

(defun emptyp (c)
  (and c (char= c #\Space)))

(defun labelp (c)
  (and c (not (or (wallp c)
                  (passagep c)
                  (emptyp c)))))

(defun 2-above (map pos)
  (mkstr (gethash (+ pos #C(0 -2)) map)
         (gethash (+ pos #C(0 -1)) map)))

(defun 2-right (map pos)
  (mkstr (gethash (+ pos #C(1 0)) map)
         (gethash (+ pos #C(2 0)) map)))

(defun 2-below (map pos)
  (mkstr (gethash (+ pos #C(0 1)) map)
         (gethash (+ pos #C(0 2)) map)))

(defun 2-left (map pos)
  (mkstr (gethash (+ pos #C(-2 0)) map)
         (gethash (+ pos #C(-1 0)) map)))

(defun read-portals (map &aux (labels (make-hash-table :test 'equal)))
  (prog1 labels
    (loop
      :for pos :being :the :hash-key :of map
      :for passage = (passagep (gethash pos map))
      :for 2-above = (2-above map pos)
      :for 2-right = (2-right map pos)
      :for 2-below = (2-below map pos)
      :for 2-left = (2-left map pos)
      :when (and passage (every #'labelp 2-above)) :do (push pos (gethash 2-above labels))
      :when (and passage (every #'labelp 2-right)) :do (push pos (gethash 2-right labels))
      :when (and passage (every #'labelp 2-below)) :do (push pos (gethash 2-below labels))
      :when (and passage (every #'labelp 2-left)) :do (push pos (gethash 2-left labels)))))

(defstruct (state (:conc-name s-))
  pos
  level)

(defstruct (donut (:constructor make-donut%)
                  (:conc-name d-))
  map
  portals
  outer-boundary-min-x
  outer-boundary-max-x
  outer-boundary-min-y
  outer-boundary-max-y)

(defun make-donut (data)
  (let* ((map (read-map data))
         (portals (read-portals map))
         (walls (loop
                  :for k :being :the :hash-keys :of map
                  :for v = (gethash k map)
                  :when (wallp v) :collect k)))
    (make-donut% :map map
                 :portals portals
                 :outer-boundary-min-x (reduce #'min walls :key #'realpart)
                 :outer-boundary-max-x (reduce #'max walls :key #'realpart)
                 :outer-boundary-min-y (reduce #'min walls :key #'imagpart)
                 :outer-boundary-max-y (reduce #'max walls :key #'imagpart))))

(defun d-start (d)
  (first (gethash "AA" (d-portals d))))

(defun d-end (d)
  (first (gethash "ZZ" (d-portals d))))

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

(defun d-other-side (d pos)
  (loop
    :for doors :being :the :hash-values :of (d-portals d)
    :for door1 = (first doors)
    :for door2 = (second doors)
    :when (and door2 (= pos door1)) :return door2
    :when (and door2 (= pos door2)) :return door1))

(defun d-neighbors (d pos)
  (loop
    :for next-pos :in (adjacents pos)
    :when (passagep (d-cell d next-pos)) :collect next-pos))

(defun d-neighbors-part1 (d pos)
  (append
    (d-neighbors d pos)
    (let ((other-side (d-other-side d pos)))
      (when other-side
        (list other-side)))))

(defun d-outer-boundary-p (d pos)
  (or (= (d-outer-boundary-min-x d) (realpart pos))
      (= (d-outer-boundary-max-x d) (realpart pos))
      (= (d-outer-boundary-min-y d) (imagpart pos))
      (= (d-outer-boundary-max-y d) (imagpart pos))))

(defun d-portal-active-p (d level pos)
  (or (/= 0 level) (not (d-outer-boundary-p d pos))))

(defun d-neighbors-part2 (d state)
  (let ((pos (s-pos state))
        (level (s-level state)))
    (append
      (mapcar (partial-1 #'make-state :pos _ :level level) (d-neighbors d pos))
      (when (or (not (zerop level)) (not (d-outer-boundary-p d pos)))
        (let ((other-side (d-other-side d pos)))
          (when (and other-side (d-portal-active-p d level pos))
            (list (make-state :pos other-side
                              :level (+ level (if (d-outer-boundary-p d pos) -1 1))))))))))

(define-solution (2019 20) (d make-donut)
  (values
    (search-cost (bfs (d-start d)
                      :goal-state (d-end d)
                      :neighbors (partial-1 #'d-neighbors-part1 d)))
    (search-cost (bfs (make-state :pos (d-start d) :level 0)
                      :goal-state (make-state :pos (d-end d) :level 0)
                      :neighbors (partial-1 #'d-neighbors-part2 d)
                      :test 'equalp))))

(define-test (2019 20) (496 5886))