advent-of-code-2022/day-14/part-01.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)
 (srfi srfi-9 gnu)
 ;; let-values
 (srfi srfi-11)
 ;; purely functional data structures
 (pfds sets)
 (timing))


(define input-filename "input")


;; QLIST -- Merely adding a Q to avoid any name clashes, either actual
;; ones or in my mind.
(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)
    (parallel-map (λ (line _ind)
                    (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
      (parallel-map (λ (parsed-poss _ind) (parsed-poss->poss parsed-poss))
                    #|arg|#)))


(define rock-paths
  (-> all-positions
      ;; ((λ (thing) (pretty-peek thing #:width 20)))
      (parallel-map (λ (poss _ind) (poss->segments poss))
                    #|arg|#)
      (parallel-map (λ (segmentss _ind) (make-rock-path segmentss))
                    #|arg|#)
      ;; ((λ (thing) (pretty-peek thing #:width 40)))
      ))


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


(assert (in-inclusive-range? 75 50 100))
(assert (in-inclusive-range? 75 100 50))
(assert (not (in-inclusive-range? 3 100 50)))
(assert (not (in-inclusive-range? 103 100 50)))
(assert (not (in-inclusive-range? 3 50 100)))
(assert (not (in-inclusive-range? 103 50 100)))


(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]))))


(assert (position-on-segment?
         (make-pos 28 40)
         (make-segment (make-pos 28 35) (make-pos 28 40))))
(assert (not
         (position-on-segment?
          (make-pos 30 40)
          (make-segment (make-pos 28 35) (make-pos 28 40)))))


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


(assert
 (position-on-rock-path? (make-pos 30 40)
                         (make-rock-path
                          (list (make-segment (make-pos 28 35) (make-pos 28 40))
                                (make-segment (make-pos 28 40) (make-pos 30 40))))))
(assert
 (not
  (position-on-rock-path? (make-pos 30 40)
                          (make-rock-path
                           (list (make-segment (make-pos 28 35) (make-pos 28 40))
                                 (make-segment (make-pos 28 40) (make-pos 29 40)))))))


(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
        ;; ((λ (rock-paths) (pretty-print (take rock-paths 5)) 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)
        (any? (map (λ (rock-path)
                     (position-on-rock-path? pos rock-path))
                   rock-paths)))))


(define settle-sand-unit
  (λ (sand-pouring-coords max-rock-depth rock-paths sand-blocked-positions)
    (let iter-sand-move ([sand-position° sand-pouring-coords])
      ;; (simple-format #t "sand unit moved to ~a\n" sand-position°)
      (cond
       ;; If one unit of sand flows into the abyss, the
       ;; next one will also flow there, as it starts at
       ;; the same position and the state of the cave
       ;; has not changed.
       [(> (position-y sand-position°) max-rock-depth) sand-blocked-positions]
       ;; 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
           [(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
            (set-insert sand-blocked-positions sand-position°)]))]))))


(define count-sand-units
  (λ (rock-paths sand-pouring-coords)
    (let ([max-rock-depth (calc-max-rock-depth rock-paths)])
      (simple-format #t "max-rock-depth: ~a\n" max-rock-depth)
      ;; TODO: There is a weird case: What if the sand fills
      ;; up the cave up to the sand pouring position?
      (let iter-sand-units ([counter 0]
                            [sand-blocked-positions° (make-empty-set)])
        ;; (simple-format #t "already placed ~a units of sand\n" counter)
        (let ([updated-sand-blocked-positions
               (settle-sand-unit sand-pouring-coords
                                 max-rock-depth
                                 rock-paths
                                 sand-blocked-positions°)])
          (cond
           [(= (set-size updated-sand-blocked-positions)
               (set-size sand-blocked-positions°))
            counter]
           [else
            (iter-sand-units (+ counter 1)
                             updated-sand-blocked-positions)]))))))


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


(simple-format #t "result: ~a\n" (count-sand-units rock-paths sand-pouring-coords))