aoc2023-day10.scm

(use-modules (ice-9 textual-ports) (srfi srfi-1) (srfi srfi-26) (ice-9 match)
	     (ice-9 format) (ice-9 pretty-print) (srfi srfi-8))

(define (read-input)
  (let ([line (get-line (current-input-port))])
    (if (eof-object? line)
	'()
	(cons (string->list line)
	      (read-input)))))

(define (find-starting-point map)
  (let ([width (length (first map))]
	[height (length map)])
    (call/cc
     (λ (done)
       (let next ([x 0]
		  [y 0])
	 (if (char=? #\S (list-ref (list-ref map y) x))
	     (done (cons x y))
	     (if (eqv? (1+ x) width)
		 (next 0 (1+ y))
		 (next (1+ x) y))))))))

(define (pipe-at-starting-point map start-point)
  (let* ([x (car start-point)]
	 [y (cdr start-point)]
	 [neigh-n (list-ref (list-ref map (1- y)) x)]
	 [neigh-e (list-ref (list-ref map y) (1+ x))]
	 [neigh-s (list-ref (list-ref map (1+ y)) x)]
	 [neigh-w (list-ref (list-ref map y) (1- x))])
    (match (list
	    (char-set-contains? (char-set #\| #\F #\7) neigh-n)
	    (char-set-contains? (char-set #\- #\J #\7) neigh-e)
	    (char-set-contains? (char-set #\| #\L #\J) neigh-s)
	    (char-set-contains? (char-set #\- #\L #\F) neigh-w))
      [(#t #f #t #f) #\|]
      [(#f #t #f #t) #\-]
      [(#t #t #f #f) #\L]
      [(#t #f #f #t) #\J]
      [(#f #t #t #f) #\F]
      [(#f #f #t #t) #\7])))

(define (map-with-pipe-at-starting-point map-lst start-point)
  (map (λ (line y)
	 (map (λ (char x)
		(if (and (equal? x (car start-point))
			 (equal? y (cdr start-point)))
		    (pipe-at-starting-point map-lst start-point)
		    char))
	      line (iota (length line))))
       map-lst (iota (length map-lst))))

(define (%traversal-directions point under)
  (match under
    [#\L (list (cons (car point) (1- (cdr point)))
	       (cons (1+ (car point)) (cdr point)))]
    [#\F (list (cons (car point) (1+ (cdr point)))
	       (cons (1+ (car point)) (cdr point)))]
    [#\J (list (cons (car point) (1- (cdr point)))
	       (cons (1- (car point)) (cdr point)))]
    [#\7 (list (cons (car point) (1+ (cdr point)))
	       (cons (1- (car point)) (cdr point)))]
    [#\| (list (cons (car point) (1- (cdr point)))
	       (cons (car point) (1+ (cdr point))))]
    [#\- (list (cons (1- (car point)) (cdr point))
	       (cons (1+ (car point)) (cdr point)))]))

(define (%filter-prev prev) (λ (point) (not (equal? prev point))))

(define (%traverse map prev1 point1 prev2 point2)
  (let* ([under1 (list-ref (list-ref map (cdr point1)) (car point1))]
	 [under2 (list-ref (list-ref map (cdr point2)) (car point2))]
	 [tgt1 (filter (%filter-prev prev1) (%traversal-directions point1 under1))]
	 [tgt2 (filter (%filter-prev prev2) (%traversal-directions point2 under2))])
    (cond
     ;; Start of traversal, point1 picks one direction, point2 -- the other.
     [(and (null? prev1) (null? prev2))
      (cons (list point1 point2)
	    ;; tgt1 == tgt2 here
	    (%traverse map point1 (car tgt1) point2 (cadr tgt2)))]
     ;; End of traversal, point1 == point2
     [(equal? point1 point2)
      (cons (list point1 point2)
	    '())]
     [else
      (cons (list point1 point2)
	    (%traverse map
		       point1 (car tgt1)
		       point2 (car tgt2)))])))

(define (traverse map start-point)
  (%traverse map '() start-point '() start-point))

(define (filter-points-out-of-path map-lst path)
  (map (λ (line y)
	 (map (λ (char x)
		(if (hash-ref path (cons x y))
		    char
		    #\X))
	      line (iota (length line))))
       map-lst (iota (length map-lst))))

;;      .|.
;; L -> .L-
;;      ...

;;      ...
;; F -> .F-
;;      .|.

;;      .|.
;; J -> -J.
;;      ...

;;      ...
;; 7 -> -7.
;;      .|.

;;      ...
;; - -> ---
;;      ...

;;      .|.
;; | -> .|.
;;      .|.

;;      ...
;; X -> .X.
;;      ...

(define (%enlarge-top-line line)
  (apply append
	 (map (λ (char)
		(match char
		  [#\L '(#\. #\| #\.)]
		  [#\J '(#\. #\| #\.)]
		  [#\| '(#\. #\| #\.)]
		  [#\F '(#\. #\. #\.)]
		  [#\7 '(#\. #\. #\.)]
		  [#\X '(#\. #\. #\.)]
		  [#\- '(#\. #\. #\.)]))
	      line)))

(define (%enlarge-middle-line line)
  (apply append
	 (map (λ (char)
		(match char
		  [#\L '(#\. #\L #\-)]
		  [#\J '(#\- #\J #\.)]
		  [#\| '(#\. #\| #\.)]
		  [#\F '(#\. #\F #\-)]
		  [#\7 '(#\- #\7 #\.)]
		  [#\X '(#\. #\X #\.)]
		  [#\- '(#\- #\- #\-)]))
	      line)))

(define (%enlarge-bottom-line line)
  (apply append
	 (map (λ (char)
		(match char
		  [#\L '(#\. #\. #\.)]
		  [#\J '(#\. #\. #\.)]
		  [#\| '(#\. #\| #\.)]
		  [#\F '(#\. #\| #\.)]
		  [#\7 '(#\. #\| #\.)]
		  [#\X '(#\. #\. #\.)]
		  [#\- '(#\. #\. #\.)]))
	      line)))

(define (enlarge-map map-lst)
  (apply append
	 (map (λ (line)
		(list (%enlarge-top-line line)
		      (%enlarge-middle-line line)
		      (%enlarge-bottom-line line)))
	      map-lst)))

(define (%point-to-fill map-lst point dx dy)
  (let ([width (length (first map-lst))]
	[height (length map-lst)]
	[tgt-x (+ (car point) dx)]
	[tgt-y (+ (cdr point) dy)])
    (if (or (< tgt-x 0)
	    (>= tgt-x width)
	    (< tgt-y 0)
	    (>= tgt-y height)
	    (not (char-set-contains? (char-set #\X #\.)
				     (list-ref (list-ref map-lst tgt-y) tgt-x))))
	'()
	(list (cons tgt-x tgt-y)))))

(define (%list-of-points-to-fill map-lst filled pending)
  (filter
   (λ (point)
     (not (hash-ref filled point)))
   (append
    (%point-to-fill map-lst (car pending) -1 0)
    (%point-to-fill map-lst (car pending)  1 0)
    (%point-to-fill map-lst (car pending) 0 -1)
    (%point-to-fill map-lst (car pending) 0  1)
    (cdr pending))))

(define (flood-fill map-lst)
  (let next ([pending '((0 . 0))]
	     [filled (make-hash-table)])
    (if (null? pending)
	filled
	(begin
	  (hash-set! filled (car pending) #t)
	  (next (%list-of-points-to-fill map-lst filled pending)
		filled)))))

(define (paths-to-point-hash paths)
  (let ([hash (make-hash-table (length paths))])
    (receive (left right)
	(unzip2 paths)
      (for-each (λ (point)
		  (hash-set! hash point #t))
		(append left right)))
    hash))

(define (part2 map-lst paths)
  (let* ([points-on-loop (paths-to-point-hash paths)]
	 [map-with-only-loop (filter-points-out-of-path map-lst points-on-loop)]
	 [large-map (enlarge-map map-with-only-loop)]
	 [filled (flood-fill large-map)])
    (fold + 0
	  (map (λ (line y)
		 (fold + 0
		       (map (λ (char x)
			      (if (and (not (hash-ref filled (cons x y)))
				       (char=? #\X char))
				  1
				  0))
			    line (iota (length line)))))
	       large-map (iota (length large-map))))))

(let* ([map-with-broken-loop (read-input)]
       [start (find-starting-point map-with-broken-loop)]
       [map (map-with-pipe-at-starting-point map-with-broken-loop start)]
       [paths (traverse map start)])
  (format #t "Part 1: ~a~%" (1- (length paths)))
  (format #t "Part 2: ~a~%" (part2 map paths)))

;; (define (visualize map points filled)
;;   (for-each
;;    (λ (line y)
;;      (for-each
;;       (λ (char x)
;; 	(cond
;; 	 [(hash-ref points (cons (floor (/ x 3))
;; 				 (floor (/ y 3))))
;; 	  (format #t "\x1b[32m")]
;; 	 [(hash-ref filled (cons x y))
;; 	  (format #t "\x1b[31m")]
;; 	 [else (format #t "\x1b[90m")])
;; 	(format #t "~a"
;; 		(match char
;; 		  [#\L "└"]
;; 		  [#\J "┘"]
;; 		  [#\7 "┐"]
;; 		  [#\F "┌"]
;; 		  [#\| "│"]
;; 		  [#\- "─"]
;; 		  [#\. " "]
;; 		  [#\X "X"]))
;; 	(format #t "\x1b[0m"))
;;       line
;;       (iota (length line)))
;;      (format #t "~%"))
;;    map
;;    (iota (length map))))