From 757b98fb30e75d7698a0986184d0303224db156c Mon Sep 17 00:00:00 2001
From: Prefetch
Date: Tue, 26 Mar 2024 21:41:32 +0100
Subject: Publish days 6-10

---
 08/lib.scm | 105 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 105 insertions(+)
 create mode 100644 08/lib.scm

(limited to '08/lib.scm')

diff --git a/08/lib.scm b/08/lib.scm
new file mode 100644
index 0000000..6e402c3
--- /dev/null
+++ b/08/lib.scm
@@ -0,0 +1,105 @@
+(library (lib)
+  (export solve-part1 solve-part2)
+  (import (chezscheme))
+
+  ; Split list at first delimiter into `prefix' and `suffix'
+  ; Return value is a pair like `((p r e f i x) s u f f i x)'
+  (define (list-split-left delimiter? xs)
+    (let loop ((prefix '())
+               (suffix xs))
+      (if (null? suffix)
+        (cons prefix suffix)
+        (let ((x (car suffix)))
+          (if (delimiter? x)
+              ; Found first delimiter, so return immediately
+              (cons prefix (cdr suffix))
+              ; `x' isn't a delimiter, so append it to `prefix'
+              (loop (append prefix (list x)) (cdr suffix)))))))
+
+  ; Split list at given delimiter into list of sublists
+  (define (list-split delimiter? xs)
+    (let loop ((pieces '())
+               (rest xs))
+      (if (null? rest)
+          ; Fix order and remove all empty sublists from output
+          ; (which are caused by consecutive delimiters in `xs')
+          (reverse (remp null? pieces))
+          ; Extract next piece from `rest' and prepend it to `pieces'
+          (let ((next (list-split-left delimiter? rest)))
+            (loop (cons (car next) pieces) (cdr next))))))
+
+  ; Split string at whitespace into list of words
+  (define (string-split str)
+    (map list->string (list-split char-whitespace? (string->list str))))
+
+  ; Evaluate a test of the form: `rval' `test' `rlit'
+  (define (satisfied? rval test rlit)
+    (cond
+      ((string=? test "<" ) (<  rval rlit))
+      ((string=? test "<=") (<= rval rlit))
+      ((string=? test "==") ( = rval rlit))
+      ((string=? test ">=") (>= rval rlit))
+      ((string=? test ">" ) (>  rval rlit))
+      (else (not (= rval rlit)))))
+
+  ; To copy the register state list from one cycle to the next, the usual
+  ; `(apply list xs)' trick isn't good enough, because `xs' contains pairs.
+  (define (list-deep-copy xs)
+    (if (not (pair? xs))
+        xs
+        (cons (list-deep-copy (car xs)) (list-deep-copy (cdr xs)))))
+
+  ; Execute one instruction (`words') given current state (`registers-old')
+  (define (execute words registers-old)
+    ; Make a copy of the input state, to be modified and returned.
+    ; The state is an association list of (register . value) pairs.
+    (define registers-new (list-deep-copy registers-old))
+    ; "Parse" the instruction, which has the following form:
+    ; `wreg' (inc|dec) `wlit' if `rreg' `test' `rlit'
+    (define wreg (list-ref words 0))
+    (define inc? (string=? "inc" (list-ref words 1)))
+    (define wlit (string->number (list-ref words 2)))
+    (define rreg (list-ref words 4))
+    (define test (list-ref words 5))
+    (define rlit (string->number (list-ref words 6)))
+    ; If register `wreg' isn't initialized yet, set it to zero
+    (if (not (assoc wreg registers-old))
+        (set! registers-new (cons (cons wreg 0) registers-new)))
+    ; If register `rreg' isn't initialized yet, set it to zero
+    (if (not (assoc rreg registers-old))
+        (set! registers-new (cons (cons rreg 0) registers-new)))
+    ; Read the values stored in registers `rreg' and `wreg'
+    (let ((wval (cdr (assoc wreg registers-new)))
+          (rval (cdr (assoc rreg registers-new))))
+      (if (satisfied? rval test rlit)
+          ; If the test condition is true, apply the increment/decrement
+          (set-cdr! (assoc wreg registers-new)
+                    (if inc?
+                        (+ wval wlit)
+                        (- wval wlit))))
+      ; Return the new state
+      registers-new))
+
+  ; Execute the "program" and return the history of register states
+  (define (solve-puzzle lines)
+    (let loop ((instructions (map string-split lines))
+               (registers '())
+               (history '()))
+      (if (null? instructions)
+          history
+          (let ((state (execute (car instructions) registers)))
+            (loop (cdr instructions) state (cons state history))))))
+
+  (define (solve-part1 lines)
+    (define history (solve-puzzle lines))
+    (apply max (map cdr (car history))))
+
+  (define (solve-part2 lines)
+    (define history (solve-puzzle lines))
+    (let loop ((states history)
+               (highest -999999))
+      (if (null? states)
+          highest
+          (loop (cdr states) (max highest (apply max (map cdr (car states))))))))
+
+)
-- 
cgit v1.2.3