(defun parse-integers (string &key (start 0))
  (loop for i = start then (cadr o)
        as o = (multiple-value-list (parse-integer string :start i :junk-allowed t))
        as n = (car o)
        while n
        collect n))

(defstruct problem
  seeds
  maps)

(defun parse-map (stream)
  ;; Ignore empty lines + title-line
  (loop for line = (read-line stream nil 'eof)
        until (eq line 'eof)
        until (> (length line) 0))
  ;; Read integers for map
  (loop for line = (read-line stream nil 'eof)
        until (eq line 'eof)
        while (> (length line) 0)
        collect (parse-integers line)))

(defun parse-problem (f)
  (with-open-file (s f)
    (let* ((seeds (let ((str (read-line s)))
                    (parse-integers str :start (1+ (position #\: str)))))
           (maps (loop for map = (parse-map s)
                       while map
                       collect map)))
      (make-problem :seeds seeds
                    :maps maps))))

(defun map-match (map value)
  (let ((aux (loop for range in map
                   as l = (caddr range)
                   as s = (cadr range)
                   as d = (car range)
                   if (and (>= value s) (< value (+ s l)))
                     return (+ d (- value s)))))
    (if aux
        aux
        value)))

(defun seed-to-location (problem seed)
  (reduce (lambda (value item) (map-match item value))
          (problem-maps problem)
          :initial-value seed))

(defun solve1 (f)
  (let ((problem (parse-problem f)))
    (loop for seed in (problem-seeds problem)
          minimize (seed-to-location problem seed))))

(defun map-ranges (start length map)
  (when (> length 0)
    (if map
      (let* ((range (car map))
             (rdest (car range))
             (rstart (cadr range))
             (rlength (caddr range))
             (end (1- (+ start length)))
             (rend (1- (+ rstart rlength))))
        (cond
          ;; no overlap
          ((or (< end rstart) (< rend start))
           (map-ranges start length (cdr map)))
          ;; inner overlap
          ((and (>= start rstart) (<= end rend))
           (list (cons (+ rdest (- start rstart)) length)))
          ;; outer overlap
          ((and (>= rstart start) (<= rend end))
           (append (map-ranges start (- rstart start) (cdr map))
                   (list (cons rdest rlength))
                   (map-ranges (1+ rend) (- end rend) (cdr map))))
          ;; right overlap
          ((and (>= rstart start) (<= end rend))
           (append (map-ranges start (- rstart start) (cdr map))
                   (list (cons rdest (1+ (- end rstart))))))
          ;; left overlap
          ((and (>= start rstart) (<= rend end))
           (append (list (cons (+ rdest (- start rstart)) (1+ (- rend start))))
                   (map-ranges (1+ rend) (- end rend) (cdr map))))))
      (list (cons start length)))))

(defun seed-range-to-min-location (start length maps)
  (if maps
      (loop for range in (map-ranges start length (car maps))
            if range
              minimize (seed-range-to-min-location (car range) (cdr range) (cdr maps)))
      start))

(defun solve2 (f)
  (let ((problem (parse-problem f)))
    (loop for (start length) on (problem-seeds problem) by #'cddr
          minimize (seed-range-to-min-location start length (problem-maps problem)))))

(print (solve1 "data/05/example.txt")) ;; 35
(print (solve1 "data/05/input.txt"))   ;; 579439039
(print (solve2 "data/05/example.txt")) ;; 46
(print (solve2 "data/05/input.txt"))   ;; 7873084