day 22: some cleanup/optimization

22.rkt

@@ -8,58 +8,46 @@
     (* card mult)))
 
 (define (play p1 p2)
-    (cond
-      [(empty? p1) (score p2)]
-      [(empty? p2) (score p1)]
-      [else
-       (define p1-card (first p1))
-       (define p2-card (first p2))
-       (cond
-        [(> p1-card p2-card) (play (append (rest p1) (list p1-card p2-card)) (rest p2))]
-        [else (play (rest p1) (append (rest p2) (list p2-card p1-card)))])]))
+  (match* (p1 p2)
+    [('() _) (score p2)]
+    [(_ '()) (score p1)]
+    [((cons p1-card p1-rest) (cons p2-card p2-rest))
+     (if (> p1-card p2-card)
+       (play (append p1-rest (list p1-card p2-card)) p2-rest)
+       (play p1-rest (append p2-rest (list p2-card p1-card))))]))
 
 (define (part1 input)
   (match-define (list p1 p2) input)
-
   (play p1 p2))
 
-
 (define (part2 input)
   (match-define (list p1 p2) input)
 
-  (define memo (make-hash))
-  (define (do-memo level p1 p2)
-    (hash-update! memo level (lambda (x) (set-add x (list p1 p2))) (set)))
-
-  (define (play/recur p1 p2 [level 0])
-    ; (printf "~a ~a\n" p1 p2)
+  (define/memoized (play/recur p1 p2)
+    (define local-memo (mutable-set))
+    (let loop ([p1 p1] [p2 p2])
       (cond
-      [(set-member? (hash-ref memo level (set)) (list p1 p2)) (cons 'p1 (score p1))]
-      [(empty? p1) (cons 'p2 (score p2))]
-      [(empty? p2) (cons 'p1 (score p1))]
+        [(set-member? local-memo (list p1 p2)) (cons 'p1 p1)]
+        [(empty? p1) (cons 'p2 p2)]
+        [(empty? p2) (cons 'p1 p1)]
         [else
-       (define p1-card (first p1))
-       (define p1-rest (rest p1))
-       (define p2-card (first p2))
-       (define p2-rest (rest p2))
+         (set-add! local-memo (list p1 p2))
+         (match-define (cons p1-card p1-rest) p1)
+         (match-define (cons p2-card p2-rest) p2)
          (cond
           [(and (>= (length p1-rest) p1-card)
                 (>= (length p2-rest) p2-card))
            (match-define (cons winner score)
-           (play/recur (take p1-rest p1-card) (take p2-rest p2-card) (add1 level)))
-         ; (printf "submatch ~a\n" winner)
-         (do-memo level p1 p2)
+             (play/recur (take p1-rest p1-card) (take p2-rest p2-card)))
            (if (symbol=? winner 'p1)
-           (play/recur (append p1-rest (list p1-card p2-card)) p2-rest level)
-           (play/recur p1-rest (append p2-rest (list p2-card p1-card)) level))]
+             (loop (append p1-rest (list p1-card p2-card)) p2-rest)
+             (loop p1-rest (append p2-rest (list p2-card p1-card))))]
           [(> p1-card p2-card)
-         (do-memo level p1 p2)
-         (play/recur (append p1-rest (list p1-card p2-card)) p2-rest level)]
+           (loop (append p1-rest (list p1-card p2-card)) p2-rest)]
           [else
-          (do-memo level p1 p2)
-           (play/recur p1-rest (append p2-rest (list p2-card p1-card)) level)])]))
+           (loop p1-rest (append p2-rest (list p2-card p1-card)))])])))
 
-  (cdr (play/recur p1 p2)))
+  (score (cdr (play/recur p1 p2))))
 
 ;; parse input file
 (define (parse fname)
@@ -68,6 +56,8 @@
     (map string->number (rest (string-split p1 "\n")))
     (map string->number (rest (string-split p2 "\n")))))
 
+(time (part2 (parse "/tmp/adventofcode-2020/input/22.txt")))
+
 (module+ test
   (require rackunit)
   ;; tests here

scripts/aoc.rkt

@@ -26,11 +26,11 @@
 ;; makes a memoization wrapper around a function
 (define (memoize func)
   (define memo (make-hash))
-  (lambda (arg)
-    (hash-ref! memo arg (λ () (func arg)))))
+  (lambda args
+    (hash-ref! memo args (λ () (apply func args)))))
 
-(define-simple-macro (define/memoized (name:id arg:id) body:expr ...+)
-  (define name (memoize (λ (arg) body ...))))
+(define-simple-macro (define/memoized (name:id arg:id ...) body:expr ...+)
+  (define name (memoize (λ (arg ...) body ...))))
 
 ;; helper for maximum-bipartite-matching
 ;; given an edge list where each first item corresponds to the left set and each second item