commit cdd5731e0753015c0ba26ca215f903bbe9708495
parent 0cbda24406ea1bc0e0df476deba80ef905c434b1
Author: Natasha Kerensikova <natgh@instinctive.eu>
Date: Fri, 8 Dec 2023 19:50:34 +0000
Add day 8 frustrating-but-working solution
Diffstat:
| M | 2023/day08.scm | | | 79 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++---- |
1 file changed, 75 insertions(+), 4 deletions(-)
diff --git a/2023/day08.scm b/2023/day08.scm
@@ -61,7 +61,7 @@
(sequence directions network))
(define data (parse all-data (read-string)))
-(write-line (conc "Input: " data))
+;(write-line (conc "Input: " data))
;;;;;;;;;;;;;;;;;
;; First Puzzle
@@ -87,7 +87,9 @@
stop
(add1 acc)))))
-;(write-line (conc "First puzzle: " (count-links-until '() "AAA" "ZZZ" 0)))
+(when (and (hash-table-exists? left-link-table "AAA")
+ (hash-table-exists? left-link-table "ZZZ"))
+ (write-line (conc "First puzzle: " (count-links-until '() "AAA" "ZZZ" 0))))
;;;;;;;;;;;;;;;;;
;; Second Puzzle
@@ -138,6 +140,9 @@
(hash-table-set! next-final-memo state result)
result))))
+(define (next-final-state state)
+ (cadr (next-final! (next-state state))))
+
; position: '(state steps)
(define (update-beyond position min-steps)
(let* ((next-final (next-final! (next-state (car position))))
@@ -154,7 +159,7 @@
(define (update-positions positions)
(let ((min-steps (apply min (map cadr positions)))
(max-steps (apply max (map cadr positions))))
- (write-line (conc "Updating from steps " min-steps "+" (- max-steps min-steps)))
+; (write-line (conc "Updating from steps " min-steps "+" (- max-steps min-steps)))
(map (lambda (position) (if (< (cadr position) max-steps)
(update-beyond position max-steps)
position))
@@ -169,4 +174,70 @@
(define start-positions
(map (lambda (node) (list (cons node (car data)) 0)) start-node-list))
-(answer-2 (map (lambda (x) (update-beyond x 0)) start-positions))
+(define initial-positions
+ (map (lambda (x) (update-beyond x 0)) start-positions))
+
+(define cycle-id-table (make-hash-table))
+(define next-cycle-id 1)
+
+(define (update-cycle-id-table! state from-id to-id until-id)
+; (write-line (conc "update-cycle-id " (car state) "-" (length (cdr state)) " -> " to-id))
+ (let ((prev-id (hash-table-ref cycle-id-table state)))
+ (if (= prev-id from-id)
+ (begin (hash-table-set! cycle-id-table state to-id)
+ (update-cycle-id-table!
+ (next-final-state state) from-id to-id until-id))
+ (assert (= prev-id until-id)))))
+
+(define (cycle-id state)
+ (assert (final-node? (car state)))
+; (write-line (conc "cycle-id " state))
+ (unless (hash-table-exists? cycle-id-table state)
+ (let loop ((cur-state state))
+; (write-line (conc " loop " state))
+ (if (hash-table-exists? cycle-id-table cur-state)
+ (let ((entry (hash-table-ref cycle-id-table cur-state)))
+ (cond ((= entry (- next-cycle-id))
+ (update-cycle-id-table! cur-state
+ (- next-cycle-id)
+ next-cycle-id
+ next-cycle-id)
+ (set! next-cycle-id (add1 next-cycle-id)))
+ ((< 0 entry next-cycle-id)
+ (update-cycle-id-table!
+ state (- next-cycle-id) (- entry) entry))
+ ((< (- cycle-id) entry 0)
+ (update-cycle-id-table!
+ state (- next-cycle-id) entry (- entry))
+ (else (assert #f)))))
+ (begin
+ (hash-table-set! cycle-id-table cur-state (- next-cycle-id))
+ (loop (next-final-state cur-state))))))
+ (hash-table-ref cycle-id-table state))
+
+(define (position->string position)
+ (conc (caar position) "-" (length (cdar position)) "/" (cadr position)))
+
+; I'm making weird assumptions there, let's check them
+(define assert-ok
+ (let assert-loop ((positions initial-positions) (result #t))
+ (if (null? positions)
+ result
+ (let ((next-position (update-beyond (car positions) (cadar positions)))
+ (cur-position (car positions)))
+ (if (and (equal? (caar cur-position) (caar next-position))
+ (equal? (cdar cur-position) (cdar next-position))
+ (= (* 2 (cadr cur-position) (cadr next-position))))
+ (assert-loop (cdr positions) result)
+ (begin
+ (write-line (conc "Assumption mismatch for "
+ (position->string cur-position)
+ " -> "
+ (position->string next-position)))
+ (assert-loop (cdr positions) #f)))))))
+
+; So when all inputs reach a cycle of a single final-position without offset,
+; the result is simply the LCM of all lengths.
+(when assert-ok
+ (write-line (conc "Second puzzle: "
+ (apply lcm (map cadr initial-positions)))))
