Initial commit

2021/day16/day16.scm

@@ -0,0 +1,127 @@
+(import (chicken io)
+	(chicken format)
+	srfi-1
+	matchable)
+
+(define (read-input #!optional (port (current-input-port)))
+  (read-line port))
+
+(define (hex-char->bin hex-char)
+  (match hex-char
+    (#\0 '(0 0 0 0))
+    (#\1 '(0 0 0 1))
+    (#\2 '(0 0 1 0))
+    (#\3 '(0 0 1 1))
+    (#\4 '(0 1 0 0))
+    (#\5 '(0 1 0 1))
+    (#\6 '(0 1 1 0))
+    (#\7 '(0 1 1 1))
+    (#\8 '(1 0 0 0))
+    (#\9 '(1 0 0 1))
+    (#\A '(1 0 1 0))
+    (#\B '(1 0 1 1))
+    (#\C '(1 1 0 0))
+    (#\D '(1 1 0 1))
+    (#\E '(1 1 1 0))
+    (#\F '(1 1 1 1))))
+
+(define (hex->bin hex)
+  (concatenate (map hex-char->bin (string->list hex))))
+
+(define (bin->number bin)
+  (let lp ((acc 0)
+	   (l bin))
+    (if (null? l)
+	acc
+	(lp (+ (* acc 2) (car l)) (cdr l)))))
+
+(define-record val
+  version num)
+
+(set! (record-printer val)
+  (lambda (x out)
+    (fprintf out "#,(val (ver ~S) ~S)" (val-version x) (val-num x))))
+
+(define-record op
+  version type args)
+
+(set! (record-printer op)
+  (lambda (x out)
+    (fprintf out "#,(op (ver ~S) (type ~S) ~S)" (op-version x) (op-type x) (op-args x))))
+
+(define (decode-version raw)
+  (values (bin->number (take raw 3))
+	  (drop raw 3)))
+
+(define (decode-type-id raw)
+  (values (bin->number (take raw 3))
+	  (drop raw 3)))
+
+(define (decode-num raw bits)
+  (let ((new-bits (take (cdr raw) 4)))
+    (if (= 1 (car raw))
+	(decode-num (drop raw 5) (append bits new-bits))
+	(values (bin->number (append bits new-bits)) (drop raw 5)))))
+
+(define (decode-op version type-id raw)
+  (if (zero? (car raw))
+      (let* ((subpackets-length (bin->number (take (cdr raw) 15)))
+	     (subpackets-raw (take (drop raw 16) subpackets-length)))
+	(let-values (((subpackets _) (decode-all-packets subpackets-raw)))
+	  (values (make-op version type-id subpackets) (drop raw (+ 16 subpackets-length)))))
+      (let ((subpackets-count (bin->number (take (cdr raw) 11))))
+	(let lp ((i subpackets-count)
+		 (packets '())
+		 (raw (drop raw 12)))
+	  (if (zero? i)
+	      (values (make-op version type-id (reverse packets)) raw)
+	      (let-values (((packet new-raw) (decode-packet raw)))
+		(lp (sub1 i) (cons packet packets) new-raw)))))))
+
+(define (decode-packet raw)
+  (let*-values (((version raw) (decode-version raw))
+		((type-id raw) (decode-type-id raw)))
+    (if (= type-id 4)
+	(let-values (((num raw) (decode-num raw '())))
+	  (values (make-val version num) raw))
+	(let-values (((op new-raw) (decode-op version type-id raw)))
+	  (values op new-raw)))))
+
+(define (decode-all-packets raw)
+  (let lp ((packets '())
+	   (raw raw))
+    (if (every zero? raw)
+	(values (reverse packets) raw)
+	(let-values (((packet new-raw) (decode-packet raw)))
+	  (lp (cons packet packets) new-raw)))))
+
+(define (version-sum packets)
+  (let lp ((versions '())
+	   (packets packets))
+    (match packets
+      (() (apply + versions))
+      ((($ val ver _) . rest)
+       (lp (cons ver versions) rest))
+      ((($ op ver _ args) . rest)
+       (lp (cons ver versions) (append args rest))))))
+
+(define (part1 hex-str)
+  (version-sum (decode-all-packets (hex->bin hex-str))))
+
+(define (eval-packet packet)
+  (match packet
+    (($ val _ num) num)
+    (($ op _ 0 args) (apply + (map eval-packet args)))
+    (($ op _ 1 args) (apply * (map eval-packet args)))
+    (($ op _ 2 args) (apply min (map eval-packet args)))
+    (($ op _ 3 args) (apply max (map eval-packet args)))
+    (($ op _ 5 args) (if (apply > (map eval-packet args)) 1 0))
+    (($ op _ 6 args) (if (apply < (map eval-packet args)) 1 0))
+    (($ op _ 7 args) (if (apply = (map eval-packet args)) 1 0))))
+
+(define (part2 hex-str)
+  (eval-packet (decode-packet (hex->bin hex-str))))
+
+(let ((hex (read-input)))
+  (print (part1 hex))
+  (print (part2 hex)))