/
19.lisp
128 lines (116 loc) · 5.76 KB
/
19.lisp
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
(ql:quickload :alexandria)
(ql:quickload :esrap) (use-package :esrap)
(ql:quickload :let-plus) (use-package :let-plus)
(defrule integer (+ (digit-char-p character))
(:lambda (digits) (parse-integer (text digits))))
(defrule end-of-line (or (and #\linefeed #\return)
(and #\return #\linefeed)
#\linefeed
#\return)
(:constant nil))
(defrule word (+ (alphanumericp character))
(:text t))
(defrule category (or #\x #\m #\a #\s)
(:lambda (s) (intern (string-upcase s))))
(defrule relation-rule (and category (or #\< #\>) integer #\: word (? #\,))
(:destructure (category relation x colon target comma)
(declare (ignore colon comma))
(list (list (intern relation) category x) (intern target))))
(defrule fixed-rule word
(:lambda (w) (list t (intern w))))
(defrule workflow-rule (or relation-rule fixed-rule))
(defrule workflow (and word #\{ (+ workflow-rule) #\} (? end-of-line))
(:destructure (name open-brace workflow-rules close-brace eol)
(declare (ignore open-brace close-brace eol))
(cons (intern name) workflow-rules)))
(defrule rating (and category #\= integer (? #\,))
(:destructure (category equals value colon)
(declare (ignore category equals colon))
value))
(defrule part (and #\{ (+ rating) #\} (? end-of-line))
(:function cadr))
(defrule input (and (+ workflow) end-of-line (+ part))
(:destructure (workflows eol parts)
(declare (ignore eol))
(list workflows parts)))
(defun day19 (is-part-two)
(if is-part-two
(loop
:with input := (parse 'input (uiop:read-file-string #P"./19.txt"))
:with get-accepted-ranges :=
`(lambda (ranges)
(let ((branches (list ranges)) results current)
(labels ((substitute-at (new n sequence)
(substitute-if new #'identity sequence :start n :count 1))
(split-range (relation range v)
(let ((from (car range)) (to (cdr range)))
(case relation
(< (cond ((< to v) (values range nil))
((>= from v) (values nil range))
(t (values (cons from (1- v)) (cons v to)))))
(> (cond ((> from v) (values range nil))
((<= to v) (values nil range))
(t (values (cons (1+ v) to) (cons from v))))))))
(branch (condition)
(let+ (((relation category v) condition)
(i (case category (x 0) (m 1) (a 2) (s 3)))
((&values matching-range non-matching-range)
(split-range relation (nth i current) v))
(match (substitute-at matching-range i current))
(no-match (substitute-at non-matching-range i current)))
(cond ((and matching-range non-matching-range)
(push match branches)
(setf current no-match)
nil)
(matching-range (setf current match) t)
(t (setf current no-match) nil)))))
(tagbody
start (alexandria:when-let (branch (pop branches))
(setf current branch)
(go |in|))
(go end)
,@(loop :with wf := nil
:for (name . rules) :in (car input)
:do (push name wf)
:do (loop :for (condition target) :in rules
:do (push (if (eql condition 't)
`(go ,target)
`(when (branch ',condition)
(go ,target)))
wf))
:finally (return (nreverse wf)))
A (push current results)
R (go start)
end nil)
results)))
:for ranges :in (funcall (compile nil get-accepted-ranges)
(loop :repeat 4 :collect (cons 1 4000)))
:sum (loop :with product := 1
:for (from . to) :in ranges
:do (setf product (* product (1+ (- to from))))
:finally (return product)))
(loop :with input := (parse 'input (uiop:read-file-string #P"./19.txt"))
:with accept-part-p
:= (compile
nil
`(lambda (part)
(destructuring-bind (x m a s) part
(declare (type fixnum x m a s))
(let ((result))
(tagbody
(go |in|)
,@(loop :with wf := nil
:for (name . rules) :in (car input)
:do (push name wf)
:do (loop :for (condition target)
:in rules
:do (push `(when ,condition
(go ,target))
wf))
:finally (return (nreverse wf)))
A (setf result t)
R nil)
result))))
:for part :in (cadr input)
:when (funcall accept-part-p part)
:sum (loop :for rating :in part :sum rating))))