ya hear about these macro things

day2.ss

@@ -1,4 +1,4 @@
-(import (rnrs))
+(import (rnrs) (only (chezscheme) define-values))
 
 (define-syntax curry
   (syntax-rules ()
@@ -6,78 +6,84 @@
 
 (define (mapmap f lst) (map (curry map f) lst))
 
-(define (split-at ch str)
-  (let [(len (string-length str))]
-    (let loop [(start 0) (end 0) (acc '())]
-      (cond
-        [(>= start len)
-         (reverse (if (= start end) (cons "" acc) acc))]
-        [(>= end len)
-         (reverse (cons (substring str start len) acc))]
-        [(char=? ch (string-ref str end))
-         (loop (+ end 1) (+ end 1) (cons (substring str start end) acc))]
-        [else (loop start (+ end 1) acc)]))))
-
-(define (trim str)
-  (let loop [(i 0)]
-    (if (char-whitespace? (string-ref str i))
-      (loop (+ i 1))
-      (let loop [(j (- (string-length str) 1))]
-        (if (char-whitespace? (string-ref str j))
-          (loop (- j 1))
-          (substring str i (+ j 1)))))))
-
-(define (one-col str)
-  (let* [(str (trim str))
-         (words (split-at #\space str))]
-    (cons (string->symbol (cadr words)) (string->number (car words)))))
-
-(define (split-line line)
-  (let* [(line (split-at #\: line))
-         (id (car line)) (line (cadr line))
-         (id (string->number (cadr (split-at #\space id))))
-         (draws (split-at #\; line))
-         (colours (map (curry split-at #\,) draws))
-         (pairs (mapmap one-col colours))]
-    (cons id pairs)))
-
-(define (max-count col)
-  (case col [(red) 12] [(green) 13] [(blue) 14]))
-
+(define-syntax let-pair
+  (syntax-rules ()
+    [(_ [(x y) pair] . body)
+     (let* [(xpair pair) (x (car xpair)) (y (cdr xpair))] . body)]))
 
 (define-syntax case-list
   (syntax-rules (nil cons)
-    [(_ lst [nil n ...] [(cons x xs) c ...])
-     (if (null? lst)
-       (begin n ...)
-       (let [(x (car lst)) (xs (cdr lst))] c ...))]
-    [(_ lst [(cons x xs) c ...] [nil n ...])
-     (case-list lst [nil n ...] [(cons x xs) c ...])]))
+    [(_ lst [nil . nbody] [(cons x xs) . cbody])
+     (let [(xlst lst)]
+       (if (null? xlst) (begin . nbody) (let-pair [(x xs) xlst] . cbody)))]
+    [(_ lst [(cons x xs) . cbody] [nil . nbody])
+     (case-list lst [nil . nbody] [(cons x xs) . cbody])]))
+
+(define-syntax split-list
+  (syntax-rules () [(_ names lst) (define-values names (apply values lst))]))
+
+(define sum (curry apply +))
+(define product (curry apply *))
+(define concat (curry apply append))
+
+(define (split-at ch str)
+  (define len (string-length str))
+  (let loop [(start 0) (end 0) (acc '())]
+    (cond
+      [(>= end len)
+       (reverse (cons (substring str start len) acc))]
+      [(char=? ch (string-ref str end))
+       (loop (+ end 1) (+ end 1) (cons (substring str start end) acc))]
+      [else (loop start (+ end 1) acc)])))
+
+(define (split-at-nested chs0 str)
+  (define chs (cond [(list? chs0) chs0] [(string? chs0) (string->list chs0)]))
+  (case-list chs
+    [nil str]
+    [(cons ch chs) (map (curry split-at-nested chs) (split-at ch str))]))
+
+(define (trim-by p str)
+  (define (ok k) (not (p (string-ref str k))))
+  (define i (do [(i 0                   (+ i 1))] [(ok i)       i]))
+  (define j (do [(j (string-length str) (- j 1))] [(ok (- j 1)) j]))
+  (substring str i j))
+
+(define trim (curry trim-by char-whitespace?))
+
+(define (one-col str)
+  (split-list (count col) (split-at #\space (trim str)))
+  (cons (string->symbol col) (string->number count)))
+
+(define (split-line line0)
+  (split-list (id-str line) (split-at #\: line0))
+  (define id (string->number (cadr (split-at #\space id-str))))
+  (define pairs (mapmap one-col (split-at-nested ";," line)))
+  (cons id pairs))
+
+(define (maybe-split-line line)
+  (and (not (string=? line "")) (split-line line)))
+
+(define max-counts '((red . 12) (green . 13) (blue . 14)))
+(define (max-count col) (cond [(assq col max-counts) => cdr] [else 0]))
 
-(define-syntax let-pair
-  (syntax-rules ()
-    [(_ [(x y) pair] body ...)
-     (let [(x (car pair)) (y (cdr pair))] body ...)]))
 
 (define (valid-draw draws)
-  (case-list draws
-    [nil #t]
-    [(cons this rest)
-     (let-pair [(col count) this]
-       (if (<= count (max-count col)) (valid-draw rest) #f))]))
+  (define (ok p) (let-pair [(col n) p] (<= n (max-count col))))
+  (for-all ok draws))
 
 (define (valid line)
-  (let-pair [(id draws) line]
-    (if (for-all valid-draw draws) id #f)))
+  (let-pair [(id draws) line] (and (for-all valid-draw draws) id)))
+
+(define (map-filter p lst)
+  (define (one x ys) (let [(y (p x))] (if y (cons y ys) ys)))
+  (fold-right one '() lst))
 
 (define (read-file path)
-  (let* [(str (call-with-input-file path get-string-all))]
-    (map split-line
-         (filter (lambda (s) (not (string=? s "")))
-                 (split-at #\newline str)))))
+  (map-filter maybe-split-line
+    (split-at #\newline (call-with-input-file path get-string-all))))
 
 (define (total lines)
-  (apply + (map (lambda (line) (or (valid line) 0)) lines)))
+  (sum (map (lambda (line) (or (valid line) 0)) lines)))
 
 (define input (read-file "in/day2"))
 
@@ -85,17 +91,19 @@
 
 (display (cons "part1" (part1))) (newline)
 
-(define (min-cubes draws)
-  (fold-left
-    (lambda (a b)
-      (let* [(get (lambda (col draw) (cond [(assq col draw) => cdr] [else 0])))
-             (get-max (lambda (c) (cons c (max (get c a) (get c b)))))]
-        (list (get-max 'red) (get-max 'green) (get-max 'blue))))
-    '() draws))
+(define (get-col col draw) (cond [(assq col draw) => cdr] [else 0]))
 
-(define (power line)
-  (fold-left (lambda (n c) (* n (cdr c))) 1 (min-cubes (cdr line))))
+(define (get-max draw1 draw2 col)
+  (cons col (max (get-col col draw1) (get-col col draw2))))
 
-(define (part2) (apply + (map power input)))
+(define (combine draw1 draw2)
+  (define (get-max-of col) (get-max draw1 draw2 col))
+  (list (get-max-of 'red) (get-max-of 'green) (get-max-of 'blue)))
+
+(define (min-cubes draws) (fold-left combine '() draws))
+
+(define (power line) (product (map cdr (min-cubes (cdr line)))))
+
+(define (part2) (sum (map power input)))
 
 (display (cons "part2" (part2))) (newline)