wilderjds
/
advent-2025
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
48 Commits
1 Branch
0 Tags
868 KiB
 
Tag: Branch: Tree: 0392d65d50
Branches Tags
${ item.name }
Create tag ${ searchTerm }
Create branch ${ searchTerm }
from '0392d65d50'
${ noResults }
advent-2025/p10/p10.org

404 lines
16 KiB
Raw Blame History

#+title: Solution to p10
This problem is pretty hard. I have not yet completely understood the
linear algebra behind it.
#+begin_src emacs-lisp :results none
(with-temp-buffer
(insert-file-contents "input")
(advent/replace-multiple-regex-buffer
'(("," . " ")
("^" . "(")
("$" . ")")
("\\[" . "\"")
("\\]" . "\"")
("{" . "(")
("}" . ")")
))
(goto-char (point-min))
(insert "(setq data '(")
(goto-char (point-max))
(insert "))")
(eval-buffer))
#+end_src
For part 1 we do not need the last item This is a linear algebra
problem in characteristic 2; we are essentially bruteforcing the
vector space; we easily succeed.
For part 2, the same approach blows the stack even for the test input
#+begin_src emacs-lisp
(setq machines (--map (-rotate 1 (cdr it)) data))
(defun apply-button (joltage button)
(--map-indexed (if (-contains-p button it-index) (- it 1) it) joltage))
(defun good-buttons (machine)
(-filter (lambda (button) (--every (< 0 (nth it (car machine))) button)) (cdr machine)))
(defun solve-machines (machines)
(-mapcat (lambda (machine)
(if (= 0 (-sum (car machine))) (list machine)
(--map (cons it (cdr machine)) (--map (apply-button (car machine) it) (good-buttons machine)))))
machines ))
(-iterate 'solve-machines (list (car machines)) 19)
#+end_src
Instead, go depth first and memoize for the win… This works for the
test input, but takes forever for the true input.
#+begin_src emacs-lisp
(setq machines (--map (-rotate 1 (cdr it)) data)
machines (--map (cons (car it) (--sort (> (length it) (length other)) (cdr it))) machines))
(defun apply-button (joltage button)
(--map-indexed (if (-contains-p button it-index) (- it 1) it) joltage))
(defun good-buttons (machine)
(-filter (lambda (button) (--every (< 0 (nth it (car machine))) button)) (cdr machine)))
(defun or-min (l)
(when l (-min l)))
(defun nil-1+ (l)
(when l (1+ l)))
(defun solve-machine (machine)
(when machine
(if (= 0 (-sum (car machine))) 0
(nil-1+ (solve-machine (-first 'solve-machine (--map (cons it (cdr machine)) (--map (apply-button (car machine) it) (good-buttons machine)))))))))
(memoize 'solve-machine)
(-sum (-map 'solve-machine machines))
#+end_src
#+RESULTS:
: 33
So we need to stop being a brute and realize that this is a linear
algebra problem. Gauss elimination to the rescue.
There is a little complication, since the matrices involved are
degenerate and we have constraints;
#+begin_src emacs-lisp :results none
(setq machines (--map (-rotate 1 (cdr it)) data))
#+end_src
These are some auxiliary functions to create and deal with matrices
#+begin_src emacs-lisp :results none
(defun matrix-buttons (machine)
"Takes MACHINE and returns the corresponding augmented matrix of the
linear system. The vector of constants is the first column vector
instead of the last column as usual(it is more idiomatic this way)"
(--map-indexed (cons it (--map (if (-contains-p it it-index) 1 0)
(cdr machine)))
(car machine)))
;; These are convenience functions that we will use for row-reducing
(defun find-pivot (row index)
(let ((p (--find-index (not (= it 0)) (-drop index row))))
(when p (+ p index))))
(defun swap-indices (i j list)
(if (= i j) list
(let ((el-i (nth i list))
(el-j (nth j list)))
(-replace-at j el-i (-replace-at i el-j list)))))
(defun subtract-indices (λ i j list)
"Subtracts λ× element i from element j"
(let ((el-i (nth i list))
(el-j (nth j list)))
(-replace-at j (- el-j (* λ el-i)) list)))
(defun flip-index (i list)
"Flip the sign of element i"
(let ((el-i (nth i list)))
(-replace-at i (* -1 el-i) list)))
(defun subtract-composite (lambdas i list)
(--each (-iota (length lambdas))
(setq list (subtract-indices (nth it lambdas) i it list)))
list)
; This is a routine for row-reducing the augmented matrix
(defun row-reduce (matrix)
(let* ((rMt (apply '-zip-lists matrix)) ;transpose
(base-index 0))
; here we cannot use -map, since we are changing the matrix as we
; go
(--each (-iota (1- (length rMt)) 1) ;skip over the constant
(let* ((original-row (nth it rMt))
(pivot-index (find-pivot original-row base-index)))
(when pivot-index
(setq rMt (--map (swap-indices base-index pivot-index it) rMt))
(let* ((pivot-coeff (nth pivot-index original-row)))
(when (< pivot-coeff 0)
(setq rMt (--map (flip-index base-index it) rMt)))
(if (not (= 1 (abs pivot-coeff))) (setq pivot-coeff (* 1.0 pivot-coeff)))
(let* ((lambdas (append (-repeat (1+ base-index) 0)
(-drop (1+ base-index) (nth it rMt))))
(lambdas-corrected (--map (/ it (abs pivot-coeff)) lambdas)))
(setq rMt (--map (subtract-composite lambdas-corrected base-index it) rMt)
base-index (1+ base-index)))))))
(apply '-zip-lists rMt)))
#+end_src
#+RESULTS:
: row-reduce
#+begin_src emacs-lisp
(defun set-distance (a b)
(length (-difference b a)))
(defun -min-or-0 (list)
(if (not list) 0
(-min list)))
(defun trip-value (list &optional base)
(let ((n (* 1.0 (length list))))
(--map (+ (set-distance base it)
(/ (-min-or-0 (--remove (= 0 it) (-map (lambda (new)
(set-distance (-union base it) new))
list)))
n))
list)))
(defun sort-re-trip-value (list &optional base)
(-map 'cdr (--sort (< (car it) (car other)) (-zip-pair (trip-value list base) list))))
(defun sort-recursively (list &optional base)
(when list
(let* ((step (sort-re-trip-value list base))
(top (car step))
(bottom (cdr step)))
(cons top
(sort-recursively bottom (-union top base))))))
(defun fix-machine (machine)
(let* ((machine-1 (cons (car machine) (sort-recursively (cdr machine))))
(sorted (-reduce '-union (cdr machine-1)))
(permutation (-grade-up '< sorted)))
(cons (-select-by-indices sorted (car machine-1))
(--map (--map (nth it permutation) it) (cdr machine-1)))))
(matrix-buttons (cadr machines))
; (-distinct
(matrix-buttons (fix-machine (nth 1 machines)))
;)
#+end_src
#+RESULTS:
| 51 | 1 | 0 | 0 | 0 | 0 | 1 | 0 | 1 | 0 | 1 |
| 74 | 1 | 1 | 1 | 1 | 0 | 0 | 0 | 1 | 0 | 1 |
| 72 | 1 | 1 | 1 | 1 | 1 | 0 | 0 | 0 | 1 | 0 |
| 31 | 0 | 1 | 0 | 1 | 0 | 0 | 0 | 0 | 0 | 1 |
| 49 | 0 | 0 | 1 | 0 | 1 | 0 | 1 | 1 | 0 | 0 |
| 77 | 0 | 0 | 0 | 1 | 0 | 1 | 1 | 1 | 1 | 1 |
| 38 | 0 | 0 | 0 | 0 | 1 | 0 | 0 | 0 | 1 | 1 |
| 61 | 0 | 0 | 0 | 0 | 0 | 1 | 1 | 1 | 1 | 1 |
#+begin_src emacs-lisp
(setq solutions-tree nil)
(solve-well-ordered (-distinct (matrix-buttons (fix-machine (nth 1 machines)))))
#+end_src
#+RESULTS:
#+begin_src emacs-lisp
; (-min (-map '-sum (solve-well-ordered (matrix-buttons (fix-machine (cadr machines))))))
solutions-tree
#+end_src
#+RESULTS:
This is the tricky part; we want solve the row-reduced form, but we
need to be careful with our choices if we have more than one
possibility
#+begin_src emacs-lisp
(defun find-possible-indices (matrix i)
(let* ((row (nth i matrix))
(next-row (nth (1+ i) matrix))
(i )
(j (if next-row (--find-index (not (= 0 it)) (cdr next-row))
(1- length row))))
(-iota (- j i) i)))
(defun solve-row-reduced (matrix)
;; we start from the last row
(let* ((soln (list (-repeat (1- (length (car matrix))) 0)))
(last-used-button (length (car soln)))
(current-row (1- (length matrix))))
(while (<= 0 current-row)
(let* ((row (nth current-row matrix))
(a (car row))
(i (--find-index (not (= 0 it)) (cdr row))))
(if i
(let ((possible-indices (--filter (not (= 0 (nth it (cdr row))))
(-iota (- last-used-button i) i))))
(if (= 1 (length possible-indices)) ;no choices here, easy
(setq soln (-non-nil (--map (let* ((correction (advent/dot it (-replace-at i 0 (cdr row))))
(corrected-a (- a correction))
(pushes (/ corrected-a (nth i (cdr row)))))
(unless (< pushes 0) (-replace-at i pushes it)))
soln))
last-used-button i
current-row (1- current-row))
;;otherwise, we create a number of solutions
(let* ((button (-last-item possible-indices)))
(setq soln (--mapcat (let* ((correction (advent/dot it (-replace-at i 0 (cdr row))))
(corrected-a (- a correction))
(max-soln (/ corrected-a (nth button (cdr row)))))
(if (< max-soln 0) (list it)
(-map (lambda (candidate) (-replace-at button candidate it)) (-iota (1+ (round max-soln))))))
soln)
last-used-button button))))
(setq current-row (1- current-row)))))
soln))
(setq solutions-tree nil)
#+end_src
This implementation works, but I need to make it recursive, so that I can memoize
#+begin_src emacs-lisp
(defun test-soln (matrix soln)
(-map (lambda (row) (advent/dot (cdr row) soln)) matrix))
(defun solve-well-ordered (matrix)
;; we start from the last row
(let* ((number-of-buttons (1- (length (car matrix))))
(soln (list (-repeat number-of-buttons 0)))
(last-used-button number-of-buttons)
(current-row (1- (length matrix))))
(while (> last-used-button 0)
(message (format "%d %d" last-used-button (length soln)))
;; (setq soln (--map (-min-by (lambda (a b) (< (-sum a) (-sum b))) (cdr it)) (--group-by (test-soln matrix it) soln)))
(let* ((row (nth current-row matrix))
(a (car row))
(rrow (cdr row))
(i (--find-index (not (zerop it)) (-take last-used-button rrow))))
(if i
(let ((possible-indices (--filter (not (zerop (nth it rrow)))
(-iota (- last-used-button i) i))))
(if (= 1 (length possible-indices)) ;no choices here, easy
(setq soln (-non-nil (--map (let* ((correction (advent/dot it rrow))
(corrected-a (- a correction)))
(unless (< corrected-a 0)
(-replace-at i corrected-a it)))
soln))
last-used-button i
current-row (1- current-row)) ; this needs to change
;;otherwise, we create a number of solutions
(let* ((button (-last-item possible-indices)))
(setq soln (--mapcat (let* ((max-soln (-min (-non-nil (-map (lambda (row)
(when (= 1 (nth button (cdr row)))
(- (car row) (advent/dot it (cdr row)))))
matrix)))))
(unless (< max-soln 0)
(-map (lambda (candidate) (-replace-at button candidate it)) (-iota (1+ max-soln)))))
soln)
last-used-button button))))
(setq soln (--filter (= a (advent/dot it rrow)) soln)
current-row (1- current-row)))
(push soln solutions-tree)
))
soln))
#+end_src
#+RESULTS:
: minimal-pushes
Try to do it recursively
#+begin_src emacs-lisp
(defun test-soln (matrix soln)
(-map (lambda (row) (advent/dot (cdr row) soln)) matrix))
(defun solve-well-ordered-recursively (matrix)
(let* ((number-of-buttons (1- (length (car matrix))))
(soln (list (-repeat number-of-buttons 0)))
(last-used-button number-of-buttons)
(current-row (1- (length matrix))))
(while (> last-used-button 0)
(message (format "%d %d" last-used-button (length soln)))
;; (setq soln (--map (-min-by (lambda (a b) (< (-sum a) (-sum b))) (cdr it)) (--group-by (test-soln matrix it) soln)))
(let* ((row (nth current-row matrix))
(a (car row))
(rrow (cdr row))
(i (--find-index (not (zerop it)) (-take last-used-button rrow))))
(if i
(let ((possible-indices (--filter (not (zerop (nth it rrow)))
(-iota (- last-used-button i) i))))
(if (= 1 (length possible-indices)) ;no choices here, easy
(setq soln (-non-nil (--map (let* ((correction (advent/dot it rrow))
(corrected-a (- a correction)))
(unless (< corrected-a 0)
(-replace-at i corrected-a it)))
soln))
last-used-button i
current-row (1- current-row)) ; this needs to change
;;otherwise, we create a number of solutions
(let* ((button (-last-item possible-indices)))
(setq soln (--mapcat (let* ((max-soln (-min (-non-nil (-map (lambda (row)
(when (= 1 (nth button (cdr row)))
(- (car row) (advent/dot it (cdr row)))))
matrix)))))
(unless (< max-soln 0)
(-map (lambda (candidate) (-replace-at button candidate it)) (-iota (1+ max-soln)))))
soln)
last-used-button button))))
(setq soln (--filter (= a (advent/dot it rrow)) soln)
current-row (1- current-row)))
(push soln solutions-tree)
))
soln))
#+end_src
try this. create a distance in the space of buttons given by the number of elements in the difference
#+begin_src emacs-lisp
;; now, this is correct, but we need a positive solution that has
;; fewest button presses possible.
(defun rank (matrix)
(length (-non-nil (--map (--find-index (not (= 0 it)) (cdr it)) matrix))))
(defun matrix-appl (matrix vector)
(--map (advent/dot it vector) matrix))
(defun solution-p (machine candidate)
(--every (= 0 it) (matrix-appl (matrix-buttons machine) (cons -1 candidate))))
(defun solve--machine (machine)
(let ((candidate (solve-row-reduced (row-reduce (matrix-buttons machine)))))
(and (--every (= (round it) it) candidate)
(--every (>= it 0) candidate)
(solution-p machine candidate) candidate)))
(defun solve-machine (machine)
(let* ((reduced-mat (row-reduce (matrix-buttons machine)))
(rank (rank reduced-mat))
(bunch (--map (cons (car machine) it)
(--filter (= rank (length it))
(-powerset (cdr machine))))))
(-min (-map '-sum (-non-nil (-map 'solve--machine bunch))))))
(-first (not ))
(-sum (-map 'solve-machine machines))
#+end_src
#+RESULTS:
: 33