day-03-alt.lisp

day-03-alt.lisp

(defpackage :advent.2019.03-alt (:use :cl :alexandria :cl-ppcre))
(in-package :advent.2019.03-alt)

(defstruct seg lo hi o d z)
(defstruct (hseg (:constructor hseg (lo hi o d z)) (:include seg)))
(defstruct (vseg (:constructor vseg (lo hi o d z)) (:include seg)))

(defun seg (type from to z)
  (funcall type
	   (min from to)
	   (max from to)
	   from
	   to
	   z))

(defmacro x (o) `(realpart ,o))
(defmacro y (o) `(imagpart ,o))
(defmacro pt (x y) `(complex ,x ,y))

(defgeneric from (segment)
  (:method ((s hseg)) (pt (seg-o s) (seg-z s)))
  (:method ((s vseg)) (pt (seg-z s) (seg-o s))))

(defgeneric to (segment)
  (:method ((s hseg)) (pt (seg-d s) (seg-z s)))
  (:method ((s vseg)) (pt (seg-z s) (seg-d s))))

(defun segment (origin direction length)
  (with-accessors ((ox realpart) (oy imagpart)) origin
    (flet ((make (type sign &aux (d (* sign length)))
	     (ecase type
	       (hseg (seg 'hseg ox (+ ox d) oy))
	       (vseg (seg 'vseg oy (+ oy d) ox)))))
      (ecase direction
	(#\U (make 'vseg -1))
	(#\D (make 'vseg +1))
	(#\L (make 'hseg -1))
	(#\R (make 'hseg +1))))))

(defun manhattan (p1 p2)
  (+ (abs (- (x p2) (x p1)))
     (abs (- (y p2) (y p1)))))

(defun parse-wires (file)
  (flet ((parse-segment (origin string)
	   (segment origin 
		    (char string 0)
		    (parse-integer string :start 1))))
    (with-open-file (in file)
      (loop
	 for line = (read-line in nil nil)
	 while line
	 collect (let ((origin ))
		   (flet ((parse (s)
			    (let ((segment (parse-segment origin s)))
			      (prog1 segment
				(setf origin (to segment))))))
		     (mapcar #'parse (split #\, line :sharedp t))))))))

(defvar *input* (parse-wires "~/tmp/advent/03.in"))

(defun intersect/orthogonal (h v)
  (let ((ix (seg-z v))
	(iy (seg-z h)))
    (and (<= (seg-lo h) ix (seg-hi h))
	 (<= (seg-lo v) iy (seg-hi v))
	 (pt ix iy))))

(defun intersect/parallel (type s1 s2)
  (and (= (seg-z s1) (seg-z s2))
       (let ((lo (max (seg-lo s1) (seg-hi s2)))
	     (hi (min (seg-hi s1) (seg-hi s2))))
	 (cond
	   ((= lo hi) 
	    (case type
	      (hseg (pt lo (seg-z s1)))
	      (vseg (pt (seg-z s1) lo))))
	   ((< lo hi)
	    (seg type lo hi (seg-z s1)))))))

(defgeneric intersect (s1 s2)
  (:method ((h hseg) (v vseg)) (intersect/orthogonal h v))
  (:method ((v vseg) (h hseg)) (intersect/orthogonal h v))
  (:method ((s1 hseg) (s2 hseg)) (intersect/parallel 'hseg s1 s2))
  (:method ((s1 vseg) (s2 vseg)) (intersect/parallel 'vseg s1 s2)))

;; day 3 - part 1

(defvar *intersections*
  (delete nil (map-product #'intersect 
			   (elt *input* 0)
			   (elt *input* 1))))

(loop
   for p in *intersections*
   unless (zerop p)
     minimize (manhattan 0 p))

;; day 3 - part 2

(defun segment-steps (s)
  (- (seg-hi s) (seg-lo s)))

(defun count-steps (segments)
  (loop
     with hash = (make-hash-table :test #'equalp)
     and count = 0
     for s in segments
     do
       ;; store steps to beginning of segment
       (setf (gethash s hash) count)
       (incf count (segment-steps s))
     finally (return hash)))

(defvar *steps* (map 'list #'count-steps *input*))

(flet ((cut% (tt s p z) (seg tt (seg-o s) p z)))
  (declare (inline cut%))
  (defgeneric cut (seg point)
    (:method ((s hseg) (p complex)) (cut% 'hseg s (x p) (y p)))
    (:method ((s vseg) (p complex)) (cut% 'vseg s (y p) (x p)))))

(loop 
   with wire-1-steps = (first *steps*)
   with wire-2-steps = (second *steps*)
   for v in (delete nil
		    (map-product (lambda (s1 s2)
				   (if-let (i (intersect s1 s2))
				     (unless (eql 0 i)
				       (+ (gethash s1 wire-1-steps)
					  (segment-steps (cut s1 i))
					  (gethash s2 wire-2-steps)
					  (segment-steps (cut s2 i))))))
				 (elt *input* 0)
				 (elt *input* 1)))
   unless (zerop v)
     minimize v)

Modified version with a better data structure for segments that reduces corner cases on intersection tests