advent-of-code-2022/day-13/part-01.scm

(import
 (except (rnrs base)
         let-values
         map
         error
         vector-map)
 (only (guile)
       lambda* λ
       simple-format
       current-output-port)
 (fileio)
 ;; (ice-9 pretty-print)
 (ice-9 peg)
 (prefix (peg-tree-utils) peg-tree:)
 ;; (ice-9 format)
 (srfi srfi-1)
 (pipeline)
 (debug)
 (list-helpers)
 (parallelism)
 (math))


(define input-filename "input")
(define lines (get-lines-from-file input-filename))
(define list-groups (split-into-segments lines (λ (line) (string-null? line))))


(assert (reduce (λ (elem acc) (and acc elem))
                #t
                (map (λ (list-group) (= (length list-group) 2))
                     list-groups)))

;; define grammar

(define-peg-pattern COMMA none ",")
(define-peg-pattern NUMBER all (+ (range #\0 #\9)))
(define-peg-pattern QOPEN none "[")
(define-peg-pattern QCLOSE none "]")
(define-peg-pattern QLIST-ITEM body (or NUMBER QLIST))
(define-peg-pattern QLIST-ALL-ITEMS all (* (and QLIST-ITEM (? COMMA))))
(define-peg-pattern QLIST all (and QOPEN QLIST-ALL-ITEMS QCLOSE))


(define parse-string-list
  (λ (str)
    (let ([tree (peg:tree (match-pattern QLIST str))])
      tree)))


(assert (reduce (λ (elem acc) (and acc elem))
                #t
                (map (λ (list-group)
                       (and (parse-string-list (first list-group))
                            (parse-string-list (second list-group))))
                     list-groups)))


(define parsed-list->list
  (λ (plist)
    (let ([label (first plist)])
      (cond
       [(eq? label 'NUMBER)
        (string->number (second plist))]
       [(eq? label 'QLIST)
        (map parsed-list->list
             (peg-tree:tree-refs plist '(QLIST-ALL-ITEMS) #:equal-test eq?))]
       [else (error "unrecognized parsed list" plist)]))))


(define list-transformer
  (λ (list-str)
    (-> list-str parse-string-list parsed-list->list)))


(define translated-list-groups
  (parallel-map (λ (group _ind)
                  (cons (list-transformer (first group))
                        (list-transformer (second group))))
                list-groups))


(for-each (λ (list-group)
            (assert (or (pair? (car list-group)) (null? (car list-group))))
            (assert (or (pair? (cdr list-group)) (null? (cdr list-group)))))
          translated-list-groups)


(define less
  (λ (lst1 lst2)
    (define compare
      ;; Usage of a continuation for the equals case avoids having to
      ;; encode the results of <, =, > in 3 values like 1, 0, -1.
      (λ (lst1° lst2° equal-case-cont)
        ;; (simple-format #t "comparing:\n~a\n~a\n" lst1° lst2°)
        (cond
         [(and (null? lst1°) (null? lst2°)) (equal-case-cont)]
         [(null? lst2°) #f]
         [(null? lst1°) #t]
         ;; no list ran out of elements yet -- OK!
         [else
          (let ([elem1 (first lst1°)] [elem2 (first lst2°)])
            (cond
             ;; both contain a list as first element
             [(and (or (pair? elem1) (null? elem1))
                   (or (pair? elem2) (null? elem2)))
              (compare elem1
                       elem2
                       ;; Build a new continuation. Compare this cdr,
                       ;; but also keep the outer cdr compare
                       ;; continuation.
                       (λ ()
                         (compare (cdr lst1°)
                                  (cdr lst2°)
                                  equal-case-cont)))]
             ;; both a number
             [(and (number? elem1) (number? elem2))
              ;; need to distinguish equals case
              (cond
               [(< elem1 elem2) #t]
               [(= elem1 elem2)
                (compare (cdr lst1°) (cdr lst2°) equal-case-cont)]
               [(> elem1 elem2) #f])]

             ;; transform into a list if not both a list
             [(and (number? elem1) (not (number? elem2)))
              (less (cons (list elem1) (cdr lst1°)) lst2°)]
             [(and (not (number? elem1)) (number? elem2))
              (less lst1° (cons (list elem2) (cdr lst2°)))]

             ;; both a list
             [(and (pair? elem1) (pair? elem2))
              (compare elem1
                       elem2
                       (λ () (less (cdr lst1°) (cdr lst2°))))]

             [else
              (simple-format #t "unrecognized situation while comparing: ~a with ~a\n" lst1 lst2)
              (error "unrecognized situation" lst1 lst2)]))])))
    (compare lst1
             lst2
             (λ () (less (cdr lst1) (cdr lst2))))))


(define identity (λ (x) x))


(simple-format
 #t "~a\n"
 (sum (filter identity
              (parallel-map
               (λ (group group-index)
                 ;; (simple-format #t "comparing group ~a\n" (+ group-index 1))
                 (cond [(less (car group) (cdr group))
                        ;; (simple-format #t "  -> ~a\n" #t)
                        (+ group-index 1)]
                       [else
                        ;; (simple-format #t "  -> ~a\n" #f)
                        #f]))
               translated-list-groups))))