advent-of-code-2022/day-15/part-02.scm

(import
 (except (rnrs base)
         let-values
         map
         error
         vector-map)
 (only (guile)
       lambda* λ
       simple-format
       current-output-port)
 (fileio)
 (ice-9 pretty-print)
 (ice-9 peg)
 (ice-9 match)
 (prefix (peg-tree-utils) peg-tree:)
 ;; (ice-9 format)
 (srfi srfi-1)
 (pipeline)
 (debug)
 ;; (list-helpers)
 (array-helpers)
 (segment)
 (parallelism)
 ;; (math)
 ;; (logic)
 ;; receive
 ;; (srfi srfi-8)
 (srfi srfi-9 gnu)
 ;; let-values
 ;; (srfi srfi-11)
 ;; purely functional data structures
 ;; (pfds sets)
 ;; (timing)
 )


(define input-filename "input")

(define-peg-pattern NUMBER body (and (? (or "-" "+")) (+ (range #\0 #\9))))
(define-peg-pattern ANYTHING-EXCEPT-NUMBER none
  (* (and (not-followed-by NUMBER) peg-any)))
(define-peg-pattern COORD all NUMBER)

(define-peg-pattern SENSOR-INFO body
  (and (and ANYTHING-EXCEPT-NUMBER COORD)
       (and ANYTHING-EXCEPT-NUMBER COORD)
       (and ANYTHING-EXCEPT-NUMBER COORD)
       (and ANYTHING-EXCEPT-NUMBER COORD)))

(define-immutable-record-type <sensor>
  (make-sensor sy sx by bx)
  sensor?
  (sy sensor-y set-sensor-y)
  (sx sensor-x set-sensor-x)
  (by sensor-beacon-y set-sensor-beacon-y)
  (bx sensor-beacon-x set-sensor-beacon-x))


(define parse-sensors
  (λ (line)
    (-> line
        (match-pattern SENSOR-INFO)
        peg:tree
        (map (λ (coord) (string->number (second coord))))
        ((λ (coords)
           (match coords
             [(sensor-x sensor-y beacon-x beacon-y)
              (make-sensor sensor-y sensor-x beacon-y beacon-x)]))))))


(define sensors
  (-> (get-lines-from-file input-filename)
      (map parse-sensors)))


(define manhattan-distance
  (λ (y1 x1 y2 x2)
    (+ (abs (- y1 y2))
       (abs (- x1 x2)))))


(define calc-blocked-segment
  (λ (sensor line-y)
    (match sensor
      [($ <sensor> sy sx by bx)
       (let ([distance-to-line (abs (- sy line-y))]
             [distance-to-beacon (manhattan-distance sy sx by bx)])
         (let ([delta-x (- distance-to-beacon distance-to-line)])
           (cond
            [(>= delta-x 0)
             (cons (- sx delta-x)
                   (+ sx delta-x))]
            [else #f])))])))


(define make-range
  (λ (start end)
    (cons start end)))


(define range-start
  (λ (range)
    (car range)))


(define range-end
  (λ (range)
    (cdr range)))


(define range+
  (λ (r1 r2)
    "Assumes, that the lower number is the first part of a
range."
    (make-range (min (range-start r1) (range-start r2))
                (max (range-end r1) (range-end r2)))))


(define ranges-less
  (λ (r1 r2)
    (or (< (range-start r1) (range-start r2))
        (and (= (range-start r1) (range-start r2))
             (< (range-end r1) (range-end r2))))))


(define find-not-blocked
  (λ (ranges limit-lower-x limit-upper-x)
    "Sum length all the blocked RANGES from LIMIT-LOWER-X to
LIMIT-UPPER-X."
    (let ([sorted-ranges (sort ranges ranges-less)])
      (let iter ([ranges° sorted-ranges] [max-x limit-lower-x])
        (cond
         [(null? ranges°) #f]
         ;; We are past the area where the beacon is
         ;; supposed to be. No gaps found.
         [(>= max-x limit-upper-x) #f]
         [else
          (let ([current-range (car ranges°)])
            (cond
             ;; Current range is completely outside of
             ;; already counted blocked, because its start
             ;; is already past the highest seen x.
             [(< max-x (range-start current-range))
              ;; Apparently we have found a gap. Since the
              ;; puzzle says there is only 1 gap, we can
              ;; assume, that it must be the position after
              ;; max-x.
              (+ max-x 1)]
             ;; Start of current range is equal than the
             ;; highest seen x. This means, that the range
             ;; starts, not leaving a gap between already
             ;; counted blocked and its fields.
             [(= max-x (range-start current-range))
              (iter (cdr ranges°)
                    ;; Do not go over the upper limit for x.
                    (min (range-end current-range)
                         limit-upper-x))]
             ;; The start of the current range is before the
             ;; highest max-x we have seen so far. That
             ;; means there is overlap.
             [else
              (iter (cdr ranges°)
                    ;; Do not go over the upper limit for x.
                    (min (max (range-end current-range) max-x)
                         limit-upper-x))]))])))))


(define identity (λ (x) x))


(define check-line
  (λ (sensors limit-lower-x limit-upper-x line-y)
    (-> sensors
        ;; calculate the blocked ranges for each sensor
        (map (λ (sensor) (calc-blocked-segment sensor line-y)) #|sensors|#)
        ;; filter out any #f values, which stand for "no blocked range"
        (filter identity #|ranges|#)
        ((λ (blocked-ranges) (sort blocked-ranges ranges-less)))
        ;; calculate the length of the blocked ranges
        ((λ (ranges)
           (find-not-blocked ranges limit-lower-x limit-upper-x))
         #|ranges|#)
        ((λ (line-x/false)
           (if line-x/false
               (cons line-y line-x/false)
               #f)))
        )))


(define check-lines
  (λ (sensors limit-lower-x limit-upper-x line-ys)
    "Give all line-y of LINE-YS, which have any positions, where
a beacon could be located. Should only return a single
line-y or an empty list."
    (-> line-ys
        ;; for all given line-ys (rows) check, whether there
        ;; is any line, which has at least 1 non-blocked
        ;; position
        (segment-map (λ (line-y)
                       (check-line sensors limit-lower-x limit-upper-x line-y))
                     #|line-ys|#)
        (filter identity)
        )))


(define tuning-frequency
  (λ (y x)
    (+ (* x (* 4 (expt 10 6))) y)))


(define limit-lower-y 0)
(define limit-upper-y #;20 (* 4 (expt 10 6)))
(define limit-lower-x 0)
(define limit-upper-x #;20 (* 4 (expt 10 6)))

(define line-partitions
  (let ([start limit-lower-y]
        [end limit-upper-y]
        [num-cores 32])
    (segment start end num-cores)))


(define distress-beacon-locations
  (run-in-parallel line-partitions
                   (λ (line-ys _ind)
                     (check-lines sensors limit-lower-x limit-upper-x line-ys))
                   (λ (res acc)
                     (cond
                      [(null? res) acc]
                      [else res]))
                   '()))


(simple-format
 #t "solution: ~a\n"
 (tuning-frequency (car (first distress-beacon-locations))
                   (cdr (first distress-beacon-locations))))