AoC '21, Day 16, first problem, rvc

Each packet has a version number; the first half of the problem is to return the sum of all the version numbers.

 $ cat 16a.rkt 
 #lang racket 
  
 (provide 
   (struct-out packet-literal) 
   (struct-out packet-operator) 
  
   parse-input 
   read-input 
   ) 
  
  
 (require 
   "aoc.rkt" 
   ) 
  
  
 (define aoc16a (lambda args 
  
  ; Return the summed packet versions for the first half of the 
  ; sixteenth AoC '21 problem. 
  
  (let-values (((packets bl) (parse-input (apply read-input args)))) 
    (traverse-packets packets)))) 
  
  
 (define (traverse-packets pl) 
  
   ; Return the sum of all the version numbers in the given list of 
   ; packets. 
  
  
   (define (traverse-packet p) 
  
     ; Return the sum of all the version numbers in the given packet. 
  
     (cond 
  
      ((packet-literal? p) 
         (packet-literal-version p)) 
  
      ((packet-operator? p) 
       (+ (packet-operator-version p) 
          (traverse-packets (packet-operator-subpackets p)))) 
  
      (#t 
       (raise-user-error 'traverse-packet "unrecognized packet type")))) 
  
   (foldr + 0 (map traverse-packet pl))) 
  
  
 (define (hex-char->4-bit-list hc) 
  
   ; Return the given hex-digit character as a four-element list of 0s 
   ; and 1s (an exploded nybble). 
  
  
   (define (hex-char->number hdc) 
  
     ; Return the number represented give hex-digit character. 
  
     (let ((hc (char-downcase hdc))) 
       (cond 
        ((and (char<=? #\0 hc) (char<=? hc #\9)) 
         (- (char->integer hc) (char->integer #\0))) 
  
        ((and (char<=? #\a hc) (char<=? hc #\h)) 
         (+ (- (char->integer hc) (char->integer #\a)) 10)) 
  
        (#t 
         (raise-user-error 'hex-char->number "non-hex digit given:  " hdc))))) 
  
  
   (define (number->bit-list d po2) 
  
     ; Taking po2 to be a number of the form 2^n for n > -1, return the 
     ; right-most n + 1 bits of the given number as a list.  If p02 is 
     ; zero, return the empty list. 
  
     (if (zero? po2) 
      '() 
      (let ((next-po2 (quotient po2 2))) 
        (if  (<= po2 d) 
             (cons 1 (number->bit-list (- d po2) next-po2)) 
             (cons 0 (number->bit-list d next-po2)))))) 
  
   (number->bit-list (hex-char->number hc) 8)) 
  
  
 (struct packet-literal (version type value) #:transparent) 
 (struct packet-operator (version type subpackets) #:transparent) 
  
  
 (define (parse-input bl) 
  
   ; Return the values (pl bl) where pl is the list of packets parsed 
   ; from the given bit list, and bl is whatever's left of the given 
   ; bit list after parsing. 
  
   (let loop ((bl bl) (packets '())) 
     (if (< (length bl) 8) 
         (values (reverse packets) bl) 
         (let-values (((b p bl) (parse-packet bl))) 
           (loop bl (cons p packets)))))) 
  
  
 (define (parse-packet bl) 
  
   ; Return the values (b p bl).  If the given bit list has a prefix 
   ; interperable as a packet, b is #t, p is the packet represented by 
   ; the prefix, and bl is the suffix of the given bit list following 
   ; the packet prefix.  If the given bit list doesn't have a prefix 
   ; interperable as a packet, b is #f, p is undefined and bl is the 
   ; given bit list. 
  
   (let-values (((b packet bl) (parse-packet-literal bl))) 
     (if b 
         (values b packet bl) 
         (let-values (((b packet bl) (parse-packet-operator bl))) 
           (if b 
               (values b packet bl) 
               (values #f #f bl)))))) 
  
  
 (define (parse-packet-literal bl) 
  
   ; Return the values (b p bl).  If the given bit list has a prefix 
   ; interperable as a literal packet, b is #t, p is the literal packet 
   ; represented by the prefix, and bl is the suffix of the given bit 
   ; list following the literal-packet prefix.  If the given bit list 
   ; doesn't have a prefix interperable as a literal packet, b is #f, p 
   ; is undefined and bl is the given bit list. 
  
   (let-values (((version bl1) (parse-prefix bl 3))) 
   (let-values (((type bl2) (parse-prefix bl1 3))) 
     (if (= type 4) 
  
         (let loop ((bl bl2) (sum 0)) 
           (let-values (((flag bl) (parse-prefix bl 1))) 
           (let-values (((val bl)  (parse-prefix bl 4))) 
             (let ((sum (+ (* sum 16) val))) 
               (if (zero? flag) 
                   (values #t (packet-literal version type sum) bl) 
                   (loop bl sum)))))) 
  
         (values #f #f bl))))) 
  
  
 (define (parse-packet-operator bl) 
  
   ; Return the values (b p bl).  If the given bit list has a prefix 
   ; interperable as an operator packet, b is #t, p is the operator 
   ; packet represented by the prefix, and bl is the suffix of the 
   ; given bit list following the operator-packet prefix.  If the given 
   ; bit list doesn't have a prefix interperable as an operator packet, 
   ; b is #f, p is undefined and bl is the given bit list. 
  
  
   (define (subpackets-by-packets bl) 
  
     ; Return the values (b p bl).  If the given bit list has a prefix 
     ; interperable as an operator packet, b is #t, p is the operator 
     ; packet represented by the prefix, and bl is the suffix of the 
     ; given bit list following the operator-packet prefix.  If the 
     ; given bit list doesn't have a prefix interperable as an operator 
     ; packet, b is #f, p is undefined and bl is the given bit list. 
  
     (let-values (((packet-count bl) (parse-prefix bl 11))) 
  
       (let loop ((packet-count packet-count) (bl bl) (subpackets '())) 
         (if (zero? packet-count) 
             (values (reverse subpackets) bl) 
             (let-values (((b packet bl) (parse-packet bl))) 
               (loop (- packet-count 1) bl (cons packet subpackets))))))) 
  
  
   (define (subpackets-by-bits bl) 
  
     ; Return the values (spl bl).  If the given bit list has a prefix 
     ; interperable as an operator packet, b is #t, p is the operator 
     ; packet represented by the prefix, and bl is the suffix of the 
     ; given bit list following the operator-packet prefix. 
  
     (let-values (((bits-available bl) (parse-prefix bl 15))) 
  
       (let loop ((bits-read 0) (bl bl) (subpackets '())) 
         (if (= bits-read bits-available) 
             (values (reverse subpackets) bl) 
             (let ((bits-available (length bl))) 
               (let-values (((b packet bl) (parse-packet bl))) 
                 (loop (+ bits-read (- bits-available (length bl))) 
                       bl 
                       (cons packet subpackets)))))))) 
  
  
   (let-values (((version bl1) (parse-prefix bl 3))) 
   (let-values (((type bl2) (parse-prefix bl1 3))) 
     (if (= type 4) 
  
         (values #f #f bl) 
  
         (let-values (((length-type bl) (parse-prefix bl2 1))) 
           (if (zero? length-type) 
  
               (let-values (((subpackets bl) (subpackets-by-bits bl))) 
                 (values #t (packet-operator version type subpackets) bl)) 
  
               (let-values (((subpackets bl) (subpackets-by-packets bl))) 
                 (values #t (packet-operator version type subpackets) bl)))))))) 
  
  
 (define (parse-prefix bl n) 
  
   ; Return the values (s bls), where s is the number represented by 
   ; the first n bits from the bit-list bl (most-significant bit 
   ; leftmost) and bls is the remainder of the list bl when the first n 
   ; elements are removed. 
  
   (when (or (< n 0) (> n (length bl))) 
     (raise-user-error 'parse-prefix 
       "prefix size ~a not in bit-list range [0..~a]" n (length bl))) 
  
   (if (zero? n) 
  
       0 
  
       (let loop ((po2 (expt 2 (- n 1))) (bl bl) (sum 0)) 
  
         (let ((sum (+ sum (* po2 (car bl)))) 
               (po2 (quotient po2 2)) 
               (bl (cdr bl))) 
  
           (if (zero? po2) 
               (values sum bl) 
               (loop po2 bl sum)))))) 
  
  
 (define read-input (lambda arg? 
  
   ; Return the risk-map described by the problem input.  If no 
   ; argument is given, use the contest problem input; otherwise assume 
   ; the argument is the string representation of a problem input. 
  
   (flatten                      
    (map 
  
     (lambda (l) 
       (map 
         hex-char->4-bit-list 
         (string->list (car l)))) 
  
     (car (aoc-read-input (if (null? arg?) 16 (car arg?)))))))) 
  
  
 (define example-a1-input "D2FE28") ; a literal packet 
 (define example-a1-result (digit-string->digit-list "110100101111111000101000")) 
  
 (define example-a2-input "38006F45291200") 
 (define example-a2-result 
   (digit-string->digit-list "00111000000000000110111101000101001010010001001000000000")) 
  
 (define example-a3-input "EE00D40C823060") 
 (define example-a3-result 
   (digit-string->digit-list "11101110000000001101010000001100100000100011000001100000")) 
  
 (define example-a4-input "8A004A801A8002F478") 
 (define example-a4-result 16) 
  
 (define example-a5-input "620080001611562C8802118E34") 
 (define example-a5-result 12) 
  
 (define example-a6-input "C0015000016115A2E0802F182340") 
 (define example-a6-result 23) 
  
 (define example-a7-input "A0016C880162017C3686B18A3D4780") 
 (define example-a7-result 31) 
  
  
 (module+ main 
  
   (aoc16a)) 
  
    
 (module+ test 
  
   (require rackunit) 
  
   (check-equal? (read-input example-a1-input) example-a1-result) 
   (check-equal? (read-input example-a2-input) example-a2-result) 
   (check-equal? (read-input example-a3-input) example-a3-result) 
  
   (define (check-literal-packet p ver val) 
     (check-equal? p (packet-literal ver 4 val))) 
  
   (let-values (((s bl) (parse-prefix '(1 0 1) 3))) 
     (check-equal? s 5) 
     (check-true (null? bl))) 
  
   (let-values (((s bl) (parse-prefix '(1 1 1 0 0 1 0) 3))) 
     (check-equal? s 7) 
   (let-values (((s bl) (parse-prefix bl 4))) 
     (check-equal? s 2) 
     (check-true (null? bl)))) 
  
   (let-values 
  
     (((b p bl) (parse-packet-literal (read-input example-a1-input)))) 
  
     (check-true b) 
     (check-equal? p (packet-literal 6 4 2021)) 
     (check-equal? bl '(0 0 0))) 
  
   (let-values 
  
     (((b p bl) (parse-packet-operator (read-input example-a2-input)))) 
  
     (check-true b) 
     (check-equal? (packet-operator-version p) 1) 
     (check-equal? (packet-operator-type p) 6) 
  
     (let ((subps (packet-operator-subpackets p))) 
  
       (check-equal? (length subps) 2) 
  
       (let ((p (car subps))) 
         (check-equal? (packet-literal-version p) 6) 
         (check-equal? (packet-literal-type p) 4) 
         (check-equal? (packet-literal-value p) 10)) 
  
       (let ((p (cadr subps))) 
         (check-equal? (packet-literal-version p) 2) 
         (check-equal? (packet-literal-type p) 4) 
         (check-equal? (packet-literal-value p) 20))) 
  
     (check-equal? bl '(0 0 0 0 0 0 0)))   
  
   (let-values 
  
     (((b p bl) (parse-packet-operator (read-input example-a3-input)))) 
  
     (check-true b) 
     (check-equal? (packet-operator-version p) 7) 
     (check-equal? (packet-operator-type p) 3) 
  
     (let ((subps (packet-operator-subpackets p))) 
  
       (check-equal? (length subps) 3) 
  
       (let ((p (car subps))) 
         (check-equal? (packet-literal-version p) 2) 
         (check-equal? (packet-literal-type p) 4) 
         (check-equal? (packet-literal-value p) 1)) 
  
       (let ((p (cadr subps))) 
         (check-equal? (packet-literal-version p) 4) 
         (check-equal? (packet-literal-type p) 4) 
         (check-equal? (packet-literal-value p) 2)) 
  
       (let ((p (caddr subps))) 
         (check-equal? (packet-literal-version p) 1) 
         (check-equal? (packet-literal-type p) 4) 
         (check-equal? (packet-literal-value p) 3))) 
  
     (check-equal? bl '(0 0 0 0 0)))   
  
   (check-equal? (aoc16a example-a4-input) example-a4-result) 
   (check-equal? (aoc16a example-a5-input) example-a5-result) 
   (check-equal? (aoc16a example-a6-input) example-a6-result) 
   (check-equal? (aoc16a example-a7-input) example-a7-result) 
   (check-equal? (aoc16a) 993) 
   ) 
  
 $ raco test 16a.rkt 
 raco test: (submod "16a.rkt" test) 
 41 tests passed 
  
 $