advent-of-code/2020/day-04/puzzle-02.scm

(import
  (except (rnrs base) let-values map error)
  (only (guile) lambda* λ command-line string-null?)
  (ice-9 peg)
  (srfi srfi-1)  ; list procs
  (srfi srfi-69)  ; hash-tables
  (fileio))

;; GRAMMAR
(define-peg-pattern DIGIT body
  (or (range #\0 #\9)))

(define-peg-pattern ALPHA-NUMERIC body
  (or (range #\0 #\9) (range #\a #\z) (range #\A #\Z)))

(define-peg-pattern HEXADECIMAL body
  (or (range #\0 #\9) (range #\a #\f)))

(define-peg-pattern KEY-VALUE-SEP none ":")
(define-peg-pattern PAIR-SEP body " ")
(define-peg-pattern LENGTH-UNIT all (or "in" "cm"))
(define-peg-pattern LENGTH-NUMBER all (+ DIGIT))
(define-peg-pattern EYE-COLOR body (or "amb" "blu" "brn" "gry" "grn" "hzl" "oth"))

(define-peg-pattern VALUE-CHARS body
  (or (range #\0 #\9) (range #\a #\z) (range #\A #\Z) "#"))

(define-peg-pattern BIRTH-YEAR-VALUE all (and DIGIT DIGIT DIGIT DIGIT))
(define-peg-pattern ISSUE-YEAR-VALUE all (and DIGIT DIGIT DIGIT DIGIT))
(define-peg-pattern EXPIRATION-YEAR-VALUE all (and DIGIT DIGIT DIGIT DIGIT))
(define-peg-pattern HEIGHT-VALUE all (and LENGTH-NUMBER LENGTH-UNIT))
(define-peg-pattern HAIR-COLOR-VALUE all
  (and "#" HEXADECIMAL HEXADECIMAL HEXADECIMAL HEXADECIMAL HEXADECIMAL HEXADECIMAL))
(define-peg-pattern EYE-COLOR-VALUE all EYE-COLOR)
(define-peg-pattern PASSPORT-ID-VALUE all
  (and DIGIT DIGIT DIGIT DIGIT DIGIT DIGIT DIGIT DIGIT DIGIT))
(define-peg-pattern COUNTRY-ID-VALUE all (+ VALUE-CHARS))

(define-peg-pattern BIRTH-YEAR-KEY body "byr")
(define-peg-pattern ISSUE-YEAR-KEY body "iyr")
(define-peg-pattern EXPIRATION-YEAR-KEY body "eyr")
(define-peg-pattern HEIGHT-KEY body "hgt")
(define-peg-pattern HAIR-COLOR-KEY body "hcl")
(define-peg-pattern EYE-COLOR-KEY body "ecl")
(define-peg-pattern PASSPORT-ID-KEY body "pid")
(define-peg-pattern COUNTRY-ID-KEY body "cid")

(define-peg-pattern KNOWN-KEY-VALUE-PAIRS body
  (or (and BIRTH-YEAR-KEY KEY-VALUE-SEP BIRTH-YEAR-VALUE)
      (and ISSUE-YEAR-KEY KEY-VALUE-SEP ISSUE-YEAR-VALUE)
      (and EXPIRATION-YEAR-KEY KEY-VALUE-SEP EXPIRATION-YEAR-VALUE)
      (and HEIGHT-KEY KEY-VALUE-SEP HEIGHT-VALUE)
      (and HAIR-COLOR-KEY KEY-VALUE-SEP HAIR-COLOR-VALUE)
      (and EYE-COLOR-KEY KEY-VALUE-SEP EYE-COLOR-VALUE)
      (and PASSPORT-ID-KEY KEY-VALUE-SEP PASSPORT-ID-VALUE)
      (and COUNTRY-ID-KEY KEY-VALUE-SEP COUNTRY-ID-VALUE)))

(define-peg-pattern PASSPORT body
  (and (* (and KNOWN-KEY-VALUE-PAIRS PAIR-SEP))
       KNOWN-KEY-VALUE-PAIRS))


(define get-value-from-peg-tree
  (λ (peg-tree label)
    ;; (simple-format (current-output-port) "looking for ~a in ~a\n" label peg-tree)
    (cond
     [(null? peg-tree) #f]
     [(pair? (car peg-tree))
      (or (get-value-from-peg-tree (car peg-tree) label)
          (get-value-from-peg-tree (cdr peg-tree) label))]
     [(string? (car peg-tree))
      (cond
       [(string=? (car peg-tree) label)
        (cdr peg-tree)]
       [else
        (get-value-from-peg-tree (cdr peg-tree) label)])]
     [else
      (get-value-from-peg-tree (cdr peg-tree) label)])))


(define println
  (λ (thing)
    (simple-format (current-output-port) "~a\n" thing)))


(define lines->passport-data
  (lambda* (lines #:key (passport-separator-test string-null?) (key-separator " "))
    (let next-line ([remaining-lines lines] [single-passport-data ""])
      (cond
       [(null? remaining-lines)
        (list (string-trim-both single-passport-data))]
       [else
        (let ([cur-line (car remaining-lines)])
          (cond
           ;; The passport-separator finishes an entry in
           ;; the lines. We cons the single passport data
           ;; onto the recursion and start collecting data
           ;; for the next single passport.
           [(passport-separator-test cur-line)
            (cons (string-trim-both single-passport-data)
                  (next-line (cdr remaining-lines) ""))]
           ;; If more data for a single passport follows, we
           ;; append it onto the single passport data and
           ;; look at the next line.
           [else
            (next-line (cdr remaining-lines)
                       (string-append single-passport-data
                                      key-separator
                                      cur-line))]))]))))


(define valid-birth-year?
  (λ (byr)
    ;; (simple-format (current-output-port) "validating birth year: ~s\n" byr)
    (let* ([year (second (first byr))]
           [num-byr (string->number year)])
      ;; (simple-format (current-output-port) "validating num-byr: ~s\n" num-byr)
      (and (>= num-byr 1920)
           (<= num-byr 2002)))))


(define valid-issue-year?
  (λ (iyr)
    ;; (simple-format (current-output-port) "validating issue year: ~s\n" iyr)
    (let* ([year (second (first iyr))]
           [num-iyr (string->number year)])
      ;; (simple-format (current-output-port) "validating num-iyr: ~s\n" num-iyr)
      (and (>= num-iyr 2010)
           (<= num-iyr 2020)))))


(define valid-expiration-year?
  (λ (eyr)
    ;; (simple-format (current-output-port) "validating expiration year: ~s\n" eyr)
    (let* ([year (second (first eyr))]
           [num-eyr (string->number year)])
      ;; (simple-format (current-output-port) "validating num-eyr: ~s\n" num-eyr)
      (and (>= num-eyr 2020)
           (<= num-eyr 2030)))))


(define valid-height?
  (λ (hgt)
    ;; (simple-format (current-output-port) "validating height: ~s\n" hgt)
    ;; (HEIGHT-VALUE (LENGTH-NUMBER 174) (LENGTH-UNIT cm))
    (let ([unit (second (third (car hgt)))]
          [num (string->number (second (second (car hgt))))])
      ;; (simple-format (current-output-port) "validating num: ~s\n" num)
      ;; (simple-format (current-output-port) "validating unit: ~s\n" unit)
      (or (and (string=? unit "in")
               (>= num 59)
               (<= num 76))
          (and (string=? unit "cm")
               (>= num 150)
               (<= num 193))))))


(define valid-hair-color?
  (λ (hcl)
    ;; is already validated through parsing
    #t))


(define valid-eye-color?
  (λ (ecl)
    ;; is already validated through parsing
    #t))


(define valid-passport-id?
  (λ (pid)
    ;; is already validated through parsing
    #t))


(define valid-country-id?
  (λ (cid)
    ;; is already validated through parsing
    #t))


(define valid-passport?
  (λ (passport)
    (let ([tree (peg:tree passport)]
          [mandatory-keys-to-pred
           (alist->hash-table `(("byr" . ,valid-birth-year?)
                                ("iyr" . ,valid-issue-year?)
                                ("eyr" . ,valid-expiration-year?)
                                ("hgt" . ,valid-height?)
                                ("hcl" . ,valid-hair-color?)
                                ("ecl" . ,valid-eye-color?)
                                ("pid" . ,valid-passport-id?)))]
          [optional-keys '("cid")])
      (hash-table-fold mandatory-keys-to-pred
                       (λ (key valid? prior-result)
                         (and prior-result
                              (if tree
                                  (let ([val (get-value-from-peg-tree tree key)])
                                    (if val (valid? val) #f))
                                  #f)))
                       #t))))


(define main
  (λ (cmd-line-args)
    (let* ([lines (get-lines-from-file (second cmd-line-args))]
           [passport-data (lines->passport-data lines)]
           [passports (map (λ (datum) (match-pattern PASSPORT datum))
                           passport-data)])
      (length (filter (λ (pp) (valid-passport? pp))
                      passports)))))


(simple-format (current-output-port)
               "~a\n"
               (main (command-line)))