aoc2023-day5.scm

(use-modules (srfi srfi-1) (ice-9 textual-ports) (ice-9 peg)
	     (ice-9 format) (ice-9 match))

(define-peg-string-patterns
  "seeds <-- SEEDS (number SPC?)+ NL NL
type-map <-- type TO type MAP NL range+ NL?
range <-- number SPC number SPC number NL
type <-- [a-z]+
number <-- [0-9]+
TO < '-to-'
MAP < ' map:'
SEEDS < 'seeds: '
SPC < ' '
NL < '\n'")

(define-peg-pattern top all (peg "seeds type-map+ !."))

(define (process-range tree)
  (map (compose string->number cadr) (cdr tree)))

(define (process-map tree)
  (cons (cadadr tree)
	(cons (car (cdaddr tree))
	      (map process-range (cadddr tree)))))

(define (process-tree tree)
  (cons (map (compose string->number cadr) (cdadr tree))
	(map process-map (caddr tree))))

(define (intersection? a-start a-end b-start b-end)
  (< (max a-start b-start) (min a-end b-end)))

(define (fully-contained? a-start a-end b-start b-end)
  (and (>= a-start b-start)
       (<= a-end b-end)))

(define (%translate-range in-start in-size
			  trans-source trans-size trans-dest)
  (let ([in-end (+ in-start in-size)]
	[trans-end (+ trans-source trans-size)]
	[trans-delta (- trans-dest trans-source)])
    (cond
     ;; Input does not intersect translation source
     [(not (intersection? in-start in-end trans-source trans-end))
      (cons (list (cons in-start in-size)) '())]
     ;; Input fully contained in translation source
     [(fully-contained? in-start in-end trans-source trans-end)
      (cons '() (cons (+ trans-delta in-start) in-size))]
     ;; Partial intersection in the middle
     ;; |-----------------|
     ;; A     |--------|  B
     ;;       C        D
     ;; A = in-start, B = in-start + in-size
     ;; C = trans-source, D = trans-source + trans-size
     [(and (fully-contained? trans-source trans-end in-start in-end)
	   (not (equal? trans-source in-start)))
      (cons (list (cons in-start (- trans-source in-start))
		  (cons trans-end
			(- in-end trans-end)))
	    (cons (+ trans-delta trans-source) trans-size))]
     ;; Partial intersection on the left
     ;;    A      B
     ;;    |------|
     ;; |----|
     ;; C    D
     ;; A = in-start, B = in-start + in-size
     ;; C = trans-source, D = trans-source + trans-size
     [(<= trans-source in-start)
      (cons (list (cons trans-end
			(- in-end trans-end)))
	    (cons (+ trans-delta in-start)
		  (- trans-end in-start)))]
     ;; Partial intersection on the right
     ;;    A      B
     ;;    |------|
     ;;         |----|
     ;;         C    D
     ;; A = in-start, B = in-start + in-size
     ;; C = trans-source, D = trans-source + trans-size
     [(< trans-source in-end)
      (cons (list (cons in-start (- trans-source in-start)))
	    (cons (+ trans-delta trans-source)
		  (- in-end trans-source)))]
     [else (error "What???" in-start in-size trans-source trans-size trans-dest)])))


(define (%translate-ranges in-ranges trans-range)
  (fold (λ (this prev)
	  (cons (append (car prev) (car this))
		(if (null? (cdr this))
		    (cdr prev)
		    (append (cdr prev) (list (cdr this))))))
	'(() . ())
	(map (λ (in-range)
	       (%translate-range (car in-range) (cdr in-range)
				 (second trans-range)
				 (third trans-range)
				 (first trans-range)))
	     in-ranges)))

(define (%translate-ranges-once in-ranges trans-ranges)
  (let next ([in-ranges in-ranges]
	     [out-ranges '()]
	     [remaining-trans (cdr trans-ranges)])
    (if (null? remaining-trans)
	(append in-ranges out-ranges)
	(match-let ([(untrans . trans)
		     (%translate-ranges in-ranges (car remaining-trans))])
	  (next untrans (append out-ranges trans) (cdr remaining-trans))))))

(define (translate-ranges-once in-cons type-maps)
  (let ([type-map (assoc (car in-cons) type-maps)])
    (cons (cadr type-map)
	  (%translate-ranges-once (cdr in-cons)
				  (cdr type-map)))))

(define (translate-ranges-until in-cons target-type type-maps)
  (if (equal? (car in-cons) target-type)
      in-cons
      (translate-ranges-until (translate-ranges-once in-cons type-maps)
			      target-type type-maps)))

(define (part-common input make-ranges)
  (apply min
	 (map car
	      (cdr (translate-ranges-until
		    (cons "seed" (make-ranges (car input)))
		    "location" (cdr input))))))

(define (part1-ranges seeds)
  (map (λ (seedv)
	 (cons seedv 1))
       seeds))

(define (part2-ranges seeds)
  (if (null? seeds)
      '()
      (cons (cons (car seeds) (cadr seeds))
	    (part2-ranges (cddr seeds)))))

(let* ([input (get-string-all (current-input-port))]
       [peg-tree (peg:tree (match-pattern top input))]
       [tree (process-tree peg-tree)])
  (format #t "Part 1: ~a~%" (part-common tree part1-ranges))
  (format #t "Part 2: ~a~%" (part-common tree part2-ranges)))