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.
508 lines
16 KiB
508 lines
16 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))))
|
|
(define (tee-with-comment comment) (lambda (value) (car (list value (display comment) (display " ") (display-ln value)))))
|
|
;=============== end of functions with side effects ======================
|
|
|
|
(define (id value) value)
|
|
(define (is value) (lambda (x) (equal? x value)))
|
|
(define (is-not value) (lambda (x) (not (equal? x value))))
|
|
(define (is-not-empty value) (not (null? value)))
|
|
|
|
;=============== combinators ======================
|
|
(define (Y f) (f (lambda (x) ((Y f) x))))
|
|
(define (Y2 f) (f (lambda (x y) ((Y2 f) x y))))
|
|
|
|
(assert-eq "Y test 1 (factorial) failed"
|
|
120
|
|
((Y (lambda (f) (lambda (n) (if (= n 0) 1 (* n (f (- n 1))))))) 5))
|
|
|
|
(assert-eq "Y2 test 1 (pascal triangle) failed"
|
|
35
|
|
((Y2 (lambda (f) (lambda (a b)
|
|
(if (= a 0) 1 (if (= b 0) 1 (+ (f (- a 1) b) (f a (- b 1))))))))
|
|
3 4))
|
|
|
|
;=============== reduce-right ======================
|
|
(define (reduce-right initial reducer) (Y
|
|
(lambda (f) (lambda (values)
|
|
(if (null? values) initial (reducer (car values) (f (cdr values))))))))
|
|
|
|
(assert-eq "reduce-right test 1 failed"
|
|
'(4 101 3 102 2 103 1 104 0)
|
|
((reduce-right '(0)
|
|
(lambda (current accumulator) (cons (+ 1 (car accumulator)) (cons current accumulator))))
|
|
'(101 102 103 104)))
|
|
|
|
;=============== reduce-left ======================
|
|
(define (reduce-left initial reducer)
|
|
(lambda (values)
|
|
((Y2
|
|
(lambda (f) (lambda (rest accumulator)
|
|
(if (null? rest) accumulator (f (cdr rest) (reducer (car rest) accumulator))))))
|
|
values
|
|
initial)))
|
|
|
|
(assert-eq "reduce-left test 1 failed"
|
|
'(4 104 3 103 2 102 1 101 0)
|
|
((reduce-left '(0)
|
|
(lambda (current accumulator) (cons (+ 1 (car accumulator)) (cons current accumulator))))
|
|
'(101 102 103 104)))
|
|
|
|
;=============== prepend ======================
|
|
(define (prepend first-value) (lambda (rest) (cons first-value rest)))
|
|
|
|
(assert-eq "prepend test failed"
|
|
'(1 2 3 4)
|
|
((prepend 1) '(2 3 4)))
|
|
|
|
;=============== append ======================
|
|
(define (append first-value) (reduce-right (list first-value) cons))
|
|
|
|
(assert-eq "append test failed"
|
|
'(1 2 3 4)
|
|
((append 4) '(1 2 3)))
|
|
|
|
;=============== reverse ======================
|
|
(define reverse (reduce-left '() cons))
|
|
|
|
(assert-eq "reverse test 1 failed"
|
|
'(4 3 2 1)
|
|
(reverse '(1 2 3 4)))
|
|
|
|
;=============== map ======================
|
|
(define (map mapper) (reduce-right '()
|
|
(lambda (current accumulator) (cons (mapper current) accumulator))))
|
|
|
|
(assert-eq "map test 1 failed"
|
|
'(1 4 9 16)
|
|
((map (lambda (x) (* x x)))
|
|
'(1 2 3 4)))
|
|
|
|
(assert-eq "map test 2 failed"
|
|
'(1 2 (3 4) 5)
|
|
((map id) '(1 2 (3 4) 5)))
|
|
|
|
;=============== concat ======================
|
|
(define (concat left right)
|
|
((reduce-right right (lambda (current accumulator) (cons current accumulator)))
|
|
left))
|
|
|
|
(assert-eq "concat test 1 failed"
|
|
'(1 2 3 4 5)
|
|
(concat '(1 2) '(3 4 5)))
|
|
|
|
;=============== flat ======================
|
|
(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))))
|
|
|
|
;=============== filter ======================
|
|
(define (filter predicate) (reduce-right '()
|
|
(lambda (current accumulator)
|
|
(if (predicate current) (cons current accumulator) accumulator))))
|
|
|
|
(assert-eq "filter test 1 failed"
|
|
'(2 4 4 2)
|
|
((filter (lambda (x) (= (modulo x 2) 0)))
|
|
'(1 2 3 4 4 3 2 1)))
|
|
|
|
;=============== 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))))
|
|
|
|
;=============== coalesce ======================
|
|
(define (coalesce-not-empty default-lazy) (lambda (value) (if (null? value) (default-lazy) value)))
|
|
|
|
(assert-eq "coalesce-not-empty test 1 failed"
|
|
'(1)
|
|
((coalesce-not-empty (lambda () '(1))) '()))
|
|
|
|
(assert-eq "coalesce-not-empty test 2 failed"
|
|
'(2)
|
|
((coalesce-not-empty (lambda () '(1))) '(2)))
|
|
|
|
(assert-eq "coalesce-not-empty test 3 failed (wrong result)"
|
|
'(2)
|
|
((coalesce-not-empty (lambda () (display-ln "coalesce-not-empty test 3 failed (called default-lazy)")))
|
|
'(2)))
|
|
|
|
;=============== truthy-chaining ======================
|
|
(define (truthy-chaining f) (lambda (value) (if value (f value) #f)))
|
|
|
|
(assert-eq "coalesce-not-empty test 1 failed"
|
|
2
|
|
((truthy-chaining (lambda (x) (+ x 1))) 1))
|
|
|
|
(assert-eq "coalesce-not-empty test 2 failed"
|
|
#f
|
|
((truthy-chaining (lambda (x) (+ x 1))) #f))
|
|
|
|
;=============== compose-two ======================
|
|
(define (compose-two f g) (lambda (x) (f (g x))))
|
|
|
|
(assert-eq "compose-two test 1 failed"
|
|
6
|
|
((compose-two
|
|
(lambda (x) (* x 2))
|
|
(lambda (x) (+ x 2)))
|
|
1))
|
|
|
|
;=============== compose ======================
|
|
(define compose (reduce-right id compose-two))
|
|
|
|
(assert-eq "compose test 1 failed"
|
|
'(1 2 3 4)
|
|
((compose (list
|
|
(prepend 1)
|
|
(prepend 2)
|
|
(prepend 3)))
|
|
'(4)))
|
|
|
|
;=============== combine ======================
|
|
(define (combine combiner)
|
|
(lambda (a b) (if (null? a) b (if (null? b) a (combiner a b)))))
|
|
|
|
(assert-eq "combine test 1 failed"
|
|
'(1 3)
|
|
((combine (lambda (a b) (list (car a) (car b))))
|
|
'(1 2)
|
|
'(3 4)))
|
|
|
|
(assert-eq "combine test 1 failed"
|
|
'(1 2)
|
|
((combine (lambda (a b) (list (car a) (car b))))
|
|
'(1 2)
|
|
'()))
|
|
|
|
(assert-eq "combine test 1 failed"
|
|
'(3 4)
|
|
((combine (lambda (a b) (list (car a) (car b))))
|
|
'()
|
|
'(3 4)))
|
|
|
|
(assert-eq "combine test 1 failed"
|
|
'()
|
|
((combine (lambda (a b) (list (car a) (car b))))
|
|
'()
|
|
'()))
|
|
|
|
;=============== sum ======================
|
|
(define sum (reduce-right 0 +))
|
|
|
|
(assert-eq "sum test 1 failed"
|
|
6
|
|
(sum '(1 2 3)))
|
|
|
|
;=============== min-list ======================
|
|
(define min-list
|
|
(reduce-right #f
|
|
(lambda (current accumulator)
|
|
(if accumulator (min current accumulator) current))))
|
|
|
|
(assert-eq "min-list test 1 failed"
|
|
2
|
|
(min-list '(7 3 8 5 2 6 9)))
|
|
|
|
(assert-eq "min-list test 2 failed"
|
|
#f
|
|
(min-list '()))
|
|
|
|
;=============== remove-adjacent-duplicates ======================
|
|
(define remove-adjacent-duplicates
|
|
(reduce-right '()
|
|
(lambda (current accumulator)
|
|
(if
|
|
(and (not (null? accumulator)) (equal? current (car accumulator)))
|
|
accumulator
|
|
(cons current accumulator)))))
|
|
|
|
(assert-eq "remove-adjacent-duplicates test 1 failed"
|
|
'(1 2 3 4 3)
|
|
(remove-adjacent-duplicates '(1 1 2 3 3 4 3 3 3)))
|
|
|
|
;=============== repeat ======================
|
|
(define (repeat value) (Y
|
|
(lambda (f) (lambda (n)
|
|
(if (= n 0) '() (cons value (f (- n 1))))))))
|
|
|
|
(assert-eq "repeat test 1 failed"
|
|
'(1 1 1)
|
|
((repeat 1) 3))
|
|
|
|
;=============== value-by-index ======================
|
|
(define value-by-index (Y2
|
|
(lambda (f) (lambda (values index)
|
|
(if (= index 0) (car values) (f (cdr values) (- index 1)))))))
|
|
|
|
(assert-eq "value-by-index test 1 failed"
|
|
12
|
|
(value-by-index '(10 11 12 13 14) 2))
|
|
|
|
;=============== split ======================
|
|
(define (split predicate)
|
|
(reduce-right '(())
|
|
(lambda (current accumulator)
|
|
(if
|
|
(predicate current)
|
|
(cons '() accumulator)
|
|
(cons (cons current (car accumulator)) (cdr accumulator))))))
|
|
|
|
(assert-eq "split test 1 failed"
|
|
'((1 2) (3 4 5) (6 7))
|
|
((split (is 0))
|
|
'(1 2 0 3 4 5 0 6 7)))
|
|
|
|
(assert-eq "split test 2 failed"
|
|
'(() (1 2) () (3 4 5) (6 7) ())
|
|
((split (is 0))
|
|
'(0 1 2 0 0 3 4 5 0 6 7 0)))
|
|
|
|
;=============== chunks ======================
|
|
(define (chunks chunk-size)
|
|
(compose (list
|
|
cdr
|
|
(reduce-right '((1))
|
|
(lambda (current accumulator)
|
|
(if
|
|
(= chunk-size (car (car accumulator)))
|
|
(cons '(1) (cons (cons current (cdr (car accumulator))) (cdr accumulator)))
|
|
(cons (cons (+ 1 (car (car accumulator))) (cons current (cdr (car accumulator)))) (cdr accumulator))))))))
|
|
|
|
(assert-eq "chunks test 1 failed"
|
|
'((101 102 103) (104 105 106) (107 108 109) (110 111 112))
|
|
((chunks 3) '(101 102 103 104 105 106 107 108 109 110 111 112)))
|
|
|
|
;=============== range intersections ======================
|
|
(define symbol-in-first-range (quote in-first-range))
|
|
(define symbol-in-second-range (quote in-second-range))
|
|
(define symbol-in-both-ranges (quote in-both-ranges))
|
|
|
|
(define (get-range-intersections first-range-start first-range-end second-range-start second-range-end)
|
|
((compose (list
|
|
remove-adjacent-duplicates
|
|
(filter (lambda (range-intersection) (< (value-by-index range-intersection 1) (value-by-index range-intersection 2))))))
|
|
(list
|
|
(list symbol-in-first-range first-range-start (min first-range-end second-range-start))
|
|
(list symbol-in-first-range (max second-range-end first-range-start) first-range-end)
|
|
(list symbol-in-second-range second-range-start (min second-range-end first-range-start))
|
|
(list symbol-in-second-range (max first-range-end second-range-start) second-range-end)
|
|
(list symbol-in-both-ranges (max first-range-start second-range-start) (min first-range-end second-range-end)))))
|
|
|
|
(assert-eq "get-range-intersections test 1 (intersecting, first range lower) failed"
|
|
(list
|
|
(list symbol-in-first-range 10 20)
|
|
(list symbol-in-second-range 30 40)
|
|
(list symbol-in-both-ranges 20 30))
|
|
(get-range-intersections 10 30 20 40))
|
|
|
|
(assert-eq "get-range-intersections test 2 (intersecting, second range lower) failed"
|
|
(list
|
|
(list symbol-in-first-range 30 40)
|
|
(list symbol-in-second-range 10 20)
|
|
(list symbol-in-both-ranges 20 30))
|
|
(get-range-intersections 20 40 10 30))
|
|
|
|
(assert-eq "get-range-intersections test 3 (non-overlapping, first range lower) failed"
|
|
(list
|
|
(list symbol-in-first-range 10 20)
|
|
(list symbol-in-second-range 30 40))
|
|
(get-range-intersections 10 20 30 40))
|
|
|
|
(assert-eq "get-range-intersections test 4 (non-overlapping, second range lower) failed"
|
|
(list
|
|
(list symbol-in-first-range 30 40)
|
|
(list symbol-in-second-range 10 20))
|
|
(get-range-intersections 30 40 10 20))
|
|
|
|
(assert-eq "get-range-intersections test 5 (second inside first) failed"
|
|
(list
|
|
(list symbol-in-first-range 10 20)
|
|
(list symbol-in-first-range 30 40)
|
|
(list symbol-in-both-ranges 20 30))
|
|
(get-range-intersections 10 40 20 30))
|
|
|
|
(assert-eq "get-range-intersections test 6 (first inside second) failed"
|
|
(list
|
|
(list symbol-in-second-range 10 20)
|
|
(list symbol-in-second-range 30 40)
|
|
(list symbol-in-both-ranges 20 30))
|
|
(get-range-intersections 20 30 10 40))
|
|
|
|
(assert-eq "get-range-intersections test 7 (second inside first, same starts) failed"
|
|
(list
|
|
(list symbol-in-first-range 30 40)
|
|
(list symbol-in-both-ranges 20 30))
|
|
(get-range-intersections 20 40 20 30))
|
|
|
|
(assert-eq "get-range-intersections test 8 (second inside first, same ends) failed"
|
|
(list
|
|
(list symbol-in-first-range 20 30)
|
|
(list symbol-in-both-ranges 30 40))
|
|
(get-range-intersections 20 40 30 40))
|
|
|
|
(assert-eq "get-range-intersections test 9 (first inside second, same starts) failed"
|
|
(list
|
|
(list symbol-in-second-range 30 40)
|
|
(list symbol-in-both-ranges 20 30))
|
|
(get-range-intersections 20 30 20 40))
|
|
|
|
(assert-eq "get-range-intersections test 10 (first inside second, same ends) failed"
|
|
(list
|
|
(list symbol-in-second-range 20 30)
|
|
(list symbol-in-both-ranges 30 40))
|
|
(get-range-intersections 30 40 20 40))
|
|
|
|
(assert-eq "get-range-intersections test 11 (same ranges) failed"
|
|
(list
|
|
(list symbol-in-both-ranges 20 30))
|
|
(get-range-intersections 20 30 20 30))
|
|
|
|
;=============== solution data definitions ======================
|
|
(define symbol-current (quote current))
|
|
(define symbol-previous (quote previous))
|
|
|
|
(define (is-state-value-current state-entry) (equal? symbol-current (car state-entry)))
|
|
(define get-state-value cdr)
|
|
(define (create-state-value state-symbol) (lambda (range) (cons state-symbol range)))
|
|
(define create-state-value-current (create-state-value symbol-current))
|
|
(define create-state-value-previous (create-state-value symbol-previous))
|
|
(define (mark-state-value-previous state-entry) (create-state-value-previous (cdr state-entry)))
|
|
(define swap-state (compose (list
|
|
#!(tee-with-comment "state after swap")!#
|
|
(map mark-state-value-previous)
|
|
(filter is-state-value-current)
|
|
#!(tee-with-comment "state before swap")!#)))
|
|
|
|
(define (create-range start end) (list start end))
|
|
(define (create-range-from-input input) (create-range
|
|
(car input)
|
|
(+ (car input) (car (cdr input)))))
|
|
(define get-range-start car)
|
|
(define get-range-end (compose (list car cdr)))
|
|
|
|
(define (create-map numbers) (list
|
|
;; convert it from destination_start, source_start, length
|
|
;; to source_start, source_end, destination_start
|
|
(value-by-index numbers 1)
|
|
(+ (value-by-index numbers 1) (value-by-index numbers 2))
|
|
(value-by-index numbers 0)))
|
|
|
|
(define (get-map-source-start seed-map) (value-by-index seed-map 0))
|
|
(define (get-map-source-end seed-map) (value-by-index seed-map 1))
|
|
(define (get-map-destination-start seed-map) (value-by-index seed-map 2))
|
|
|
|
;=============== solution ======================
|
|
(define (apply-map-to-range map-source-start map-source-end map-destination-start range-start range-end)
|
|
((compose (list
|
|
(map (lambda (intersection)
|
|
(if
|
|
(equal? symbol-in-both-ranges (car intersection))
|
|
(create-state-value-current
|
|
(create-range
|
|
(+ map-destination-start (- (get-range-start (cdr intersection)) map-source-start))
|
|
(+ map-destination-start (- (get-range-end (cdr intersection)) map-source-start))))
|
|
(create-state-value-previous (create-range (get-range-start (cdr intersection)) (get-range-end (cdr intersection)))))))
|
|
(filter (lambda (intersection)
|
|
(or
|
|
(equal? symbol-in-second-range (car intersection))
|
|
(equal? symbol-in-both-ranges (car intersection)))))))
|
|
(get-range-intersections map-source-start map-source-end range-start range-end)))
|
|
|
|
(define (apply-map-to-previous-state-value seed-map state-value)
|
|
(apply-map-to-range
|
|
(get-map-source-start seed-map)
|
|
(get-map-source-end seed-map)
|
|
(get-map-destination-start seed-map)
|
|
(get-range-start state-value)
|
|
(get-range-end state-value)))
|
|
|
|
(define seed-maps-processor
|
|
(compose (list
|
|
;; for list of maps (within a single map set); returns state-transforming lambda
|
|
compose
|
|
#!(prepend (tee-with-comment "state after applying mapset"))!#
|
|
(append swap-state)
|
|
(map (lambda (seed-map)
|
|
;; for seed map within the list: returns state-transforming lambda
|
|
(compose (list
|
|
flat
|
|
(map (lambda (state-entry)
|
|
;; for seed map _and_ single range from state, returns list of new ranges
|
|
(if
|
|
(is-state-value-current state-entry)
|
|
(list state-entry)
|
|
(apply-map-to-previous-state-value seed-map (get-state-value state-entry))))))))))))
|
|
|
|
(define parse-seed-maps
|
|
(compose (list
|
|
;; for list of map lines (within a single map set)
|
|
(prepend '(0 4294967295 0))
|
|
(map (compose (list
|
|
;; for map line
|
|
create-map
|
|
(map (compose (list
|
|
;; for number in map line
|
|
string->number
|
|
list->string)))
|
|
(split (is #\space))
|
|
string->list
|
|
)))
|
|
cdr)))
|
|
|
|
(define parse-initial
|
|
(compose (list
|
|
(map (compose (list
|
|
create-state-value-current
|
|
create-range-from-input)))
|
|
(chunks 2)
|
|
(map (compose (list
|
|
string->number
|
|
list->string)))
|
|
cdr
|
|
(split (is #\space))
|
|
string->list)))
|
|
|
|
(define (final-state lines)
|
|
(((compose (list
|
|
compose
|
|
(map seed-maps-processor)
|
|
(map parse-seed-maps)
|
|
reverse
|
|
(filter is-not-empty)
|
|
(split (is ""))))
|
|
(cdr lines))
|
|
(parse-initial (car lines))))
|
|
|
|
(define solve-all
|
|
(compose (list
|
|
min-list
|
|
(map get-range-start)
|
|
(map get-state-value)
|
|
(filter is-state-value-current)
|
|
final-state)))
|
|
|
|
(display (solve-all (read-lines)))
|
|
|