day 5, part 2

day05-hard/main.scm

@@ -0,0 +1,499 @@
+#!/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 '()))
+
+;=============== repeat ======================
+(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)))
+
+;=============== split ======================
+(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 ======================
+(define symbol-current (quote current))
+(define symbol-previous (quote previous))
+
+(define (mark-state-value-previous state-entry) (cons symbol-previous (cdr state-entry)))
+(define (is-state-value-current state-entry) (equal? symbol-current (car state-entry)))
+(define get-state-value cdr)
+(define create-state-value cons)
+(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 parse-initial
+  (compose (list
+    (map (lambda (raw-range) (create-state-value symbol-current (create-range-from-input raw-range))))
+    (chunks 2)
+    (map (compose (list
+      string->number
+      list->string)))
+    cdr
+    (split (is #\space))
+    string->list)))
+
+(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))
+
+(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 symbol-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 symbol-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 (apply-map-to-state-entry seed-map)
+  (lambda (state-entry)
+    (if
+      (is-state-value-current state-entry)
+      (list state-entry)
+      (apply-map-to-previous-state-value seed-map (get-state-value state-entry)))))
+
+(define (apply-map-to-state seed-map)
+  (compose (list
+    flat
+    (map (apply-map-to-state-entry seed-map)))))
+
+(define (seed-maps-processor raw-seed-maps)
+  (compose (list
+    ;; for state
+    #!(tee-with-comment "state after applying mapset")!#
+    ((compose (list
+      ;; for list of map lines (within a single map set); should return state-transforming lambda
+      compose
+      (map apply-map-to-state)
+      #!(tee-with-comment "current mapset")!#
+      (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
+      )))
+      #!(tee-with-comment "raw seed maps without prefix")!#
+      cdr))
+      raw-seed-maps)
+    swap-state)))
+
+(define (final-state lines)
+  (((compose (list
+    compose
+    (map seed-maps-processor)
+    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)))

day05-hard/sample.in

@@ -0,0 +1,33 @@
+seeds: 79 14 55 13
+
+seed-to-soil map:
+50 98 2
+52 50 48
+
+soil-to-fertilizer map:
+0 15 37
+37 52 2
+39 0 15
+
+fertilizer-to-water map:
+49 53 8
+0 11 42
+42 0 7
+57 7 4
+
+water-to-light map:
+88 18 7
+18 25 70
+
+light-to-temperature map:
+45 77 23
+81 45 19
+68 64 13
+
+temperature-to-humidity map:
+0 69 1
+1 0 69
+
+humidity-to-location map:
+60 56 37
+56 93 4