wilderjds
/
advent-2025
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

[p10] Refactor the row-reduction code

Browse Source
master
Jacopo De Simoi 6 months ago
parent c5179fed61
commit 47e567b8f8
1 changed files with 131 additions and 139 deletions
Whitespace
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Unified View
Diff Options
Show Stats Download Patch File Download Diff File
  1. 270
      p10/p10.org

270
p10/p10.org
Unescape View File

@ -4,7 +4,7 @@ This problem is pretty hard. I have not yet completely understood the
linear algebra behind it. linear algebra behind it.
#+begin_src emacs-lisp :results none #+begin_src emacs-lisp :results none
(with-temp-buffer (with-temp-buffer
(insert-file-contents "input") (insert-file-contents "input-test")
(advent/replace-multiple-regex-buffer (advent/replace-multiple-regex-buffer
'(("," . " ") '(("," . " ")
("^" . "(") ("^" . "(")
@ -24,39 +24,8 @@ linear algebra behind it.
For part 1 we do not need the last item This is a linear algebra For part 1 we do not need the last item This is a linear algebra
problem in characteristic 2; we are essentially bruteforcing the problem in characteristic 2; we are essentially bruteforcing the
vector space; we easily succeed. vector space; we easily succeed.
#+begin_src emacs-lisp
(defun zero-one (n)
(if (eq n ?#) 1 0))
(setq cleanedup-data (--map (cons (-map #'zero-one
(advent/split-string-into-char-list (car it)))
(cdr it))
data))
(setq machines (--map (-drop-last 1 it) cleanedup-data))
(defun to-bin (l)
(-sum (--map-indexed (* it (expt 2 it-index)) l)))
(defun to-mask (l)
(-sum (--map (expt 2 it) l)))
(setq mask-machines (--map (cons (to-bin (car it))
(-map #'to-mask (cdr it)))
machines))
(-sum
(-map (lambda (machine)
(-min (-map 'length (--filter (= (car machine) (apply 'logxor it))
(-powerset (cdr machine))))))
mask-machines))
#+end_src
#+RESULTS:
: 7
This approach blows the stack even for the test input For part 2, the same approach blows the stack even for the test input
#+begin_src emacs-lisp #+begin_src emacs-lisp
(setq machines (--map (-rotate 1 (cdr it)) data)) (setq machines (--map (-rotate 1 (cdr it)) data))
@ -73,11 +42,10 @@ This approach blows the stack even for the test input
machines )) machines ))
(-iterate 'solve-machines (list (car machines)) 19) (-iterate 'solve-machines (list (car machines)) 19)
#+end_src #+end_src
Instead, go depth first and memoize for the win… except that Instead, go depth first and memoize for the win… This works for the
it does not work for the true input test input, but takes forever for the true input.
#+begin_src emacs-lisp #+begin_src emacs-lisp
(setq machines (--map (-rotate 1 (cdr it)) data) (setq machines (--map (-rotate 1 (cdr it)) data)
machines (--map (cons (car it) (--sort (> (length it) (length other)) (cdr it))) machines)) machines (--map (cons (car it) (--sort (> (length it) (length other)) (cdr it))) machines))
@ -106,113 +74,137 @@ it does not work for the true input
#+RESULTS: #+RESULTS:
: 33 : 33
So we need to stop being a brute and realize that this So we need to stop being a brute and realize that this is a linear
is a linear algebra problem. Gauss elimination to the rescue 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 #+begin_src emacs-lisp :results none
(setq machines (--map (-rotate 1 (cdr it)) data) (setq machines (--map (-rotate 1 (cdr it)) data) machines)
machines (--map (cons (car it) (--sort (> (length it) (length other)) (cdr it))) machines)) #+end_src
These are some auxiliary functions to create and deal with matrices
#+begin_src emacs-lisp
(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)))
(assert (= 1 (abs 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 #+end_src
#+RESULTS:
| 10 | 1 | 1 | 1 | 0 |
| -1 | 0 | 1 | 0 | -1 |
| 5 | 0 | 0 | 1 | 0 |
| 0 | 0 | 0 | 0 | 0 |
| 0 | 0 | 0 | 0 | 0 |
| 0 | 0 | 0 | 0 | 0 |
arst
#+RESULTS:
| 7 | 1 | 1 | 0 | 1 | 0 | 0 |
| 5 | 0 | 1 | 0 | 0 | 0 | 1 |
| 4 | 0 | 0 | 1 | 1 | 1 | 0 |
| 3 | 0 | 0 | 0 | 0 | 1 | 1 |
#+begin_src emacs-lisp #+begin_src emacs-lisp
;; Now take a machine, create an "augmented" matrix to be reduced (defun solve-row-reduced (matrix)
;; Notice that the "augmentation" is the first column for ;; we start from the last row
;; reasons of making things more idiomatic (let ((soln (-repeat (length (cdar matrix)) 0)))
(--each (-iota (length matrix) (- (length matrix) 1) -1)
(defun matrix-buttons (machine) (let* ((row (nth it matrix))
(--map-indexed (cons it (--map (if (-contains-p it it-index) 1 0) (cdr machine))) (car machine))) (a (car row))
(i (--find-index (not (= 0 it)) (cdr row))))
(defun find-pivot (row index) (when i
(let ((p (--find-index (not (= it 0)) (-drop index row)))) (setq correction (advent/dot soln (append (-repeat (1+ i) 0) (drop (1+ i) (cdr row))))
(when p (+ p index)))) soln (-replace-at i (/ (- a correction) (nth i (cdr row))) soln)))))
soln))
(defun swap-indices (i j list)
(if (= i j) list (solve-row-reduced (row-reduce (matrix-buttons (caddr machines))))
(let ((el-i (nth i list)) ;; now, this is correct, but we need a positive solution that has
(el-j (nth j list))) ;; fewest button presses possible.
(-replace-at j el-i (-replace-at i el-j list)))))
(defun rank (matrix)
(defun subtract-indices (λ i j list) (length (-non-nil (--map (--find-index (not (= 0 it)) (cdr it)) matrix))))
"Subtracts λ× element i from element j"
(let ((el-i (nth i list)) (defun matrix-appl (matrix vector)
(el-j (nth j list))) (--map (advent/dot it vector) matrix))
(-replace-at j (- el-j (* λ el-i)) list)))
(defun solution-p (machine candidate)
(defun subtract-composite (lambdas i list) (--every (= 0 it) (matrix-appl (matrix-buttons machine) (cons -1 candidate)))
(--each (-iota (length lambdas)) )
(setq list (subtract-indices (nth it lambdas) i it list))) (setq current-machine nil)
list) (defun solve--machine (machine)
(setq current-machine machine)
;; Here we row-reduce; this is non-unique (let ((candidate (solve-row-reduced (row-reduce (matrix-buttons machine)))))
(defun row-reduce (matrix) (setq canca candidate)
(let* ((v (-map #'car matrix)) ;; vector (and (--every (>= it 0) candidate) (solution-p machine candidate) candidate)))
(rM (-map #'cdr matrix)) ;; reduced matrix
(rMt (apply '-zip-lists rM)) ;transpose (defun solve-machine (machine)
(base 0)) (let* ((reduced-mat (row-reduce (matrix-buttons machine)))
(--each (-iota (length rMt)) (rank (rank reduced-mat))
(let ((pivot (find-pivot (nth it rMt) base))) (bunch (--map (cons (car machine) it)
(when pivot (--filter 'identity
(setq rMt (-map (lambda (row) ;(<= rank (length it))
(swap-indices base pivot row)) (-powerset (cdr machine))))))
rMt) (-min (-map '-sum (-non-nil (-map 'solve--machine bunch))))
v (swap-indices base pivot v)) ))
;; hopefully we never have to divide
;; now we have to clean the other bits (-sum (-map 'solve-machine machines))
; (fwq) current-machine
;; this is the pivot (solve--machine machine)
(let* ((pivot-coeff (nth base (nth it rMt))) canca
(lambdas (append (-repeat (1+ base) 0) (-drop (1+ base) (nth it rMt))))
(lambdas-corrected (--map (/ it (* 1 pivot-coeff)) lambdas)))
(setq rMt (--map (subtract-composite lambdas-corrected base it) rMt)
v (subtract-composite lambdas-corrected base v)))
(setq base (1+ base)))))
(apply '-zip-lists (cons v rMt))))
(defun solve-row-reduced (matrix)
;; we start from the last row
(let ((soln (-repeat (length (cdar matrix)) 0)))
(--each (-iota (length matrix) (- (length matrix) 1) -1)
(let* ((row (nth it matrix))
(a (car row))
(i (--find-index (not (= 0 it)) (cdr row))))
(when i
(setq correction (advent/dot soln (append (-repeat (1+ i) 0) (drop (1+ i) (cdr row))))
soln (-replace-at i (/ (- a correction) (nth i (cdr row))) soln)))))
soln))
(solve-row-reduced (row-reduce (matrix-buttons (caddr machines))))
;; 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)))
)
(setq current-machine nil)
(defun solve--machine (machine)
(setq current-machine machine)
(let ((candidate (solve-row-reduced (row-reduce (matrix-buttons machine)))))
(setq canca candidate)
(and (--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 'identity
;(<= rank (length it))
(-powerset (cdr machine))))))
(-min (-map '-sum (-non-nil (-map 'solve--machine bunch))))
))
(-sum (-map 'solve-machine machines))
current-machine
(solve--machine machine)
canca
#+end_src #+end_src
#+RESULTS: #+RESULTS:

Write Preview
Loading…
Cancel
Save