blob: 0a7dfd4c19046136d45d2b0f079200a5734ae1f3 (
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
140
141
142
143
144
145
146
147
148
|
;; -*- lexical-binding: t; -*-
(require 'cl-lib)
(require 'seq)
(defconst solver-chamber-width 7)
(defun solver-point (x y)
(+ x (* y solver-chamber-width)))
(defun solver-coords (point)
(list (floor point solver-chamber-width)
(mod point solver-chamber-width)))
(defconst *rocks*
(vector (list (solver-point 0 0) (solver-point 1 0) (solver-point 2 0) (solver-point 3 0))
(list (solver-point 1 0)
(solver-point 0 1) (solver-point 1 1) (solver-point 2 1)
(solver-point 1 2))
(list (solver-point 0 0) (solver-point 1 0) (solver-point 2 0)
(solver-point 2 1)
(solver-point 2 2))
(list (solver-point 0 0) (solver-point 0 1) (solver-point 0 2) (solver-point 0 3))
(list (solver-point 0 0) (solver-point 1 0)
(solver-point 0 1) (solver-point 1 1))))
(cl-defun solver-no-collision-move (object direction obstacles)
(mapcar
(lambda (current)
(let ((next (funcall
(cl-ecase direction
(?> #'1+)
(?< #'1-)
(?v (lambda (p) (- p solver-chamber-width))))
current)))
(if (and (>= next 0)
;; no rolling boundaries
(seq-let (y x) (solver-coords current)
(seq-let (y2 x2) (solver-coords next)
(= 1 (+ (abs (- x x2)) (abs (- y y2))))))
(not (memq next obstacles)))
next (cl-return-from solver-no-collision-move object))))
object))
(defun solver-gen-object (seq)
(let ((len (length seq))
(index 0))
(lambda ()
(prog1 (elt seq index)
(setf index (mod (1+ index) len))))))
(defun solver-place-rock (rock highpoint)
(let ((left-pad 2)
(altitude (* solver-chamber-width highpoint)))
(mapcar (lambda (point)
(+ point left-pad altitude))
rock)))
(defun solver-next-move (rock next-move obstacles)
(let* ((shift (solver-no-collision-move rock next-move obstacles))
(drop (solver-no-collision-move shift ?v obstacles)))
(cl-values drop (equal shift drop))))
(defun solver-highpoint (obstacles)
(1+ (car (solver-coords (cl-reduce #'max obstacles)))))
(defun solver-simulate (chamber rock next-shift)
(seq-let (new-place done-falling-p)
(solver-next-move rock (funcall next-shift) chamber)
(if done-falling-p
(cl-values (append new-place chamber) (solver-highpoint new-place))
(solver-simulate chamber new-place next-shift))))
(defun solver (drops-left highpoint raise-history obstacles next-rock next-shift)
(if (zerop drops-left)
raise-history
(seq-let (new-obstacles posible-high)
(solver-simulate obstacles
(solver-place-rock (funcall next-rock) (+ highpoint 3))
next-shift)
(let ((new-high (max highpoint posible-high)))
(solver (1- drops-left) new-high (cons new-high raise-history)
;; new-obstacles
(if (zerop (mod drops-left 100)) ;; arbitrarily chop list
(seq-subseq new-obstacles 0 (min 128 (length new-obstacles)))
new-obstacles)
next-rock next-shift)))))
(defun solver-occurrences (lst)
(let ((table (make-hash-table :test #'eq)))
(cl-loop for e in lst
do (cl-incf (gethash e table 0)))
table))
(defun solver-to-alist (table)
(cl-loop for k being the hash-key of table using (hash-value v)
collect (cons k v)))
(defun solver-find-period (history max-window)
(let ((len (1- (length history))))
(cl-loop for size from 1 to max-window
for raises = (cl-loop
for start from 0 to len by size
for end from size by size
collect (- (aref history (min end len)) (aref history start)))
for periods = (solver-occurrences raises)
for test = (and (<= (hash-table-count periods) 3)
(car (cl-find-if (lambda (f) (< 1 (cdr f))) (solver-to-alist periods))))
until test
finally (return (cl-values size test)))))
(defun solver-height-reached (max-drops history max-window)
(seq-let (period block-height) (solver-find-period history max-window)
(seq-let (cycles left) (list (floor max-drops period) (mod max-drops period))
(let ((offset (aref history period))
(remaining (- (aref history (+ left period)) (aref history period))))
(+ offset (* (1- cycles) block-height) remaining)))))
(defun solver-input-directions (filename)
(with-current-buffer (find-file-noselect filename)
(solver-gen-object (string-trim (buffer-string)))))
(ert-deftest solutions ()
;; part 1
(let ((max-specpdl-size 18000)
(max-lisp-eval-depth 18000))
(should
(= 3068 (car (solver 2022 0 '(0) nil (solver-gen-object *rocks*) (solver-input-directions "eg-in")))))
(should
(= 3141 (car (solver 2022 0 '(0) nil (solver-gen-object *rocks*) (solver-input-directions "input")))))
;; part 2
(let* ((drops 1000000000000)
(quick-run 10000)
(max-period-window 3620)
(history-eg (apply #'vector
(nreverse (solver quick-run 0 '(0) nil (solver-gen-object *rocks*)
(solver-input-directions "eg-in")))))
(history-my (apply #'vector
(nreverse (solver quick-run 0 '(0) nil (solver-gen-object *rocks*)
(solver-input-directions "input"))))))
(should (= 1514285714288
(solver-height-reached drops history-eg
max-period-window)))
(should (= 1561739130391
(solver-height-reached drops history-my
max-period-window))))))
|
