day05.scm - advent-of-code - Perserverance, or the lack thereof

day05.scm (6660B)

    1 (use-modules (ice-9 popen))
    2 (use-modules (ice-9 rdelim))
    3 (use-modules (ice-9 format))
    4 (use-modules (ice-9 receive))
    5 (use-modules (srfi srfi-1))
    6 
    7 (define (parse-numbers numbers)
    8   (filter (lambda (x) x) (map string->number (string-split numbers #\ ))))
    9 
   10 (define (parse-map file)
   11   (let ((parsed-map '()))
   12     (while #t
   13            (let ((line (car (%read-line file))))
   14              (cond ((or (eof-object? line) (string-null? line)) (break))
   15                    (#t (set! parsed-map (cons (parse-numbers line) parsed-map))))))
   16     (reverse parsed-map)))
   17 
   18 (define (parse-input filename)
   19   (let ((file (open-input-file filename))
   20         (seeds '())
   21         (seed-to-soil-map '())
   22         (soil-to-fertilizer-map '())
   23         (fertilizer-to-water-map '())
   24         (water-to-light-map '())
   25         (light-to-temperature-map '())
   26         (temperature-to-humidity-map '())
   27         (humidity-to-location-map '()))
   28     (let ((line (car (%read-line file))))
   29       (set! seeds (parse-numbers (car (cdr (string-split line #\:))))))
   30     (%read-line file)
   31     (while #t
   32            (let ((line (car (%read-line file))))
   33              (cond ((eof-object? line) (break))
   34                    ((string-prefix? line "seed-to-soil map:") (set! seed-to-soil-map (parse-map file)))
   35                    ((string-prefix? line "soil-to-fertilizer map:") (set! soil-to-fertilizer-map (parse-map file)))
   36                    ((string-prefix? line "fertilizer-to-water map:") (set! fertilizer-to-water-map (parse-map file)))
   37                    ((string-prefix? line "soil-to-fertilizer map:") (set! soil-to-fertilizer-map (parse-map file)))
   38                    ((string-prefix? line "fertilizer-to-water map:") (set! fertilizer-to-water-map (parse-map file)))
   39                    ((string-prefix? line "water-to-light map:") (set! water-to-light-map (parse-map file)))
   40                    ((string-prefix? line "light-to-temperature map:") (set! light-to-temperature-map (parse-map file)))
   41                    ((string-prefix? line "temperature-to-humidity map:") (set! temperature-to-humidity-map (parse-map file)))
   42                    ((string-prefix? line "humidity-to-location map:") (set! humidity-to-location-map (parse-map file))))))
   43     (values seeds seed-to-soil-map soil-to-fertilizer-map fertilizer-to-water-map water-to-light-map light-to-temperature-map temperature-to-humidity-map humidity-to-location-map)))
   44 
   45 (define (convert-number x maps)
   46   (let ((dest-start (car maps))
   47         (src-start (car (cdr maps)))
   48         (map-length (car (cdr (cdr maps)))))
   49     (if (and (>= x src-start) (< x (+ src-start map-length)))
   50         (+ dest-start (- x src-start))
   51         #f)))
   52 
   53 (define (src-to-dest src maps)
   54   (if (null? maps)
   55       src
   56       (let ((res (convert-number src (car maps))))
   57         (if (not res)
   58             (src-to-dest src (cdr maps))
   59             res))))
   60 
   61 (define (srcs-to-dests srcs maps)
   62   (map (lambda (src) (src-to-dest src maps)) srcs))
   63 
   64 (receive (seeds seed-to-soil-map soil-to-fertilizer-map fertilizer-to-water-map water-to-light-map light-to-temperature-map temperature-to-humidity-map humidity-to-location-map)
   65     (parse-input "input.txt")
   66   (let* ((curr seeds)
   67          (curr (srcs-to-dests curr seed-to-soil-map))
   68          (curr (srcs-to-dests curr soil-to-fertilizer-map))
   69          (curr (srcs-to-dests curr fertilizer-to-water-map))
   70          (curr (srcs-to-dests curr water-to-light-map))
   71          (curr (srcs-to-dests curr light-to-temperature-map))
   72          (curr (srcs-to-dests curr temperature-to-humidity-map))
   73          (curr (srcs-to-dests curr humidity-to-location-map))
   74          (lowest-location (reduce (lambda (x y) (min x y)) #nil curr)))
   75     ;; 175622908
   76     (format #t "Part 1: ~d" lowest-location)
   77     (newline)))
   78 
   79 (define (between x a b)
   80   (and (>= x a) (<= x b)))
   81 
   82 (define (startend-to-range start end)
   83   (cons start (1+ (- end start))))
   84 
   85 (define (range-intersect a-start a-length b-start b-length)
   86   (let ((a-end (1- (+ a-start a-length)))
   87         (b-end (1- (+ b-start b-length))))
   88     (cond ((or (< a-end b-start) (> a-start b-end))
   89            (values #nil (list (cons a-start a-length))))
   90           ((and (< a-start b-start) (between a-end b-start b-end))
   91            (values (startend-to-range b-start a-end) (list (startend-to-range a-start (1- b-start)))))
   92           ((and (between a-start b-start b-end) (> a-end b-end))
   93            (values (startend-to-range a-start b-end) (list (startend-to-range (1+ b-end) a-end))))
   94           ((and (>= a-start b-start) (<= a-end b-end))
   95            (values (startend-to-range a-start a-end) '()))
   96           ((and (< a-start b-start) (> a-end b-end))
   97            (values (startend-to-range b-start b-end) (list (startend-to-range a-start (1- b-start)) (startend-to-range (1+ b-end) a-end)))))))
   98 
   99 (define (src-range-to-dest-ranges x-range maps)
  100   (if (null? maps)
  101       (list x-range)
  102       (let ((x-start (car x-range))
  103             (x-length (cdr x-range))
  104             (dest-start (car (car maps)))
  105             (src-start (car (cdr (car maps))))
  106             (map-length (car (cdr (cdr (car maps)))))
  107             (res '()))
  108         (receive (mapped unmapped) (range-intersect x-start x-length src-start map-length)
  109           (if (not (null? mapped))
  110               (set! res (cons (cons (+ dest-start (- (car mapped) src-start)) (cdr mapped)) res)))
  111           (fold append res (map (lambda (r) (src-range-to-dest-ranges r (cdr maps))) unmapped))))))
  112 
  113 (define (src-ranges-to-dest-ranges srcs maps)
  114   (fold append '() (map (lambda (src) (src-range-to-dest-ranges src maps)) srcs)))
  115 
  116 (define (make-pairs inputs)
  117   (if (null? inputs)
  118       '()
  119       (cons (cons (car inputs) (car (cdr inputs))) (make-pairs (cdr (cdr inputs))))))
  120 
  121 (receive (seed-ranges-raw seed-to-soil-map soil-to-fertilizer-map fertilizer-to-water-map water-to-light-map light-to-temperature-map temperature-to-humidity-map humidity-to-location-map)
  122     (parse-input "input.txt")
  123   (let* ((curr (make-pairs seed-ranges-raw))
  124          (curr (src-ranges-to-dest-ranges curr seed-to-soil-map))
  125          (curr (src-ranges-to-dest-ranges curr soil-to-fertilizer-map))
  126          (curr (src-ranges-to-dest-ranges curr fertilizer-to-water-map))
  127          (curr (src-ranges-to-dest-ranges curr water-to-light-map))
  128          (curr (src-ranges-to-dest-ranges curr light-to-temperature-map))
  129          (curr (src-ranges-to-dest-ranges curr temperature-to-humidity-map))
  130          (curr (src-ranges-to-dest-ranges curr humidity-to-location-map))
  131          (curr-starts (map (lambda (x) (car x)) curr))
  132          (lowest-location (reduce (lambda (x y) (min x y)) #nil curr-starts)))
  133     ;; 5200543
  134     (format #t "Part 2: ~d" lowest-location)
  135     (newline)))