(import (chicken fixnum) (chicken sort) (chicken string) (chicken keyword) (chicken irregex)) (define input " seeds: 364807853 408612163 302918330 20208251 1499552892 200291842 3284226943 16030044 2593569946 345762334 3692780593 17215731 1207118682 189983080 2231594291 72205975 3817565407 443061598 2313976854 203929368 seed-to-soil map: 2069473506 3732587455 1483883 3235691256 2348990120 6550341 3547561069 1392195671 747406227 3264251584 3734071338 283309485 391285622 257757572 195552540 1645243555 3166958320 377191689 335002083 512210869 56283539 3242241597 897735089 22009987 77244511 0 257757572 989159646 4172023334 122943962 605476380 3544150009 188437446 0 568494408 18343754 2700122696 4050276683 121746651 2022435244 2139601898 47038262 2227672101 919745076 95840269 1112103608 2633818373 533139947 826809686 2186640160 162349960 3100147259 762191092 135543997 18343754 453310112 58900757 2323512370 1015585345 282396986 2605909356 1297982331 94213340 2821869347 2355540461 278277912 793913826 4017380823 32895860 2070957389 605476380 156714712 soil-to-fertilizer map: 2700214958 2743391193 363795571 1484584575 1440072796 24660284 927520818 435059068 191969051 1588488926 1434420334 5652462 1423277199 141187887 5443857 1594141388 1350997453 83422881 1986188257 3933008893 120750463 1509244859 146631744 79093544 3712482038 4220862006 74105290 3948206286 1986188257 277570873 291046304 281588807 153470261 1119489869 918224946 303787330 1677564269 1321192605 29804848 2309878676 2336743687 390336282 3079951473 3306332300 449116691 444516565 1222012276 99180329 543696894 1464733080 383823924 3895169406 3771389935 53036880 3529068164 4053759356 167102650 0 627178642 291046304 3696170814 2727079969 16311224 3855550220 3824426815 39619186 2106938720 3107186764 199145536 1428721056 225725288 55863519 1707369117 0 64378064 1771747181 64378064 76809823 3064010529 3755448991 15940944 2306084256 2332949267 3794420 4225777159 2263759130 69190137 3786587328 3864046001 68962892 1588338403 627028119 150523 fertilizer-to-water map: 2299879115 39069388 7889905 514481680 504392888 101474410 3448524168 0 25428313 13641075 1832356728 472401611 0 25428313 13641075 1842445520 108629584 395763304 486042686 3445513487 28438994 2307769020 2304758339 1140755148 2238208824 46959293 61670291 615956090 605867298 1226489430 water-to-light map: 1318826171 2010420436 223477535 2278894745 2233897971 671603259 988189854 447584401 27746374 2132052210 300741866 146842535 0 1279660741 97125596 3531244480 3147213622 507810286 257581844 3816963790 101424269 1298609589 3918388059 20216582 3317726838 1072550929 21856732 3065323607 1254863909 4121973 97125596 1094407661 160456248 359006113 1057194484 15356445 374362558 1636971609 104335413 4039054766 475330775 9209679 1038424317 1376786337 260185272 878530050 3938604641 109659804 1784016098 3738041092 78922698 3152462764 0 165264074 1862938796 1741307022 269113414 497536930 676201364 380993120 3069445580 3655023908 83017184 2950498004 165264074 114825603 1015936228 1258985882 1835900 478697971 1260821782 18838959 1017772128 280089677 20652189 1542303706 2905501230 241712392 3339583570 484540454 191660910 light-to-temperature map: 2827696039 489007811 183207687 1480301347 3744628626 306791400 695239418 130668965 358338846 1297125534 2232912413 183175813 3979319170 1917264287 315648126 3010903726 948848843 968415444 130668965 2663473525 564570453 1053578264 4051420026 243547270 2303677395 672215498 276633345 1787092747 3228043978 516584648 2580310740 2416088226 247385299 temperature-to-humidity map: 4161466647 3871737509 133500649 2423686895 2864370860 72123408 1983529997 0 320533964 3184295196 2695571092 41928210 0 822932241 605870242 3557076981 3267347843 604389666 3226223406 2936494268 330853575 2495810303 2737499302 126871558 1108268519 1428802483 491674128 605870242 320533964 502398277 2622681861 2423686895 271884197 2894566058 4005238158 289729138 1599942647 1920476611 383587350 humidity-to-location map: 2945628300 1864953738 334378942 3467273713 3579654586 715312710 975015905 1356290883 508662855 1483678760 2498980024 1080674562 3443998409 2199332680 23275304 3280007242 2222607984 163991167 4182586423 2386599151 112380873 2564353322 975015905 381274978 ") (define-record entity type id) (define-record mapping-entry from-type to-type from-start from-end to-start to-end) (define seed-irregex '(: (* whitespace) "seeds: " (submatch-named seed-numbers (+ (or numeric whitespace))))) (define mapping-irregex '(: (submatch-named mapping-from (+ alphabetic)) "-to-" (submatch-named mapping-to (+ alphabetic)) " map:" (submatch-named mapping-vals (+ (or numeric whitespace))))) (define mapping-nums-irregex '(: (* whitespace) (submatch-named to-range (+ numeric)) (* whitespace) (submatch-named from-range (+ numeric)) (* whitespace) (submatch-named range-size (+ numeric)))) (define (input->seeds-list input) (let ((seeds-str (irregex-match-substring (irregex-search seed-irregex input) 'seed-numbers))) (map string->number (string-split seeds-str)))) (define (input->mapping-alist input) (irregex-fold mapping-irregex (lambda (from-index match seed) (let ((map-from-key (string->keyword (irregex-match-substring match 'mapping-from))) (map-to-key (string->keyword (irregex-match-substring match 'mapping-to))) (mapping-vals-str (irregex-match-substring match 'mapping-vals))) (cons (cons map-from-key (irregex-fold mapping-nums-irregex (lambda (from-index match seed) (let ((from-start (string->number (irregex-match-substring match 'from-range))) (to-start (string->number (irregex-match-substring match 'to-range))) (range-size (string->number (irregex-match-substring match 'range-size)))) (cons (make-mapping-entry map-from-key map-to-key from-start (fx- (fx+ from-start range-size) 1) to-start (fx- (fx+ to-start range-size) 1)) seed))) '() mapping-vals-str)) seed))) '() input)) (define (map-entity-forward entity mapping-alist) (let ((maplist (alist-ref (entity-type entity) mapping-alist))) (if maplist (let ((default-target-type (mapping-entry-to-type (car maplist)))) (or (foldl (lambda (new-entity mapping-entry) (if (and (fx>= (entity-id entity) (mapping-entry-from-start mapping-entry)) (fx<= (entity-id entity) (mapping-entry-from-end mapping-entry))) (make-entity (mapping-entry-to-type mapping-entry) (fx+ (mapping-entry-to-start mapping-entry) (fx- (entity-id entity) (mapping-entry-from-start mapping-entry)))) new-entity)) #f maplist) (make-entity default-target-type (entity-id entity)))) #f))) (define (map-entity-forward-fully entity mapping-alist) (let ((new-entity (map-entity-forward entity mapping-alist))) (if new-entity (map-entity-forward-fully new-entity mapping-alist) entity))) (define (calc-part-1) (let ((seeds (map (cut make-entity #:seed <>) (input->seeds-list input))) (mapping-alist (input->mapping-alist input))) (apply min (map (compose entity-id (cut map-entity-forward-fully <> mapping-alist)) seeds)))) (define (expand-seed existing-seeds start size) (let ((max (- (+ start size) 1))) (do ((seedlist (cons start existing-seeds) (cons (+ (car seedlist) 1) seedlist))) ((< (- max 2) (car seedlist)) seedlist)))) (define (expand-seeds seed-nums #!optional (existing-seeds '())) (if (< 2 (length seed-nums)) (expand-seeds (cddr seed-nums) (delay-force (expand-seed existing-seeds (car seed-nums) (cadr seed-nums)))) (expand-seed existing-seeds (car seed-nums) (cadr seed-nums)))) (define (fold-seeds seeds mapping-alist #!optional (minimum most-positive-fixnum)) (let* ((seeds (if (promise? seeds) (force seeds) seeds)) (seeds-available? (not (eqv? '() seeds)))) (if seeds-available? (let ((location-entity-id ((compose entity-id (cut map-entity-forward-fully <> mapping-alist) (cut make-entity #:seed <>)) (car seeds)))) (fold-seeds (cdr seeds) mapping-alist (min minimum location-entity-id))) minimum))) (define (calc-part-2) (let ((seeds (expand-seeds (input->seeds-list input))) (mapping-alist (input->mapping-alist input))) (fold-seeds seeds mapping-alist))) (define-record ranged-entity type from-id to-id) (define (extract-dangling-entity-part ranged-entity type mapping-entry) (let ((mapping-entry-lower-bound (mapping-entry-from-start mapping-entry))) (values (make-ranged-entity type (ranged-entity-from-id ranged-entity) (- mapping-entry-lower-bound 1)) (make-ranged-entity (ranged-entity-type ranged-entity) mapping-entry-lower-bound (ranged-entity-to-id ranged-entity))))) (define (extract-matching-entity-part ranged-entity type mapping-entry) (let* ((mapping-entry-lower-bound (mapping-entry-from-start mapping-entry)) (mapping-entry-upper-bound (mapping-entry-from-end mapping-entry)) (mapping-entry-target-start (mapping-entry-to-start mapping-entry)) (ranged-entity-lower-bound (ranged-entity-from-id ranged-entity)) (ranged-entity-upper-bound (ranged-entity-to-id ranged-entity)) (start-offset (- ranged-entity-lower-bound mapping-entry-lower-bound)) (first-index (max ranged-entity-lower-bound mapping-entry-lower-bound)) (last-index (min ranged-entity-upper-bound mapping-entry-upper-bound)) (range-size (- last-index first-index)) (matches-mapping? (= ranged-entity-upper-bound mapping-entry-upper-bound)) (exceeds-mapping? (> ranged-entity-upper-bound mapping-entry-upper-bound))) (values (make-ranged-entity type (+ mapping-entry-target-start start-offset) (+ mapping-entry-target-start start-offset range-size)) (if exceeds-mapping? (make-ranged-entity (ranged-entity-type ranged-entity) (+ mapping-entry-upper-bound 1) ranged-entity-upper-bound) #f)))) (define (map-dangling-entity ranged-entity type) (values (make-ranged-entity type (ranged-entity-from-id ranged-entity) (ranged-entity-to-id ranged-entity)) #f)) (define (map-ranged-entity-forward ranged-entity type level-mappings) (let ((processed-ranged-entity #f) (remaining-ranged-entity #f) (retry? #f)) (cond ((eqv? '() ranged-entity) '()) ((eqv? '() level-mappings) (let-values (((processed-ranged-entity* remaining-ranged-entity*) (map-dangling-entity ranged-entity type))) (set! processed-ranged-entity processed-ranged-entity*) (set! remaining-ranged-entity remaining-ranged-entity*))) ((and (>= (ranged-entity-from-id ranged-entity) (mapping-entry-from-start (car level-mappings))) (<= (ranged-entity-from-id ranged-entity) (mapping-entry-from-end (car level-mappings)))) (let-values (((processed-ranged-entity* remaining-ranged-entity*) (extract-matching-entity-part ranged-entity type (car level-mappings)))) (set! processed-ranged-entity processed-ranged-entity*) (set! remaining-ranged-entity remaining-ranged-entity*))) ((> (ranged-entity-from-id ranged-entity) (mapping-entry-from-end (car level-mappings))) (set! retry? #t)) (else (let-values (((processed-ranged-entity* remaining-ranged-entity*) (extract-dangling-entity-part ranged-entity type (car level-mappings)))) (set! processed-ranged-entity processed-ranged-entity*) (set! remaining-ranged-entity remaining-ranged-entity*)))) (if retry? (map-ranged-entity-forward ranged-entity type (cdr level-mappings)) (if remaining-ranged-entity (cons processed-ranged-entity (map-ranged-entity-forward remaining-ranged-entity type (cdr level-mappings))) (list processed-ranged-entity))))) (define (map-ranged-entity-forward-fully ranged-entity mapping-alist) (let ((mappings (alist-ref (ranged-entity-type ranged-entity) mapping-alist))) (if (and (not (eqv? '() mappings)) mappings) (let* ((mappings-alist (map (lambda (x) (cons (mapping-entry-from-start x) x)) mappings)) (sorted-mapping-ids (sort (map car mappings-alist) <)) (sorted-mappings (map (cut alist-ref <> mappings-alist) sorted-mapping-ids)) (new-type (mapping-entry-to-type (car sorted-mappings))) (new-entities (map-ranged-entity-forward ranged-entity new-type sorted-mappings))) (foldl append '() (map (cut map-ranged-entity-forward-fully <> mapping-alist) new-entities))) (list ranged-entity)))) (define (seeds-list->ranged-entities seeds) (if (<= 2 (length seeds)) (cons (make-ranged-entity #:seed (car seeds) (- (+ (car seeds) (cadr seeds)) 1)) (seeds-list->ranged-entities (cddr seeds))) '())) (define (calc-part-2-optimized) (let ((seeds (seeds-list->ranged-entities (input->seeds-list input))) (mapping-alist (input->mapping-alist input))) (foldl min most-positive-fixnum (map ranged-entity-from-id (foldl append '() (map (cut map-ranged-entity-forward-fully <> mapping-alist) seeds))))))