blob: 24725ef07c580f2d65860ee400705890adc20ca9 (
plain)
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
|
(ql:quickload '(fiveam uiop trivia arrows))
(defun distance-1 (a b)
(apply #'+
(mapcar (lambda (e1 e2)
(abs (- e1 e2))) a b)))
(defun boundary-conditions (width height)
"The boundary is a wall meaning 0 & (N-1) are never occupied."
(lambda (x y dir)
(list
dir
(cond
((zerop x) (- width 2))
((= x (- width 1)) 1)
(x))
(cond
((zerop y) (- height 2))
((= y (- height 1)) 1)
(y)))))
(defun wall-p (width height)
(lambda (point)
(destructuring-bind (x y) point
(cond
;; not entry - exit
((or (and (= x 1) (zerop y))
(and (= x (- width 2)) (= y (1- height))))
nil)
;; yes wall or out of map
((or (<= x 0) (<= y 0)
(>= x (1- width))
(>= y (1- height))))))))
(fiveam:test boundaries
(let ((bc (boundary-conditions 6 9)))
(fiveam:is (equal (funcall bc 5 3 t) '(t 1 3)))
(fiveam:is (equal (funcall bc 5 8 t) '(t 1 1)))
(fiveam:is (equal (funcall bc 0 8 t) '(t 4 1)))))
(defstruct valley
blizzards
boundaries
wallp
size)
(defun data-input (filename)
(let* ((lines (uiop:read-file-lines filename))
(width (length (car lines)))
(height (length lines)))
(make-valley
:blizzards
(loop for row in lines
and y from 0
nconc (loop for place across row
and x from 0
unless (or (eq #\# place) (eq #\. place))
collect (list (ecase place
(#\> '>)
(#\< '<)
(#\v 'v)
(#\^ '^))
x y)))
:boundaries (boundary-conditions width height)
:wallp (wall-p width height)
:size (list width height))))
(defun evolve (valley)
(with-slots (blizzards boundaries) valley
(mapcar
(lambda (blizzard)
(trivia:match blizzard
((list '> x y) (funcall boundaries (1+ x) y '>))
((list '< x y) (funcall boundaries (1- x) y '<))
((list 'v x y) (funcall boundaries x (1+ y) 'v))
((list '^ x y) (funcall boundaries x (1- y) '^))))
blizzards)))
(defun elf-moves (elf valley)
(with-slots (blizzards wallp) valley
(destructuring-bind (x y) elf
(arrows:-<>
(list (list (1+ x) y)
(list x (1+ y))
(list (1- x) y)
(list x (1- y))
(list x y))
(delete-if wallp <>)
(set-difference <> (mapcar #'cdr blizzards) :test #'equal)))))
(defun cutoff-distance (positions goal)
(loop for p in positions
for dist = (distance-1 goal p)
maximize dist into ma
minimize dist into mi
finally (return (values (max (ceiling (+ ma mi) 2)
(* 1.2 mi)
(* 0.8 ma)
30)
mi ma))))
(defun discard-hopeless-positions (positions goal cutoff-distance)
(delete-if (lambda (p) (< cutoff-distance (distance-1 goal p))) positions))
(defun time-step! (time-left walkers goal valley)
(if (or (zerop time-left) (member goal walkers :test #'equal))
time-left
(progn
(setf (valley-blizzards valley) (evolve valley))
(let* ((new-positions (reduce
(lambda (options point)
(union options (elf-moves point valley) :test #'equal))
walkers
:initial-value nil))
(shortened-positions (discard-hopeless-positions new-positions goal
(cutoff-distance new-positions goal))))
(time-step! (1- time-left)
shortened-positions
goal valley)))))
(defun solver (filename repeats)
(let ((valley (data-input filename)))
(destructuring-bind (width height) (valley-size valley)
(let ((exit (list (- width 2) (1- height)))
(start (list 1 0))
(max-time 500))
(loop for (start goal) on (loop with l = (list start exit)
repeat repeats
append l)
while goal
sum (- max-time (time-step! max-time (list start) goal valley)))))))
(fiveam:test solutions
(fiveam:is (= 18 (solver "eg-in" 1)))
(fiveam:is (= 299 (solver "input" 1)))
(fiveam:is (= 54 (solver "eg-in" 2)))
(fiveam:is (= 899 (solver "input" 2))))
|
