Solutions of some puzzles in Scheme (Lisp), my first experience with it.
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

229 lines
6.3 KiB

#!/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)))