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.
21 KiB
21 KiB
Solution to p10
This problem was quite hard. I think that probably I was hit hard by the inefficiencies of elisp. Anyways. here it is:
(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))
(setq machines (--map (-rotate 1 (cdr it)) data))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.
(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))For part 2, the same approach would blow the stack even for the test input. As a first attempt, go depth first and memoize for the win… This works for the test input, but appears to take forever for the true input.
(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))33
So we need to stop being a brute and realize that this is a linear algebra problem. Gauss elimination could work, but in general leads to matrices with negative entries.
These are some auxiliary functions to create and deal with matrices I leave here a row-reducing routine for posterity, but I am not using it in the actual solution
(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))) (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))Instead of using row-reduction we sort the buttons and the list of buttons in a (arbitrary) way that makes the matrix "triangular". The sorting is what I thought would be a good idea, but possibly it is inefficient in the long run. In any case, it does what it needs to, which is present the matrix in a way that has zeros in the bottom left corner.
(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)))))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. The following implementation works, but it may blow the stack if the matrix is particularly degenerate; this is a breadth first implementation that I use to check other solutions
(defun test-soln (matrix soln)
(equal (-map 'car matrix) (-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 (>= current-row 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) max-soln -1))))
soln)
last-used-button button))))
(setq soln (--filter (= a (advent/dot it rrow)) soln)
current-row (1- current-row)))
(push soln solutions-tree)
))
soln))solve-well-ordered
Breadth first may yield too many vectors to check. Subdivide into chunks if this happens and go breadth first on each chunk separately. The size at which we chunkize is arbitrary
(defun create-chunks (n list)
(let ((result nil))
(while list
(push (-take n list) result)
(setq list (-drop n list)))
result))
(defun solve-well-ordered-chunks (matrix)
;; we start from the last row
(let* ((soln-acc nil)
(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)))
(soln-chunks nil))
(while (or (>= current-row 0) soln-chunks)
(message (format "%d %d - %d" last-used-button (length soln) (length soln-chunks)))
(when (< current-row 0)
(let ((chunk (pop soln-chunks)))
(push soln soln-acc)
(setq current-row (pop chunk)
last-used-button (pop chunk)
soln (pop chunk))))
;; chunkize here
(when (> (length soln) 50000)
(let* ((chunks (create-chunks 8000 soln))
(new-soln (car chunks))
(chunks-to-store (--map (list current-row last-used-button it) (cdr chunks))))
(setq soln new-soln
soln-chunks (append chunks-to-store soln-chunks))))
(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) max-soln -1))))
soln)
last-used-button button))))
(setq soln (--filter (= a (advent/dot it rrow)) soln)
current-row (1- current-row)))))
(push soln soln-acc)
(apply #'append soln-acc)))Even with the chunks, the bruteforcing was not going through. I now solve mod a prime for a few primes and then use the Chinese Remainder Theorem to go back to ℤ. This routine solves the matrix over ℤ_prime
(defun solve-well-ordered-chunks-mod (matrix prime)
;; we start from the last row
(let* ((soln-acc nil)
(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)))
(soln-chunks nil))
(while (or (>= current-row 0) soln-chunks)
(message (format "%d %d - %d" last-used-button (length soln) (length soln-chunks)))
(when (< current-row 0)
(let ((chunk (pop soln-chunks)))
(push soln soln-acc)
(setq current-row (pop chunk)
last-used-button (pop chunk)
soln (pop chunk))))
;; chunkize here
(when (> (length soln) 50000)
(let* ((chunks (create-chunks 8000 soln))
(new-soln (car chunks))
(chunks-to-store (--map (list current-row last-used-button it) (cdr chunks))))
(setq soln new-soln
soln-chunks (append chunks-to-store soln-chunks))))
(let* ((row (nth current-row matrix))
(a (mod (car row) prime))
(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 (mod (- a correction) prime)))
(-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 (-map (lambda (candidate)
(-replace-at button candidate it))
(-iota prime))
soln)
last-used-button button))))
(setq soln (--filter (= (mod a prime) (mod (advent/dot it rrow) prime)) soln)
current-row (1- current-row)))))
(push soln soln-acc)
(apply #'append soln-acc)))solve-well-ordered-chunks-mod
This is a recursive implementation, but it is super-slow and I ended up not using it
(defun solve-well-ordered-recursively (matrix)
(if (not matrix) t
(setq matrix (-distinct matrix))
(let* ((number-of-buttons (1- (length (car matrix))))
(row (-last-item matrix))
(a (car row))
(rrow (cdr row))
(possible-indices (--find-indices (not (zerop it)) rrow)))
(if (not possible-indices)
(when (zerop a)
(solve-well-ordered-recursively (-butlast matrix)))
(let ((possible-solutions
(if (= 1 (length possible-indices)) (list a)
(let* ((button (-last-item possible-indices))
(max-soln (-min (-non-nil (-map (lambda (row)
(when (= 1 (nth button (cdr row))) (car row)))
matrix)))))
(when (>= max-soln 0) (-iota (1+ max-soln)))))))
(-non-nil (-mapcat (lambda (a)
(let* ((new-car (--map (if (= 1 (-last-item it)) (- (car it) a) (car it)) matrix)))
(when (--every (>= it 0) new-car)
(let* ((new-matrix (-map '-butlast (--map-indexed (cons (nth it-index new-car) (cdr it)) matrix))) ; remove one column
(next (solve-well-ordered-recursively new-matrix)))
(when next (if (listp next)
(--map (cons a it) next)
(list (list a))))))))
possible-solutions)))))))
(--map (cons 'a it) '((1) (1 2) (1 3)))Here we compute solutions modulo 2 3 5 and 7, then try to check possible solutions in ℤ by hand. Computing solutions modulo a prime is far cheaper bruteforcing.
(setq rainbow (-annotate (lambda (n) (--map (mod n it) '(2 3 5 7))) (-iota (* 2 3 5 7))))
(defun process-machine (machine)
(let* ((matrix (-distinct (matrix-buttons (fix-machine machine))))
(solmod (--map (solve-well-ordered-chunks-mod matrix it) '(2 3 5 7)))
(solns nil)
(numcand (apply '* (-map 'length solmod)))
(count 0))
;; Oh Programming Gods, have mercy of me for I have sinned
(-each (car solmod)
(lambda (a)
(-each (cadr solmod)
(lambda (b)
(-each (caddr solmod)
(lambda (c)
(-each (cadddr solmod)
(lambda (d)
(let ((cand (--map (cdr (assoc it rainbow)) (-zip-lists a b c d))))
(message (format "machine %d. Verifying %d / %d - found %d" machine-id (setq count (1+ count)) numcand (length solns)))
(when (test-soln matrix cand) (push cand solns)))))))))))
solns))
(setq machine-id -1)
(-sum (--map (progn
(setq machine-id (1+ machine-id))
(-min (-map '-sum (process-machine it))))
machines))16474