Day 17: Pyroclastic Flow

(struct shape (bricks tall wide) #:transparent)
(define WIDTH 7)
(define (parse-shapes shapes)
  (for/list ([s (in-list (map lines (groups shapes)))])
    (for*/fold ([max-row 0]
                [max-col 0]
                [S (set)]
                #:result (shape S (add1 max-row) (add1 max-col)))
               ([(l row) (in-indexed (in-list s))]
                [(c col) (in-indexed (in-string l))]
                #:when (char=? c #\#))
      (values (max max-row row)
              (max max-col col)
              (set-add S (list (- row) col))))))

(define (part-01 input)
  (tetris input 2022))

For part 2, increase the number of dropped shapes and pass #t to catch cycles. DONE!

(define (part-02 input)
  (tetris input 1000000000000 #t))

(define (tetris jets rounds [cycle #f])
  (define next-wind (wind-supply jets))
  (define next-rock (rock-supply (parse-shapes shapes)))
  (for/fold ([chamber (hash)]
             [index-top -1]
             [cache (hash)]
             #:result (add1 index-top))
            ([i (in-naturals)]
             #:break (>= i rounds))
    (define-values (rock ri) (next-rock))
    (define-values (C top wi)
      (drop-shape chamber rock (+ index-top (shape-tall rock) 3) next-wind))
    (define top+ (max index-top top))
    (cond [cycle
           (define blocks-id  (block-shape C top+))
           (define cache-id (list wi ri blocks-id))
           (define cache+ (hash-set cache cache-id (list i top+)))
           (cond [(hash-has-key? cache cache-id)
                  (match-define (list i-prev top-prev) (hash-ref cache cache-id))
                  (define cycle-height (- top+ top-prev))
                  (define cycle-size (- i i-prev))
                  (define cycles (quotient (- rounds i) cycle-size))
                  (define new-top (+ top+ (* cycle-height cycles)))
                  (set! rounds (- rounds (* cycle-size cycles)))
                  ;; no need to keep checking the cache
                  (set! cycle #f)
                  ;; update the chamber to reflect the new height
                  ;; or the next released shape is going to fall a loooooooooooong way
                  (define new-chamber
                    (for/hash ([(k v) (in-hash C)])
                      (match-define (list r c) k)
                      (values (list (+ r (* cycle-height cycles)) c) v)))
                  (values new-chamber new-top cache+)]
                 [else (values C top+ cache+)])]
          [else (values C top+ cache)])))

(define (wind-supply input)
  (define l (string-length input))
  (define i 0)
  (define cache
    (for/hash ([c (in-string input)] [i (in-naturals)])
      (values i c)))
  (λ ()
    (begin0 (values (hash-ref cache i) i)
      (set! i (if (= (sub1 l) i) 0 (add1 i))))))

(define (rock-supply shapes)
  (define l (length shapes))
  (define i 0)
  (define cache (list->vector shapes))
  (λ ()
    (begin0 (values (vector-ref cache i) i)
      (set! i (if (= (sub1 l) i) 0 (add1 i))))))

(define (drop-shape chamber rock rock-top next-wind)
  (define wide (shape-wide rock))
  (for/fold ([top rock-top]
             [left 2]
             [wi 0]
             [stopped? #f]
             #:result (values (add-rock chamber rock top left) top wi))
            ([_ (in-naturals)]
             #:break stopped?)
    (define-values (dir wi) (next-wind))
    (define left+ (wind-move chamber rock dir top left (+ left wide)))
    (if (blocked? chamber rock (sub1 top) left+)
        (values top left+ wi #t)
        (values (sub1 top) left+ wi #f))))

(define (wind-move chamber rock wdir top left right)
  (cond [(char=? wdir #\<)
         (cond [(<= left 0) left]
               [(blocked? chamber rock top (sub1 left)) left]
               [else (sub1 left)])]
        [(char=? wdir #\>)
         (cond [(>= right WIDTH) left]
               [(blocked? chamber rock top (add1 left)) left]
               [else (add1 left)])]
        [else (error 'wind-move "bad wind! ~a" wdir)]))

(define (blocked? chamber rock top left)
  (define P (list top left))
  (for/or ([brick (in-set (shape-bricks rock))])
    (define pos (point+ P brick))
    (or (negative? (first pos)) (hash-has-key? chamber pos))))

(define (add-rock chamber rock top left)
  (define rp (list top left))
  (for/fold ([chamber chamber])
            ([p (in-set (shape-bricks rock))])
    (hash-set chamber (point+ rp p) "▓")))

(define (point+ a b) (map + a b))

(define (show-chamber chamber top)
  (define free (mutable-seteq 0 1 2 3 4 5 6))
  (for ([row (in-inclusive-range top 0 -1)]
        #:break (set-empty? free))
    (printf "~a |" (~a #:max-width 10 #:width 10 #:align 'right row))
    (for ([col (in-range WIDTH)])
      (cond [(hash-has-key? chamber (list row col))
             (set-remove! free col)
             (printf "▓")]
            [else (printf " ")]))
    (printf "|\n"))
  (printf "           +-------+\n")
  (printf "=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-\n" ))

;; To find a cycle:
;;
;; A cycle will have the same blocks for the same current shape and wind index.
;;
;; e.g width 3 wind index 31 and rock 2
;; ▓ ▓
;;   ▓
;; ▓ ▓
;; ▓▓
;;
;; No brick can fall past blockages so this is the pattern to find. Ignore anything below. 
;; Convert it to a string to store in a cache.
(define (block-shape chamber top)
  (define lowest (probe-blocked chamber top))
  (for/fold ([id ""])
            ([row (in-inclusive-range top lowest -1)])
    (for/fold ([line ""]
               #:result (string-append id line))
              ([col (in-range WIDTH)])
      (string-append
       line
       (if (hash-has-key? chamber (list row col))
           "1" "0")))))

(define (probe-blocked chamber top)
  (define free (mutable-seteq 0 1 2 3 4 5 6))
  (define (min-blocked lowest)
    (cond [(= lowest 0) lowest]
          [(set-empty? free) lowest]
          [else (for ([col (in-range WIDTH)]
                      #:when (hash-has-key? chamber (list lowest col)))
                  (set-remove! free col))
                (min-blocked (sub1 lowest))]))
  (min-blocked top))