aoc2024-day15.scm

(use-modules (srfi srfi-1) (ice-9 textual-ports) (ice-9 peg)
	     (ice-9 match) (ice-9 pretty-print) (srfi srfi-26)
	     (ice-9 string-fun))

(define-peg-string-patterns
  "top <-- grid insns !.*
grid <-- (nnl+ CNL)+ NL
insns <-- (nnl* NL)+
nnl <- !NL .
CNL <- '\n'
NL < '\n'
")

(define (parse-grid-p1 grid)
  (list->array 2
	       (map string->list
		    (string-split (string-drop-right (second grid) 1)
				  #\newline))))


(define (p2-transform str)
  ((compose (cut string-replace-substring <> "#" "##")
	    (cut string-replace-substring <> "@" "@.")
	    (cut string-replace-substring <> "." "..")
	    (cut string-replace-substring <> "O" "[]"))
   str))

(define (parse-grid-p2 grid)
  (list->array 2
	       (map (compose string->list p2-transform)
		    (string-split (string-drop-right (second grid) 1)
				  #\newline))))

(define (parse-insns insns)
  (string->list (second insns)))

(define (parse-top tree)
  (list (parse-grid-p1 (second tree))
	(parse-grid-p2 (second tree))
	(parse-insns (third tree))))


(define (vec2+ a b)
  (cons (+ (car a) (car b))
	(+ (cdr a) (cdr b))))


(define (find-robot grid)
  (let ([unrolled (array-contents grid)]
	[width (cadr (array-dimensions grid))])
    (let next ([i 0])
      (if (array-in-bounds? unrolled i)
	  (if (eqv? (array-ref unrolled i) #\@)
	      (cons (quotient  i width)
		    (remainder i width))
	      (next (1+ i)))
	  (error "Robot not in grid")))))


(define (wide? chr)
  (match chr
    [#\[ #t]
    [#\] #t]
    [_ #f]))

(define (vertical? move)
  (not (eqv? (car move) 0)))

(define (neighbor-offset grid pos)
  (match (array-ref grid (car pos) (cdr pos))
      [#\[ '(0 .  1)]
      [#\] '(0 . -1)]
      [x (error "Tile without distinct neighbor" x)]))


(define (check-move grid from move)
  (let ([target (vec2+ from move)])
    (match (array-ref grid (car target) (cdr target))
      [#\. #t]
      [#\# #f]
      [#\O (check-move grid target move)]
      [_ (and (check-move grid target move)
	      (or (not (vertical? move))
		  (check-move grid (vec2+ target (neighbor-offset grid target)) move)))])))


(define (move-tile grid from to)
  (array-set! grid (array-ref grid (car from) (cdr from))
	      (car to) (cdr to))
  (array-set! grid #\. (car from) (cdr from))
  #t)

(define (do-move grid from move)
  (let ([target (vec2+ from move)])
    (match (list move (array-ref grid (car from) (cdr from)))
      [(_ #\.) #t]
      [(_ #\#) (error "Wall in do-move")]
      [((? vertical?) (? wide?))
	 (let ([off (neighbor-offset grid from)])
	   (do-move grid target move)
	   (do-move grid (vec2+ target off) move)

	   (move-tile grid (vec2+ from off) (vec2+ target off))
	   (move-tile grid from target))]
      [(_ _)
       (begin
	 (do-move grid target move)
	 (move-tile grid from target))])))


(define (try-move grid from move)
  (if (check-move grid from move)
      (do-move grid from move)
      #f))


(define (insn->vec2 insn)
  (match insn
    [#\^ '(-1 .  0)]
    [#\> '( 0 .  1)]
    [#\v '( 1 .  0)]
    [#\< '( 0 . -1)]
    [_ (error "Illegal insn" insn)]))

(define (simulate-move grid insn robot)
  (let ([move (insn->vec2 insn)])
    (if (try-move grid robot move)
	(vec2+ robot move)
	robot)))


(define (sum-of-gps grid want)
  (let ([unrolled (array-contents grid)]
	[width (cadr (array-dimensions grid))])
    (let next ([i 0]
	       [acc 0])
      (if (array-in-bounds? unrolled i)
	  (next (1+ i)
		(+ acc
		   (if (eqv? (array-ref unrolled i) want)
		       (+ (* 100 (quotient i width))
			  (remainder i width))
		       0)))
	  acc))))


(match-let* ([input (get-string-all (current-input-port))]
	     [peg-tree (peg:tree (match-pattern top input))]
	     [(grid-p1 grid-p2 insns) (parse-top peg-tree)]
	     [robot (find-robot grid-p1)])
  (fold
   (cut simulate-move grid-p1 <...>)
   robot insns)
  (pretty-print (sum-of-gps grid-p1 #\O))

  (fold
   (cut simulate-move grid-p2 <...>)
   (cons (car robot) (* 2 (cdr robot))) insns)
  (pretty-print (sum-of-gps grid-p2 #\[)))