Advent of Code 2023

(load "~/quicklisp/setup.lisp")
(ql:quickload :split-sequence)

(defmacro ssq (char sequence)
  `(split-sequence:split-sequence ,char ,sequence))

(defvar *qualify* '((red . 12)
                  (green . 13)
                  (blue . 14)))

(defun fetch-at-least (color visions)
  (cons color
      (apply #'max
             (mapcar #'cdr
                     (remove-if-not #'(lambda (vision)
                                        (eq (car vision) color))
                                    visions)))))

(defun parse-pulls (pulls)
  (let* ((visions (mapcar #'(lambda (vision)
                            (let* ((clean (string-trim " " vision))
                                   (val (read-from-string clean))
                                   (color (read-from-string (cadr (ssq #\Space clean)))))
                              (cons color val)))
                        (ssq #\, pulls))))
    (mapcar #'(lambda (color)
              (fetch-at-least color visions))
          '(red green blue))))

(defun valid-game-p (at-leasts)
  (reduce #'(lambda (a b)
            (and a b))
        (mapcar #'(lambda (color-at-least)
                    (>= (cdr (assoc (car color-at-least) *qualify*))
                        (cdr color-at-least)))
                at-leasts)
        :initial-value t))

(defun parse-line-part-1 (line)
  (let* ((base-split (ssq #\: line))
       (id (parse-integer (cadr (ssq #\Space (car base-split)))))
       (at-leasts (parse-pulls (substitute #\, #\; (cadr base-split))))
       (valid (valid-game-p at-leasts)))
    (if (valid-game-p at-leasts) id 0)))

(defun parse-line-part-2 (line)
  (let* ((base-split (ssq #\: line))
       (id (parse-integer (cadr (ssq #\Space (car base-split)))))
       (at-leasts (parse-pulls (substitute #\, #\; (cadr base-split)))))
    (apply #'* (mapcar #'cdr at-leasts))))

(defun solve-1 (filename)
  (with-open-file (stream filename)
    (do ((acc 0 (+ acc (parse-line-part-1 (read-line stream)))))
      ((not (listen stream)) acc))))

(defun solve-2 (filename)
  (with-open-file (stream filename)
    (do ((acc 0 (+ acc (parse-line-part-2 (read-line stream) ))))
      ((not (listen stream)) acc))))

;;load board into array ;;have virtual padding
;; :- function that returns a dot when out of bounds
;;for each symbol check surroundings (8 of them)
;;mark indices for processing where a number occurs
;;when processing an index, mark all the indices where the number extends
;;report accumulation

(defun load-board (file-name)
  (with-open-file (stream file-name)
    (do ((board '() (cons (coerce (read-line stream) 'list)
                          board)))
        ((not (listen stream)) (reverse board)))))

(defvar *repr* (load-board "./board.txt"))
(defvar *rows* (length *repr*))
(defvar *cols* (length (car *repr*)))

(defun paref (i j array &key (sentinel #\.))
  "sentinel padded bget"
  (let ((rows (array-dimension array 0))
        (cols (array-dimension array 1)))
   (labels ((out-index (index bound) (or (< index 0)
                                        (>= index bound)))
           (orow (row-num) (out-index row-num rows))
           (ocol (col-num) (out-index col-num cols)))
     (if (or (orow i)
             (ocol j))
         sentinel
         (aref array i j)))))

(defun symbol-p (char)
  (and (not (digit-char-p char) )
       (not (char= char #\.) )))

(defvar *board* (make-array `(,*rows*
                              *cols*)
                            :initial-contents *repr*))

(defun proc-setf (i j array val)
  (let ((rows (array-dimension array 0))
        (cols (array-dimension array 1)))
    (labels ((out-index (index bound) (or (< index 0)
                                          (>= index bound)))
             (orow (row-num) (out-index row-num rows))
             (ocol (col-num) (out-index col-num cols))
             (validator (i j) (digit-char-p (paref i j *board*))))
      (when (and (not (or (orow i)
                          (ocol j)))
                 (validator i j))
        (setf (aref array i j) val)))))

(defun mark-check-local (i j check-mask)
  (let ((marks `((,(- i 1)  ,(- j 1))
                 (,(- i 1)  ,j)
                 (,(- i 1)  ,(+ j 1))
                 (,i  ,(- j 1))
                 (,i  ,(+ j 1))
                 (,(+ i 1)  ,(- j 1))
                 (,(+ i 1)  ,j)
                 (,(+ i 1)  ,(+ j 1)))))
    (mapcar #'(lambda (mark)
                (proc-setf (car mark)
                           (cadr mark)
                           check-mask
                           T))
            marks)))

(defun make-check-mask (board)
  (let* ((rlen (array-dimension board 0))
         (clen (array-dimension board 1))
         (base-mask (make-array `(,rlen
                                  ,clen)
                                :initial-element nil)))
    (do ((i 0 (+ 1 i)))
        ((= i rlen) base-mask)
      (do ((j 0 (+ 1 j)))
          ((= j clen))
        (when (symbol-p (paref i j board))
          (mark-check-local i j base-mask))))))

(defvar *check-mask* (make-check-mask *board*))

(defun get-row (board row)
  (loop for i from 0 to (- (array-dimension board 1) 1)
        collect (aref board row i)))

(defun process-row (row)
  (let ((brow (get-row *board* row))
        (crow (get-row *check-mask* row)))
    (do ((i 0)
         (acc 0))
        ((>= i *cols*) acc)
      (if (nth i crow)
          (let ((lefts (do ((l (- i 1) (- l 1))
                            (left '() (cons (nth l brow) left)))
                           ((or (< l 0) (not (digit-char-p (nth l brow))))
                            left)))
                (rights (do ((r (+ i 1) (+ r 1))
                             (right '() (cons (nth r brow) right)))
                            ((or (= r *cols*) (not (digit-char-p (nth r brow))))
                             (reverse right)))))
            (incf acc (parse-integer (coerce (append lefts
                                                     (list (nth i brow))
                                                     rights)
                                             'string)))
            (incf i (+ (length rights) 1)))
          (incf i 1)))))

(defun process-board ()
  (apply #'+ (loop for row from 0 to (- *rows* 1)
                   collect (process-row row))))

(process-board)

;;each number needs to identified by an id
;;populate an id mask that stores number locations
;;when checking surrounding ids of a gear,
;;  report multiplication if exactly 2 unique detected

(defvar *val-hash* (make-hash-table))

(defmacro gethashf (k)
  "fetch hash"
  `(gethash ,k *val-hash*))

(defmacro sethashf (k v)
  "set hash form"
  `(setf (gethashf ,k) ,v))

(defvar *id-loc* (make-array `(,*rows*
                               *cols*)
                             :initial-element 0))

(defun update-id-locs (id indices)
  (dolist (index indices)
    (setf (aref *id-loc* (car index) (cdr index)) id)))

(defparameter *id-ctr* 0)

(defun mark-numbers (row)
  (let ((brow (get-row *board* row))
        (crow (get-row *check-mask* row)))
    (do ((i 0))
        ((>= i *cols*) *id-loc*)
      (if (nth i crow)
          (let* ((lefts (do ((l (- i 1) (- l 1))
                             (left '() (cons (nth l brow) left)))
                            ((or (< l 0) (not (digit-char-p (nth l brow))))
                             left)))
                 (rights (do ((r (+ i 1) (+ r 1))
                              (right '() (cons (nth r brow) right)))
                             ((or (= r *cols*) (not (digit-char-p (nth r brow))))
                              (reverse right))))
                 (val (parse-integer (coerce (append lefts
                                                     (list (nth i brow))
                                                     rights)
                                             'string)))
                 (mark-indices (mapcar #'(lambda (col)
                                           (cons row col))
                                       (loop for index
                                             from (- i (length lefts))
                                               to (+ i (length rights))
                                             collect index))))
            (incf *id-ctr*)
            (sethashf *id-ctr* val)
            (update-id-locs *id-ctr* mark-indices)
            (incf i (+ (length rights) 1)))
          (incf i 1)))))

(defun mark-board-ids ()
  (loop for r from 0 to (- *rows* 1)
        do (mark-numbers r)))

(mark-board-ids)

(defun compute-gear-ratios ()
  (labels ((fetch-marks (i j)
             `((,(- i 1) . ,(- j 1))
               (,(- i 1) . ,j)
               (,(- i 1) . ,(+ j 1))
               (,i . ,(- j 1))
               (,i . ,(+ j 1))
               (,(+ i 1) . ,(- j 1))
               (,(+ i 1) . ,j)
               (,(+ i 1) . ,(+ j 1)))))
    (apply #'+
           (loop for i
                 from 0 to
                        (- *rows* 1)
                 append (loop for j
                              from 0 to
                                     (- *cols* 1)
                              collect
                              (if (char= (aref *board* i j)
                                         #\*)
                                  (let ((ids (remove-if #'zerop (remove-duplicates
                                                                 (mapcar #'(lambda (mark)
                                                                             (paref (car mark)
                                                                                    (cdr mark)
                                                                                    *id-loc*
                                                                                    :sentinel 0))
                                                                         (fetch-marks i j))))))
                                    (if (= (length ids) 2)
                                        (apply #'* (mapcar #'(lambda (id)
                                                               (gethashf id))
                                                           ids))
                                        0))
                                  0))))))

(compute-gear-ratios)

(load "~/quicklisp/setup.lisp")
(ql:quickload :cl-ppcre)

(defmacro ssq (str sequence)
  `(cl-ppcre:split ,str ,sequence))

(defun read-and-parse-file (file-name)
  (with-open-file (stream file-name)
    (ssq (coerce '(#\Return #\Return) 'string)
         (apply #'concatenate 'string
                (loop for line = (read-line stream nil)
                      while line
                      collect line)))))

(defvar *from-chain* '(seed soil fertilizer water light temperature humidity))

(defparameter *lambda-hash* (make-hash-table))

(defun smap (map-line)
  (let* ((spec (ssq " " map-line))
         (sst (read-from-string (second spec)))
         (dst (read-from-string (first spec)))
         (rl (read-from-string (third spec))))
    #'(lambda (smap-request)
        (if (<= sst smap-request (+ sst rl -1))
            (+ dst (- smap-request sst))
            nil))))

(defun compile-smaps (smap-list)
  (let ((smappers smap-list))
    #'(lambda (map-request)
        (dolist (smapper smappers map-request)
          (let ((smapped (funcall smapper map-request)))
            (if smapped
                (return smapped)))))))

(defun build-map (from to mapper)
  (labels ((fetch-from () from)
           (fetch-to () to)
           (call (input) (funcall mapper input)))
    #'(lambda (message &optional input)
        (cond ((eq message 'from) (fetch-from))
              ((eq message 'to) (fetch-to))
              ((eq message 'call) (call input))
              (t (error "invalid message received"))))))

(defun parse-map-spec (map-spec)
  (let* ((title (car (ssq " " map-spec)))
         (a (read-from-string (car (ssq "-to-" title))))
         (b (read-from-string (cadr (ssq "-to-" title))))
         (smaps (mapcar #'smap (cdr (ssq #\Return map-spec)))))
    (build-map a b (compile-smaps smaps))))

(defun range (start len)
  (loop for i from start below (+ start len) 
        collect i))

(defun parse-seed-spec (seed-spec)
  (do* ((key-head seed-spec (cdr value-head))
        (value-head (cdr key-head) (cdr key-head))
        (seeds '() ))
       ((null key-head) seeds)
    (setf seeds (append (range (car key-head) (car value-head))
                        seeds) )))

(defun parse-spec-brute (file-name)
  (let* ((info (read-and-parse-file file-name))
         (seeds (parse-seed-spec
                 (mapcar #'read-from-string
                         (ssq " " (cadr (ssq ": " (car info)))))))
         (maps (mapcar #'parse-map-spec (cdr info))))
    (dolist (map maps)
      (setf (gethash (funcall map 'from) *lambda-hash*) map))
    seeds))

(defun soil-to-loc (soil-number)
  (let ((mappers (mapcar #'(lambda (from-sym)
                             (gethash from-sym *lambda-hash*))
                         *from-chain*))
        (passed soil-number))
    (loop for func in mappers
          do (setf passed (funcall func 'call passed)))
    passed))

(defun solve-brute (file-name)
  (clrhash *lambda-hash*)
  (apply #'min (mapcar #'soil-to-loc
                       (parse-spec-brute file-name))))

;; Optimization 1
;; report min soil number for a range
;; final report min of mins
;; do not build seed-range list on the get go

(defun parse-seed-spec-opt-1 (seed-spec)
  (do* ((key-head seed-spec (cdr value-head))
        (value-head (cdr key-head) (cdr key-head))
        (seeds '()))
       ((null key-head) (reverse seeds))
    (setf seeds (cons  (cons (car key-head)
                             (car value-head))
                       seeds))))

(defun parse-spec-opt-1 (file-name)
  (let* ((info (read-and-parse-file file-name))
         (seed-ranges (parse-seed-spec-opt-1
                       (mapcar #'read-from-string
                               (ssq " " (cadr (ssq ": " (car info)))))))
         (maps (mapcar #'parse-map-spec (cdr info))))
    (dolist (map maps)
      (setf (gethash (funcall map 'from) *lambda-hash*) map))
    seed-ranges))

(defun min-range-soil-to-loc (range-info)
  (let* ((start (car range-info))
         (len (cdr range-info))
         (local-min (apply #'min (mapcar #'soil-to-loc (range start len)))))
    (format t "~%local-min for ~S : ~S" range-info local-min)
    (force-output)
    local-min))

(defun solve-opt-1 (file-name)
  (clrhash *lambda-hash*)
  (let ((seed-ranges (parse-spec-opt-1 file-name)))
    (format t "~%final min: ~S"
            (apply #'min (mapcar #'min-range-soil-to-loc
                         seed-ranges)))))