AdventOfCode-2023-functional/day01-hard/main.scm

#!/usr/bin/guile -s
!#

;=============== functions with side effects (I/O) ======================
(use-modules (ice-9 rdelim))

(define (read-lines)
  ((lambda (line)
    (if (eof-object? line) '() (cons line (read-lines))))
  (read-line)))

(define (display-ln value) (list (display value) (display "\n")))

(define (assert-eq error-message expected actual)
  (if (not (equal? expected actual))
    (display-ln (list error-message (list "expected" expected) (list "actual" actual)))
    '()))

(define (tee value) (car (list value (display-ln value))))
;=============== end of functions with side effects ======================

(define (id value) value)
(define (is-not value) (lambda (x) (not (equal? x value))))
(define is-not-empty (lambda (x) (not (null? x))))

(define (prepend first-value) (lambda (rest) (cons first-value rest)))

(define Y (lambda (f) (f (lambda (x) ((Y f) x)))))
(define Y2 (lambda (f) (f (lambda (x y) ((Y2 f) x y)))))

(define (reduce-right reducer initial) (Y
  (lambda (f) (lambda (values)
    (if (null? values) initial (reducer (car values) (f (cdr values))))))))

(define (map mapper) (reduce-right
  (lambda (current accumulator) (cons (mapper current) accumulator))
  '()))

(define (concat left right)
  ((reduce-right
    (lambda (current accumulator) (cons current accumulator))
    right)
  left))

;=============== starts-with ======================
(define flat (reduce-right concat '()))

(assert-eq "flat test 1 failed"
  '(1 2 3 4 5 (6 7) 8)
  (flat '((1 2) (3 4) (5 (6 7) 8))))

(define (filter predicate) (reduce-right
  (lambda (current accumulator)
    (if (predicate current) (cons current accumulator) accumulator))
  '()))

;=============== first ======================
(define (first predicate) (reduce-right
  (lambda (current accumulator)
    (if (predicate current) current accumulator))
  '()))

(assert-eq "first with is-not-empty test 1 failed"
  '(1 2 3)
  ((first is-not-empty) '(() (1 2 3))))

(define (coalesce-not-empty default) (lambda (value) ((first is-not-empty) (list value default))))

(define (truthy-chaining f) (lambda (value) (if value (f value) #f)))

(define (compose-two f g) (lambda (x) (f (g x))))

(define compose (reduce-right compose-two id))

(define (combine combiner)
  (lambda (a b) (if (null? a) b (if (null? b) a (combiner a b)))))

(define sum (reduce-right + 0))

(define (repeat value) (Y
  (lambda (f) (lambda (n)
    (if (= n 0) '() (cons value (f (- n 1))))))))

;=============== starts-with ======================
(define starts-with (Y2
  (lambda (f) (lambda (prefix values)
    (if
      (null? prefix)
      values
      (if
        (null? values)
        #f
        (if (equal? (car prefix) (car values))
          (f (cdr prefix) (cdr values))
          #f)))))))

(assert-eq "starts-with test 1 failed"
  '(4)
  (starts-with '(1 2 3) '(1 2 3 4)))

(assert-eq "starts-with test 2 failed"
  '()
  (starts-with '(1 2 3) '(1 2 3)))

(assert-eq "starts-with test 3 failed"
  #f
  (starts-with '(1 2 3) '(1 2)))

(assert-eq "starts-with test 4 failed"
  #f
  (starts-with '(1 2 3) '(4 5 6 7)))

(assert-eq "starts-with test 5 failed"
  (string->list "d")
  (starts-with (string->list "abc") (string->list "abcd")))

;=============== tokenize ======================
(define (tokenize-generic tokens next) (Y
  (lambda (f) (lambda (values)
    (if
      (null? values)
      '(())
      ((compose (list
        (coalesce-not-empty (f (cdr values)))
        flat
        (filter id)
        (map
          (lambda (token)
            ((truthy-chaining (compose (list
              (map (prepend (car token)))
              (lambda (rest) (f (next rest values))))))
              (starts-with (cdr token) values))))))
        tokens))))))

(define (tokenize tokens)
  (tokenize-generic tokens (lambda (rest values) rest)))

(assert-eq "tokenize test 1 failed"
  '((101 201) (101 202) (102 201) (102 202))
  ((tokenize '((101 1) (102 1) (201 2) (202 2)))
  '(1 2)))

(assert-eq "tokenize test 2 failed"
  '((101 102 102 101 102))
  ((tokenize '((101 1) (102 2)))
  '(1 2 3 2 1 2)))

(assert-eq "tokenize test 3 failed"
  '((101 102 101) (101 1021) (1012 101))
  ((tokenize '((101 1) (102 2) (1012 1 2) (1021 2 1)))
  '(1 2 1)))

(define (tokenize-aoc tokens)
  (tokenize-generic tokens (lambda (rest values) (cdr values))))

;=============== solution ======================
(define solution-tokens
  (list
    (cons #\0 (string->list "0"))
    (cons #\1 (string->list "1"))
    (cons #\2 (string->list "2"))
    (cons #\3 (string->list "3"))
    (cons #\4 (string->list "4"))
    (cons #\5 (string->list "5"))
    (cons #\6 (string->list "6"))
    (cons #\7 (string->list "7"))
    (cons #\8 (string->list "8"))
    (cons #\9 (string->list "9"))
    (cons #\1 (string->list "one"))
    (cons #\2 (string->list "two"))
    (cons #\3 (string->list "three"))
    (cons #\4 (string->list "four"))
    (cons #\5 (string->list "five"))
    (cons #\6 (string->list "six"))
    (cons #\7 (string->list "seven"))
    (cons #\8 (string->list "eight"))
    (cons #\9 (string->list "nine"))))

(assert-eq "solution tokenize test 1 failed"
  (list (string->list "219"))
  ((tokenize-aoc solution-tokens)
  (string->list "two1nine")))

(assert-eq "solution tokenize test 2 failed"
  (list (string->list "823"))
  ((tokenize-aoc solution-tokens)
  (string->list "eightwothree")))

(assert-eq "solution tokenize test 3 failed"
  (list (string->list "123"))
  ((tokenize-aoc solution-tokens)
  (string->list "abcone2threexyz")))

(assert-eq "solution tokenize test 4 failed"
  (list (string->list "2134"))
  ((tokenize-aoc solution-tokens)
  (string->list "xtwone3four")))

(assert-eq "solution tokenize test 5 failed"
  (list (string->list "49872"))
  ((tokenize-aoc solution-tokens)
  (string->list "4nineeightseven2")))

(assert-eq "solution tokenize test 6 failed"
  (list (string->list "18234"))
  ((tokenize-aoc solution-tokens)
  (string->list "zoneight234")))

(assert-eq "solution tokenize test 7 failed"
  (list (string->list "76"))
  ((tokenize-aoc solution-tokens)
  (string->list "7pqrstsixteen")))

(define solve-line (compose (list
  string->number
  list->string
  (reduce-right
    (combine (lambda (left right) (cons (car left) (cdr right))))
    '())
  (map (lambda (char) ((repeat char) 2)))
  car
  (tokenize-aoc solution-tokens)
  string->list)))

(define solve-all (compose (list
  sum
  (map solve-line))))

(display (solve-all (read-lines)))