advent-of-code-2022/day-14/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)
 (prefix (peg-tree-utils) peg-tree:)
 ;; (ice-9 format)
 (srfi srfi-1)
 (pipeline)
 (debug)
 (list-helpers)
 (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 COMMA none ",")
(define-peg-pattern ARROW none "->")
(define-peg-pattern SPACE none " ")
(define-peg-pattern SEPARATOR none (and SPACE ARROW SPACE))
(define-peg-pattern NUMBER body (+ (range #\0 #\9)))
(define-peg-pattern COORD all NUMBER)
(define-peg-pattern COORDS all (and COORD COMMA COORD))
(define-peg-pattern COORDS-LIST all (* (and COORDS (? SEPARATOR))))


(define-immutable-record-type <pos>
  (make-pos y x)
  coord?
  (x position-x set-position-x)
  (y position-y set-position-y))

(define-immutable-record-type <segment>
  (make-segment start end)
  segment?
  (start segment-start set-segment-start)
  (end segment-end set-segment-end))

(define-immutable-record-type <rock-path>
  (make-rock-path rock-segments)
  rock-path?
  (rock-segments rock-path-segments set-rock-path-segments))


(define extract-parsed-poss
  (λ (parsed-coords-lists)
    (map (λ (line)
           (peg:tree (match-pattern COORDS-LIST line)))
         parsed-coords-lists)))


(define parsed-pos->pos
  (λ (parsed-pos)
    (make-pos (-> parsed-pos third second string->number)
              (-> parsed-pos second second string->number))))


(define parsed-poss->poss
  (λ (parsed-poss)
    (map parsed-pos->pos (drop parsed-poss 1))))


(define poss->segments
  (λ (coords)
    (let iter ([start° (car coords)]
               [segments° '()]
               [coords° (cdr coords)])
      (cond
       [(null? coords°) segments°]
       [else
        (iter (car coords°)
              (cons (make-segment start° (car coords°))
                    segments°)
              (cdr coords°))]))))


(define all-positions
  (-> (get-lines-from-file input-filename)
      extract-parsed-poss
      (map (λ (parsed-poss) (parsed-poss->poss parsed-poss))
           #|arg|#)))


(define rock-paths
  (-> all-positions
      (map (λ (poss) (poss->segments poss))
           #|arg|#)
      (map (λ (segmentss) (make-rock-path segmentss))
           #|arg|#)))


(define in-inclusive-range?
  (λ (num1 start end)
    (or (and (>= num1 start) (<= num1 end))
        (and (>= num1 end) (<= num1 start)))))


(define position-on-segment?
  (λ (position segment)
    (let ([pos-x (position-x position)]
          [pos-y (position-y position)]
          [seg-start-pos-x (position-x (segment-start segment))]
          [seg-start-pos-y (position-y (segment-start segment))]
          [seg-end-pos-x (position-x (segment-end segment))]
          [seg-end-pos-y (position-y (segment-end segment))])
      (cond
       ;; vertical segment case
       [(= pos-x seg-start-pos-x seg-end-pos-x)
        (in-inclusive-range? pos-y seg-start-pos-y seg-end-pos-y)]
       ;; horizontal segment case
       [(= pos-y seg-start-pos-y seg-end-pos-y)
        (in-inclusive-range? pos-x seg-start-pos-x seg-end-pos-x)]
       [else
        #f]))))


(define position-on-rock-path?
  (λ (position rock-path)
    (-> (rock-path-segments rock-path)
        (map (λ (segment) (position-on-segment? position segment)))
        any?)))


(define make-empty-set
  (λ ()
    (make-set
     (λ (p1 p2)
       (or (< (position-x p1) (position-x p2))
           (and (= (position-x p1) (position-x p2))
                (< (position-y p1) (position-y p2))))))))


(define move-down
  (λ (pos)
    (set-position-y pos (+ (position-y pos) 1))))


(define move-down-left
  (λ (pos)
    (set-fields pos
                ((position-y) (+ (position-y pos) 1))
                ((position-x) (- (position-x pos) 1)))))


(define move-down-right
  (λ (pos)
    (set-fields pos
                ((position-y) (+ (position-y pos) 1))
                ((position-x) (+ (position-x pos) 1)))))


(define calc-max-rock-depth
  (λ (rock-paths)
    (-> rock-paths
        (map rock-path-segments)
        flatten
        (filter (λ (seg)
                  (= (position-y (segment-start seg))
                     (position-y (segment-end seg)))))
        (map (λ (hseg)
               (max (position-y (segment-start hseg))
                    (position-y (segment-end hseg)))))
        (apply max))))


(define neighbors
  (λ (pos)
    (values (move-down pos)
            (move-down-left pos)
            (move-down-right pos))))


(define chunked-rock-paths (split-into-n-segments rock-paths 4))


(define position-blocked?
  (λ (pos rock-paths sand-blocked-positions)
    (or (set-member? sand-blocked-positions pos)
        (-> rock-paths
            (map (λ (rock-path) (position-on-rock-path? pos rock-path)))
            any?))))


(define settle-sand-unit
  (λ (sand-pouring-coords max-rock-depth rock-paths sand-blocked-positions)
    (let iter-sand-move ([sand-position° sand-pouring-coords])
      (cond
       ;; Otherwise check, if the sand unit has come to
       ;; rest or can flow further.
       [else
        (let-values ([(down down-left down-right) (neighbors sand-position°)])
          ;; If any of the 3 neighbor positions is not
          ;; blocked, move the sand unit there, but
          ;; adhere to the specified order.
          (cond
           [(= (position-y down) (+ max-rock-depth 2))
            ;; (simple-format #t "hit rock bottom, settled at: ~a\n" sand-position°)
            (set-insert sand-blocked-positions sand-position°)]
           [(not (position-blocked? down rock-paths sand-blocked-positions))
            (iter-sand-move down)]
           [(not (position-blocked? down-left rock-paths sand-blocked-positions))
            (iter-sand-move down-left)]
           [(not (position-blocked? down-right rock-paths sand-blocked-positions))
            (iter-sand-move down-right)]
           ;; The sand unit has come to rest.
           [else
            ;; (simple-format #t "settled at: ~a\n" sand-position°)
            (set-insert sand-blocked-positions sand-position°)]))]))))


(define max-rock-depth (calc-max-rock-depth rock-paths))
(simple-format #t "max-rock-depth: ~a\n" max-rock-depth)


(define fill-up-cave
  (λ (rock-paths sand-pouring-coords max-rock-depth)
    (let iter-sand-units ([sand-blocked-positions° (make-empty-set)])
      (simple-format #t "settled ~a units of sand\n" (set-size sand-blocked-positions°))
      (let ([updated-sand-blocked-positions
             (settle-sand-unit sand-pouring-coords
                               max-rock-depth
                               rock-paths
                               sand-blocked-positions°)])
        (cond
         ;; CHANGE: new condition for part 02
         [(set-member? updated-sand-blocked-positions sand-pouring-coords)
          (simple-format #t "filled up\n")
          updated-sand-blocked-positions]
         [(= (set-size updated-sand-blocked-positions)
             (set-size sand-blocked-positions°))
          (simple-format #t "no more sand unit settled\n")
          updated-sand-blocked-positions]
         [else
          (iter-sand-units updated-sand-blocked-positions)])))))


(define sand-pouring-coords (make-pos 0 500))


(define cave-filled-up-sand-blocked
  (fill-up-cave rock-paths
                sand-pouring-coords
                max-rock-depth))


(simple-format #t "result: count: ~a\n" (set-size cave-filled-up-sand-blocked))
(assert (set-member? cave-filled-up-sand-blocked sand-pouring-coords))