127 lines
3.6 KiB
Scheme
127 lines
3.6 KiB
Scheme
(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)))
|