#!/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))) ;=============== 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))) ;=============== 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))) ;=============== 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 seed-maps) (compose (list ;; for state #!(tee-with-comment "state after applying mapset")!# ((compose (list ;; for list of maps (within a single map set); returns state-transforming lambda compose (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))))))))))) seed-maps) swap-state))) (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)))