AoC '21, Day 14, second problem, rvc

 #lang racket 
  
  
 (require 
   "14a.rkt" 
   "../scheme/utl.rkt") 
  
  
 (define (aoc14b) 
  
   ; Return the answer to the second half of the fourteenth 
   ; advent-of-code '21 problem. 
  
   (let-values (((polymer expansion-table) (read-input))) 
     (census:spread 
       (population-after polymer expansion-table 40)))) 
  
  
 ; The second problem is the same as the first problem, except with 40 rounds of 
 ; expansion instead of 10.  Unfortunately, 40 rounds moves the problem into 
 ; terabyte expansions, making useless the brute-force approach used to solve 
 ; the first problem.  Fortunately, there are two techniques available to tame 
 ; this outrageous expansion.  The first technique exploits the fact that the 
 ; problem doesn't require the expanded polymer, it only requires the monomer 
 ; population of the expanded polymer.  Rather than expand the whole 
 ; polymer in pass after pass, as was done in the first problem, the 
 ; polymer can be expanded piecemeal in adjacent monomer pairs, keeping track 
 ; of the monomer population along the way. 
  
  
 (define (population-after polymer expansions iterations) 
  
   ; Return a monomer census for the given polymer after it has been 
   ; expanded the given number of times using the given expansions. 
  
   (define population (census:new polymer)) 
    
   (cond 
  
     ((< iterations 0) 
      (raise-user-error 'population-after 
        "negative iterations given" iterations)) 
  
     ((zero? iterations) 
      population) 
  
     (#t 
      (let loop ((fst (car polymer)) 
                 (rst (cdr polymer)) 
                 (population population)) 
      
        (if (null? rst) 
            population 
            (let ((nxt (car rst))) 
              (loop nxt 
                    (cdr rst) 
                    (census:merge 
                     population 
                     (population-between-after 
                       fst nxt expansions iterations))))))))) 
  
  
 ; Gimlet-eyed programmers will be shaking their heads because reducing problem 
 ; size won't outrun exponential behavior: the first few iterations inflate the 
 ; solution back to the original size, and the remaining iterations still 
 ; produce outrageous results.  This is where the second technique comes in: 
 ; memoization.  Adjacent monomer pairs are going to be expanded repeadedly 
 ; (there are polynomially many pairs, and exponentialy many expansions), and 
 ; memoization can assign the resulting population to those pair iterations to 
 ; avoid repeated expansions. 
  
 (define population-between-after 
  
   ; Return a monomer census for the polymer between the given monomer pair 
   ; after the pair has been expanded the given number of times using the given 
   ; expansions. 
  
   (let ((memo (make-hash))) 
  
       (lambda (left right expansions iterations) 
  
  
         (define (expansion-for left right) 
           (hash-ref expansions (string-append left right))) 
  
  
         (define (p-b-a) 
            
           ; Return a monomer census for the polymer between the given monomer 
           ; pair after the pair has been expanded the given number of times 
           ; using the given expansions. 
  
           ; There's a neat recursive formulation for expanding the monomer pair 
           ; l r in i iterations: expand the pair once to get the middle monomer 
           ; m (the look-up), then expand the monomer pairs l m and m r in i - 1 
           ; iterations (the recursion). 
  
           (let ((middle (expansion-for left right)) 
                 (iterations (- iterations 1))) 
  
             (if (zero? iterations) 
  
               (census:new (list middle)) 
  
               (census:tally 
                 (census:merge 
                   (population-between-after 
                    left middle expansions iterations) 
                   (population-between-after 
                    middle right expansions iterations)) 
                 middle)))) 
  
  
           (if (< iterations 1) 
  
               (raise-user-error 'population-between-after 
                 "non-positive iterations given ~a" iterations) 
  
               (let ((key (list left right iterations))) 
  
                 (if (hash-has-key? memo key) 
  
                     (hash-ref memo key) 
  
                     (let ((value (p-b-a))) 
                       (hash-set! memo key value) 
                       value))))))) 
  
  
 (define (census:merge census-1 census-2) 
  
   ; Return the census that results from merging the given censuses. 
    
   (let ((census (hash-copy census-1))) 
     (hash-for-each 
      census-2 
      (lambda (k v) (hash-set! census k (+ (hash-ref census k 0) v)))) 
     census)) 
  
  
 (module+ main 
   (aoc14b)) 
  
  
 (module+ test 
  
   (require rackunit) 
  
   (define (str-pop str) 
     (census:new (string->string-list str))) 
  
   ; Memoization makes writing tests tricky, because different 
   ; expansion sets may conflict if their alphabets aren't disjoint. 
   ; The easiest way around this problem is to have different test sets 
   ; use different (disjoint) alphabets. 
    
   (let-values (((p e) (read-input))) 
     (check-equal? (census:spread (population-after p e 10)) 2621)) 
  
   (let-values (((polymer expansions) 
                 (read-input "ww\n\nwx -> 1\nxy -> 2\nyz -> 3"))) 
     (for-each 
  
      (lambda (p) 
        (check-equal? 
         (population-after (string->string-list (car p)) expansions 1) 
         (str-pop (cdr p))))      
  
      '(("w" . "w") 
        ("wx" . "w1x") 
        ("wxy" . "w1x2y") 
        ("wxyz" . "w1x2y3z")))) 
  
   (let-values (((polymer expansions) (read-input example-input))) 
    (for-each 
  
      (lambda (p) 
        (check-equal? 
         (population-after polymer expansions (car p)) 
         (str-pop (cdr p))))      
  
      example-input-results)) 
   ) 
  
 $ raco test 14b.rkt  
 raco test: (submod "14b.rkt" test) 
 9 tests passed 
  
 $