--- a/advent.asd Sat Dec 02 12:49:22 2017 -0500
+++ b/advent.asd Sun Dec 03 18:39:45 2017 -0500
@@ -13,4 +13,5 @@
(:file "quickutils")))
(:file "package")
(:module "src" :serial t
- :components ((:file "main")))))
+ :components ((:file "number-spiral")
+ (:file "main")))))
--- a/package.lisp Sat Dec 02 12:49:22 2017 -0500
+++ b/package.lisp Sun Dec 03 18:39:45 2017 -0500
@@ -1,2 +1,6 @@
(defpackage :advent
(:use :cl :losh :iterate :advent.quickutils))
+
+(defpackage :advent.spiral
+ (:use :cl :losh :iterate :advent.quickutils)
+ (:export :number-coordinates))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/scratch.lisp Sun Dec 03 18:39:45 2017 -0500
@@ -0,0 +1,113 @@
+ ;;;; Spirals -------------------------------------------------------------------
+ (defun layer-side-length (layer)
+ "Return the length of one side of `layer`."
+ (1+ (* 2 layer)))
+
+ (defun layer-size (layer)
+ "Return the total size of a number spiral with a final layer of `layer`."
+ (square (layer-side-length layer)))
+
+ (defun layer-for-number (number)
+ "Return the index of the layer containing `number`."
+ (ceiling (/ (1- (sqrt number)) 2)))
+
+ (defun layer-start (layer)
+ "Return the smallest number in `layer`."
+ (if (zerop layer)
+ 1
+ (1+ (layer-size (1- layer)))))
+
+ (defun layer-leg-length (layer)
+ "Return the length of one \"leg\" of `layer`."
+ (1- (layer-side-length layer)))
+
+
+ (defun leg (layer number)
+ "Return the leg index and offset of `number` in `layer`."
+ (if (= 1 number)
+ (values 0 0)
+ (let ((idx (- number (layer-start layer)))
+ (legsize (layer-leg-length layer)))
+ (values (floor idx legsize)
+ (1+ (mod idx legsize))))))
+
+ (defun corner-coordinates (layer leg)
+ "Return the coordinates of the corner starting `leg` in `layer`.
+
+ Leg | Corner
+ 0 | Bottom Right
+ 1 | Top Right
+ 2 | Top Left
+ 3 | Bottom Left
+
+ "
+
+ ;; 2 1
+ ;;
+ ;; 3 0
+ (ccase leg
+ (0 (complex layer (- layer)))
+ (1 (complex layer layer))
+ (2 (complex (- layer) layer))
+ (3 (complex (- layer) (- layer)))))
+
+ (defun leg-direction (leg)
+ "Return the direction vector for the given `leg`.
+ "
+ ;; <--
+ ;; 11110
+ ;; | 2 0 ^
+ ;; | 2 0 |
+ ;; v 2 0 |
+ ;; 23333
+ ;; -->
+ (ccase leg
+ (0 (complex 0 1))
+ (1 (complex -1 0))
+ (2 (complex 0 -1))
+ (3 (complex 1 0))))
+
+
+ (defun number-coordinates (number)
+ (nest
+ ;; Find the layer the number falls in.
+ (let ((layer (layer-for-number number))))
+
+ ;; Find which leg of that layer it's in, and how far along the leg it is.
+ (multiple-value-bind (leg offset) (leg layer number))
+
+ ;; Find the coordinates of the leg's corner, and its direction vector.
+ (let ((corner (corner-coordinates layer leg))
+ (direction (leg-direction leg))))
+
+ ;; Start at the corner and add the offset in the leg's direction to find the
+ ;; number's coordinates.
+ (+ corner (* direction offset))))
+
+
+ ;;;; Main ---------------------------------------------------------------------
+ (defun day-3-part-1 ()
+ (labels ((manhattan-distance (a b)
+ (+ (abs (- (realpart a)
+ (realpart b)))
+ (abs (- (imagpart a)
+ (imagpart b)))))
+ (distance-to-origin (p)
+ (manhattan-distance #c(0 0) p)))
+ (distance-to-origin (number-coordinates 325489))))
+
+ (defun day-3-part-2 ()
+ (flet ((neighbors (coord)
+ (iterate (for-nested ((dx :from -1 :to 1)
+ (dy :from -1 :to 1)))
+ (unless (= 0 dx dy)
+ (collect (+ coord (complex dx dy)))))))
+ (iterate
+ (with memory = (make-hash-table))
+ (initially (setf (gethash #c(0 0) memory) 1))
+ (for n :from 2)
+ (for coord = (number-coordinates n))
+ (for value = (summation (neighbors coord) :key (rcurry #'gethash memory 0)))
+ (finding value :such-that (> value 325489))
+ (setf (gethash coord memory) value))))
+
--- a/src/2015.lisp Sat Dec 02 12:49:22 2017 -0500
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,898 +0,0 @@
-; https://bitbucket.org/sjl/beef
-(ql:quickload "beef")
-(ql:quickload "alexandria")
-(ql:quickload "split-sequence")
-(ql:quickload "cl-arrows")
-(ql:quickload "fset")
-(ql:quickload "cl-ppcre")
-(ql:quickload "ironclad")
-(ql:quickload "smug")
-(ql:quickload "bit-smasher")
-(ql:quickload "optima")
-
-(defpackage #:advent
- (:use #:cl)
- (:use #:cl-arrows)
- (:use #:split-sequence)
- (:use #:smug))
-
-(in-package #:advent)
-
-(declaim (optimize (debug 3)))
-
-;;;; Day 1
-(defun instruction-to-num (ch)
- (cond
- ((eql ch #\() 1)
- ((eql ch #\)) -1)
- (t 0)))
-
-(defun advent-1-1 ()
- (loop :for c :across (beef:slurp "data/1")
- :sum (instruction-to-num c)))
-
-(defun advent-1-2 ()
- (loop :for c :across (beef:slurp "data/1")
- :sum (instruction-to-num c) :into floor
- :sum 1
- :until (= floor -1)))
-
-
-;;;; Day 2
-(defun advent-2-data ()
- (->> (beef:slurp "data/2")
- beef:trim-whitespace-right
- beef:split-lines
- (mapcar (lambda (s)
- (->> s
- (split-sequence #\x)
- (mapcar #'parse-integer))))))
-
-(defun advent-2-1 ()
- (loop :for dims :in (advent-2-data)
- :for (w h l) = dims
- :for sides = (list (* w h)
- (* w l)
- (* h l))
- :for paper = (* 2 (apply #'+ sides))
- :for slack = (apply #'min sides)
- :sum (+ paper slack)))
-
-(defun advent-2-2 ()
- (loop :for dims :in (advent-2-data)
- :for (w h l) = dims
- :for sides = (list (* 2 (+ w h))
- (* 2 (+ w l))
- (* 2 (+ h l)))
- :for ribbon = (apply #'min sides)
- :for bow = (apply #'* dims)
- :sum (+ ribbon bow)))
-
-
-;;;; Day 3
-(defun advent-3-data ()
- (beef:trim-whitespace (beef:slurp "data/3")))
-
-(defun instruction-to-offsets (instruction)
- (case instruction
- (#\> '(1 0))
- (#\< '(-1 0))
- (#\^ '(0 1))
- (#\v '(0 -1))))
-
-(defun step-santa (loc dir)
- (destructuring-bind (x y) loc
- (destructuring-bind (dx dy) (instruction-to-offsets dir)
- (list (+ x dx) (+ y dy)))))
-
-(defun houses (data)
- (loop
- :with loc = '(0 0)
- :with visited = (fset:set '(0 0))
- :for dir :across data
- :do (setq loc (step-santa loc dir))
- :do (fset:includef visited loc)
- :finally (return visited)))
-
-(defun advent-3-1 (data)
- (fset:size (houses data)))
-
-(defun advent-3-2 (data)
- (fset:size
- (fset:union
- ; come directly at me
- (houses (ppcre:regex-replace-all "(.)." data "\\1"))
- (houses (ppcre:regex-replace-all ".(.)" data "\\1")))))
-
-
-;;;; Day 4
-(defun advent-4-data ()
- "ckczppom")
-
-(defun md5 (str)
- (ironclad:byte-array-to-hex-string
- (ironclad:digest-sequence :md5
- (ironclad:ascii-string-to-byte-array str))))
-
-(defun mine (data zeroes)
- (let ((target (apply #'concatenate 'string
- (loop :repeat zeroes :collect "0"))))
- (loop :for i :upfrom 1
- :for hash = (->> i
- prin1-to-string
- (concatenate 'string data)
- md5)
- :until (equal target (subseq hash 0 zeroes))
- :finally (return i))))
-
-(defun advent-4-1 (data)
- (mine data 5))
-
-(defun advent-4-2 (data)
- (mine data 6))
-
-
-;;;; Day 5
-(defun advent-5-data ()
- (-> "data/5"
- beef:slurp
- beef:trim-whitespace-right
- beef:split-lines))
-
-(defun join-strings (strings delim)
- "Join strings into a single string with the given delimiter string interleaved.
-
- Delim must not contain a ~.
-
- "
- (format nil (concatenate 'string "~{~A~^" delim "~}") strings))
-
-
-(defparameter *bad-pairs* '("ab" "cd" "pq" "xy"))
-
-(defun count-vowels (s)
- (length (ppcre:regex-replace-all "[^aeiou]" s "")))
-
-(defun has-run (s)
- (when (ppcre:scan "(.)\\1" s) t))
-
-(defun has-bad (s)
- (when (ppcre:scan (join-strings *bad-pairs* "|") s) t))
-
-(defun is-nice (s)
- (and (>= (count-vowels s) 3)
- (has-run s)
- (not (has-bad s))))
-
-(defun advent-5-1 (data)
- (count-if #'is-nice data))
-
-(defun has-run-2 (s)
- (when (ppcre:scan "(..).*\\1" s) t))
-
-(defun has-repeat (s)
- (when (ppcre:scan "(.).\\1" s) t))
-
-(defun is-nice-2 (s)
- (and (has-run-2 s)
- (has-repeat s)))
-
-(defun advent-5-2 (data)
- (count-if #'is-nice-2 data))
-
-
-;;;; Day 6
-(defun advent-6-data ()
- (beef:slurp-lines "data/6" :ignore-trailing-newline t))
-
-(defmacro loop-array (arr name &rest body)
- (let ((i (gensym "index")))
- `(loop :for ,i :below (array-total-size ,arr)
- :for ,name = (row-major-aref ,arr ,i)
- ,@body)))
-
-(defun parse-indexes (s)
- (->> s
- (split-sequence #\,)
- (mapcar #'parse-integer)))
-
-(defun flip (b)
- (if (zerop b) 1 0))
-
-(defun parse-line (line)
- (let ((parts (split-sequence #\space line)))
- (list (parse-indexes (beef:index parts -3))
- (parse-indexes (beef:index parts -1))
- (cond
- ((equal (car parts) "toggle") :toggle)
- ((equal (cadr parts) "on") :on)
- ((equal (cadr parts) "off") :off)
- (t (error "Unknown operation!"))))))
-
-(defmacro loop-square (r c from-row from-col to-row to-col &rest body)
- `(loop :for ,r :from ,from-row :to ,to-row
- :do (loop :for ,c :from ,from-col :to ,to-col
- ,@body)))
-
-(defun advent-6-1 (data)
- (let ((lights (make-array '(1000 1000) :element-type 'bit)))
- (loop
- :for line :in data
- :for ((from-row from-col) (to-row to-col) operation) = (parse-line line)
- :do (loop-square
- r c from-row from-col to-row to-col
- :do (setf (bit lights r c)
- (case operation
- (:toggle (flip (bit lights r c)))
- (:on 1)
- (:off 0)
- (t 0)))))
- (loop-array lights b
- :sum b)))
-
-(defun advent-6-2 (data)
- (let ((lights (make-array '(1000 1000) :element-type 'integer)))
- (loop
- :for line :in data
- :for ((from-row from-col) (to-row to-col) operation) = (parse-line line)
- :do (loop-square
- r c from-row from-col to-row to-col
- :do (case operation
- (:toggle (incf (aref lights r c) 2))
- (:on (incf (aref lights r c)))
- (:off (when (not (zerop (aref lights r c)))
- (decf (aref lights r c)))))))
- (loop-array lights b
- :sum b)))
-
-
-;;;; Day 7
-(defun advent-7-data ()
- (beef:slurp-lines "data/7" :ignore-trailing-newline t))
-
-(defun advent-7-2-data ()
- (beef:slurp-lines "data/7-2" :ignore-trailing-newline t))
-
-(defun int->bits (i)
- (bitsmash:bits<- (format nil "~4,'0X" i)))
-
-(defun bit-lshift (bit-array distance)
- (replace (make-array (length bit-array) :element-type 'bit)
- bit-array
- :start1 0
- :start2 (bitsmash:int<- distance)))
-
-(defun bit-rshift (bit-array distance)
- (let ((width (length bit-array))
- (distance (bitsmash:int<- distance)))
- (replace (make-array width :element-type 'bit)
- bit-array
- :start1 distance
- :end2 (- width distance))))
-
-(defun .zero-or-more (parser)
- (.plus (.let* ((x parser)
- (xs (.zero-or-more parser)))
- (.identity (cons x xs)))
- (.identity ())))
-
-(defun .one-or-more (parser)
- (.let* ((x parser)
- (y (.zero-or-more parser)))
- (.identity (cons x y))))
-
-(defun parse-7 (line)
- (labels ((.whitespace ()
- (.first (.one-or-more (.is 'member '(#\space #\tab)))))
- (.arrow ()
- (.first (.string= "->")))
- (.number ()
- (.let* ((digits (.first (.one-or-more (.is 'digit-char-p)))))
- (.identity (parse-integer (concatenate 'string digits)))))
- (.wire ()
- (.let* ((chars (.first (.one-or-more (.is 'lower-case-p)))))
- (.identity (concatenate 'string chars))))
- (.source ()
- (.or (.wire) (.number)))
- (.string-choice (strs)
- (if (not strs)
- (.fail)
- (.or (.string= (car strs))
- (.string-choice (cdr strs)))))
- (.dest ()
- (.progn (.whitespace) (.arrow) (.whitespace)
- (.wire)))
- (.constant-source ()
- (.let* ((val (.source)))
- (.identity (list #'identity (list val)))))
- (.binary-op ()
- (let ((ops '(("AND" . bit-and)
- ("OR" . bit-ior)
- ("LSHIFT" . bit-lshift)
- ("RSHIFT" . bit-rshift))))
- (.let* ((name (.string-choice (mapcar #'car ops))))
- (.identity (cdr (assoc name ops :test #'equal))))))
- (.binary-source ()
- (.let* ((left (.source))
- (_ (.whitespace))
- (op (.binary-op))
- (_ (.whitespace))
- (right (.source)))
- (.identity (list op (list left right)))))
- (.unary-op ()
- (.let* ((_ (.string= "NOT")))
- (.identity #'bit-not)))
- (.unary-source ()
- (.let* ((op (.unary-op))
- (_ (.whitespace))
- (source (.source)))
- (.identity (list op (list source)))))
- (.instruction ()
- (.let* ((source (.or (.binary-source)
- (.unary-source)
- (.constant-source)))
- (dest (.dest)))
- (.identity (concatenate 'list source (list dest))))))
- (parse (.instruction) line)))
-
-(defun advent-7-1 (data)
- (let ((circuit (make-hash-table :test #'equal))
- (commands (mapcar #'parse-7 data)))
- (labels ((retrieve (source)
- (cond
- ((stringp source) (gethash source circuit))
- ((integerp source) (int->bits source))
- (t (error "what?"))))
- (ready (args)
- (every #'identity args))
- (perform (fn args dest)
- (setf (gethash dest circuit)
- (apply fn args)))
- (try-command (command)
- "If the command is ready to go, run it and return nil. Otherwise,
- return the command itself."
- (destructuring-bind (fn args dest) command
- (let ((vals (mapcar #'retrieve args)))
- (if (ready vals)
- (progn
- (perform fn vals dest)
- nil)
- command)))))
- (loop :while commands
- :do (setf commands
- (loop :for command :in commands
- :when (try-command command)
- :collect :it)))
- (bitsmash:bits->int (gethash "a" circuit)))))
-
-
-;;;; Day 8
-(defun advent-8-data ()
- (beef:slurp-lines "data/8" :ignore-trailing-newline t))
-
-
-(defconstant +backslash+ #\\ )
-(defconstant +quote+ #\" )
-
-(defun parse-8 (line)
- (labels ((.hex-digit ()
- (.or
- (.is #'digit-char-p)
- (.is #'member '(#\a #\b #\c #\d #\e #\f))))
- (.hex-escape ()
- (.let* ((_ (.char= #\x))
- (a (.hex-digit))
- (b (.hex-digit)))
- (.identity
- (->> (format nil "~A~A" a b)
- bitsmash:hex->int
- code-char))))
- (.escaped-char ()
- (.progn
- (.char= +backslash+)
- (.or (.char= +backslash+)
- (.char= +quote+)
- (.hex-escape))))
- (.normal-char ()
- (.is-not 'member (list +backslash+ +quote+)))
- (.string-char ()
- (.or (.normal-char)
- (.escaped-char)))
- (.full-string ()
- (.prog2
- (.char= +quote+)
- (.first (.zero-or-more (.string-char)))
- (.char= +quote+))))
- (parse (.full-string) line)))
-
-(defun .wrap (fn parser)
- (.let* ((v parser))
- (.identity (funcall fn v))))
-
-(defun parse-8-2 (line)
- (labels ((.special-char ()
- (.let* ((ch (.or (.char= +backslash+)
- (.char= +quote+))))
- (.identity (list +backslash+ ch))))
- (.normal-char ()
- (.wrap #'list
- (.is-not 'member (list +backslash+ +quote+))))
- (.string-char ()
- (.or (.normal-char)
- (.special-char)))
- (.full-string ()
- (.let* ((chars (.zero-or-more (.string-char))))
- (.identity (apply #'concatenate 'list chars)))))
- (append (list +quote+)
- (parse (.full-string) line)
- (list +quote+))))
-
-(defun advent-8-1 (data)
- (loop :for line :in data
- :for chars = (parse-8 line)
- :sum (- (length line)
- (length chars))))
-
-(defun advent-8-2 (data)
- (loop :for line :in data
- :for chars = (parse-8-2 line)
- :sum (- (length chars)
- (length line))))
-
-
-;;;; Day 9
-(defun advent-9-data ()
- (beef:slurp-lines "data/9" :ignore-trailing-newline t))
-
-; Thanks Norvig
-; http://norvig.com/paip/gps.lisp
-(defun permutations (bag)
- "Return a list of all the permutations of the input."
- ;; If the input is nil, there is only one permutation:
- ;; nil itself
- (if (null bag)
- '(())
- ;; Otherwise, take an element, e, out of the bag.
- ;; Generate all permutations of the remaining elements,
- ;; And add e to the front of each of these.
- ;; Do this for all possible e to generate all permutations.
- (mapcan #'(lambda (e)
- (mapcar #'(lambda (p) (cons e p))
- (permutations
- (remove e bag :count 1 :test #'eq))))
- bag)))
-
-(defun advent-9 (data)
- (let ((distances (make-hash-table :test #'equal)))
- (loop :for line :in data
- :for (a to b _ dist) = (split-sequence #\space line)
- :for distance = (parse-integer dist)
- :do (progn
- (setf (gethash (cons a b) distances) distance)
- (setf (gethash (cons b a) distances) distance)))
- (labels ((score-route (route)
- (optima:match route
- ((list _) 0)
- ((list* a b _) (+ (gethash (cons a b) distances)
- (score-route (cdr route))))))
- (dedupe (l)
- (remove-duplicates l :test #'equal)))
- (loop :for route :in (->> distances
- beef:hash-keys
- (mapcar #'car)
- dedupe
- permutations)
- :for score = (score-route route)
- :minimizing score :into min-dist
- :maximizing score :into max-dist
- :finally (return (cons min-dist max-dist))))))
-
-
-(defmethod print-object ((object hash-table) stream)
- (format stream "#HASH{~%~{~{ (~s : ~s)~}~%~}}"
- (loop for key being the hash-keys of object
- using (hash-value value)
- collect (list key value))))
-
-
-;;;; Day 10
-(defun advent-10-data ()
- "1321131112")
-
-(defun look-and-say (seq)
- (let ((runs (list))
- (len 1)
- (current -1))
- (flet ((mark-run ()
- (setf runs (cons current (cons len runs)))))
- (loop :for n :in seq
- :do (if (= current n)
- (incf len)
- (progn
- (when (not (= -1 current))
- (mark-run))
- (setf len 1)
- (setf current n)))
- :finally (mark-run))
- (reverse runs))))
-
-(defun iterate (n f data)
- (declare (optimize speed (debug 0)))
- (dotimes (_ n)
- (setf data (funcall f data)))
- data)
-
-(defun las-to-list (s)
- (loop :for digit :across s
- :collect (-> digit string parse-integer)))
-
-(defun advent-10-1 (data)
- (length (iterate 40 #'look-and-say (las-to-list data))))
-
-(defun advent-10-2 (data)
- (length (iterate 50 #'look-and-say (las-to-list data))))
-
-
-;;;; Day 11
-(defun advent-11-data ()
- "vzbxkghb")
-
-
-(defparameter base 26)
-(defparameter ascii-alpha-start (char-code #\a))
-(defun num-to-char (n)
- (code-char (+ n ascii-alpha-start)))
-
-(defun char-to-num (ch)
- (- (char-code ch) ascii-alpha-start))
-
-
-(defmacro loop-window (seq width binding-form &rest body)
- (let ((i (gensym "IGNORE"))
- (s (gensym "SEQ"))
- (n (gensym "WIDTH"))
- (tail (gensym "TAIL")))
- `(let ((,s ,seq)
- (,n ,width))
- (loop :for ,i :upto (- (length ,s) ,n)
- :for ,tail :on ,s
- :for ,binding-form = (subseq ,tail 0 ,n)
- ,@body))))
-
-
-(defun is-straight-3 (l)
- (destructuring-bind (a b c) l
- (and (= 1 (- b a))
- (= 1 (- c b)))))
-
-(defun has-straight-3 (nums)
- (loop-window nums 3 triplet
- :thereis (is-straight-3 triplet)))
-
-
-(defparameter bad-chars
- (mapcar #'char-to-num '(#\i #\l #\o)))
-
-(defun no-bad (nums)
- (loop :for bad :in bad-chars
- :never (find bad nums)))
-
-
-(defun two-pairs (nums)
- (-> nums
- (loop-window 2 (a b)
- :when (= a b)
- :collect a)
- remove-duplicates
- length
- (>= 2)))
-
-
-(defun valid (nums)
- (and (has-straight-3 nums)
- (no-bad nums)
- (two-pairs nums)
- nums))
-
-
-(defun incr-nums (nums)
- (labels ((inc-mod (x)
- (mod (1+ x) base))
- (inc (nums)
- (if (not nums)
- '(1)
- (let ((head (inc-mod (car nums))))
- (if (zerop head)
- (cons head (inc (cdr nums)))
- (cons head (cdr nums)))))))
- (reverse (inc (reverse nums)))))
-
-
-(defun advent-11-1 (data)
- (flet ((chars-to-string (chs)
- (apply #'concatenate 'string (mapcar #'string chs)))
- (nums-to-chars (nums)
- (mapcar #'num-to-char nums))
- (string-to-nums (str)
- (loop :for ch :across str
- :collect (char-to-num ch))))
- (-> (loop :for pw = (incr-nums (string-to-nums data))
- :then (incr-nums pw)
- :thereis (valid pw))
- nums-to-chars
- chars-to-string)))
-
-
-;;;; Day 12
-(defun advent-12-data ()
- (beef:trim-whitespace (beef:slurp "data/12")))
-
-
-(defun parse-json (s)
- (labels ((.number ()
- (.let* ((negation (.optional (.char= #\-)))
- (digits (.first (.one-or-more (.is 'digit-char-p)))))
- (.identity (let ((i (parse-integer (concatenate 'string digits)))
- (c (if negation -1 1)))
- (* i c)))))
- (.string-char ()
- (.wrap #'list (.is-not 'member (list +quote+))))
- (.string-guts ()
- (.let* ((chars (.zero-or-more (.string-char))))
- (.identity (apply #'concatenate 'string chars))))
- (.string ()
- (.prog2
- (.char= +quote+)
- (.string-guts)
- (.char= +quote+)))
- (.map-pair ()
- (.let* ((key (.string))
- (_ (.char= #\:))
- (value (.expression)))
- (.identity (cons key value))))
- (.map-guts ()
- (.or
- (.let* ((p (.map-pair))
- (_ (.char= #\,))
- (remaining (.map-guts)))
- (.identity (cons p remaining)))
- (.wrap #'list (.map-pair))
- (.identity '())))
- (.map ()
- (.prog2
- (.char= #\{)
- (.wrap (lambda (v) (cons :map v))
- (.map-guts))
- (.char= #\})))
- (.array-guts ()
- (.or
- (.let* ((item (.expression))
- (_ (.char= #\,))
- (remaining (.array-guts)))
- (.identity (cons item remaining)))
- (.wrap #'list (.expression))
- (.identity '())))
- (.array ()
- (.prog2
- (.char= #\[)
- (.wrap (lambda (v) (cons :array v))
- (.array-guts))
- (.char= #\])))
- (.expression ()
- (.or (.array)
- (.map)
- (.string)
- (.number))))
- (parse (.expression) s)))
-
-(defun walk-sum (v)
- (cond
- ((not v) 0)
- ((typep v 'integer) v)
- ((typep v 'string) 0)
- ((eql (car v) :array) (loop :for value in (cdr v)
- :sum (walk-sum value)))
- ((eql (car v) :map) (loop :for (key . value) :in (cdr v)
- :sum (walk-sum value)))
- (:else (error (format nil "wat? ~a" v)))))
-
-(defun walk-sum-2 (v)
- (cond
- ((not v) 0)
- ((typep v 'integer) v)
- ((typep v 'string) 0)
- ((eql (car v) :array) (loop :for value in (cdr v)
- :sum (walk-sum-2 value)))
- ((eql (car v) :map)
- (if (member "red" (mapcar #'cdr (cdr v))
- :test #'equal)
- 0
- (loop :for (key . value) :in (cdr v)
- :sum (walk-sum-2 value))))
- (:else (error (format nil "wat? ~a" v)))))
-
-
-(defun advent-12-1 (data)
- (walk-sum (parse-json data)))
-
-(defun advent-12-2 (data)
- (walk-sum-2 (parse-json data)))
-
-
-;;;; Day 13
-(defun advent-13-data ()
- (beef:slurp-lines "data/13" :ignore-trailing-newline t))
-
-
-(defvar *wat* nil)
-
-(defmacro map-when (test fn val &rest args)
- (let ((v (gensym "VALUE")))
- `(let ((,v ,val))
- (if ,test
- (apply ,fn ,v ,args)
- ,v))))
-
-(defun split-lines-13 (lines)
- (loop :for line :in lines
- :collect (ppcre:register-groups-bind
- (a dir amount b)
- ("(\\w+) would (gain|lose) (\\d+) .*? next to (\\w+)."
- line)
- (list a b (map-when (equal "lose" dir)
- #'-
- (parse-integer amount))))))
-
-(defun rate-seating (vals arrangement)
- (labels ((find-val (a b)
- (or (gethash (cons a b) vals) 0))
- (rate-one-direction (arr)
- (+ (loop-window arr 2 (a b) :sum (find-val a b))
- (find-val (car (last arr)) (car arr)))))
- (+ (rate-one-direction arrangement)
- (rate-one-direction (reverse arrangement)))))
-
-(defun advent-13-1 (data)
- (let* ((tups (split-lines-13 data))
- (attendees (remove-duplicates (mapcar #'car tups) :test #'equal))
- (vals (make-hash-table :test #'equal)))
- (loop :for (a b val) :in tups
- :do (setf (gethash (cons a b) vals) val))
- (loop :for arrangement :in (permutations attendees)
- :maximize (rate-seating vals arrangement))))
-
-(defun advent-13-2 (data)
- (let* ((tups (split-lines-13 data))
- (attendees (cons "Self" (remove-duplicates (mapcar #'car tups) :test #'equal)))
- (vals (make-hash-table :test #'equal)))
- (loop :for (a b val) :in tups
- :do (setf (gethash (cons a b) vals) val))
- (loop :for arrangement :in (permutations attendees)
- :maximize (rate-seating vals arrangement))))
-
-
-;;;; Day 14
-(defun advent-14-data ()
- (beef:slurp-lines "data/14" :ignore-trailing-newline t))
-
-
-(defun tick (deer)
- (destructuring-bind
- (name speed sprint-period rest-period traveled currently remaining)
- deer
- (let ((remaining (1- remaining)))
- (if (equal currently :resting)
- (list name speed sprint-period rest-period
- traveled
- (if (zerop remaining) :sprinting :resting)
- (if (zerop remaining) sprint-period remaining))
- (list name speed sprint-period rest-period
- (+ traveled speed)
- (if (zerop remaining) :resting :sprinting)
- (if (zerop remaining) rest-period remaining))))))
-
-(defun parse-deers (lines)
- (loop :for line :in lines
- :collect (ppcre:register-groups-bind
- (name speed sprint-period rest-period)
- ("(\\w+) can fly (\\d+) km/s for (\\d+) .* (\\d+) seconds."
- line)
- (list name
- (parse-integer speed)
- (parse-integer sprint-period)
- (parse-integer rest-period)
- 0
- :sprinting
- (parse-integer sprint-period)))))
-
-(defun find-leaders (deers)
- (let ((dist (reduce #'max deers :key (beef:partial #'nth 4))))
- (remove-if-not (lambda (deer)
- (= dist (nth 4 deer)))
- deers)))
-
-
-(defun advent-14-1 (data n)
- (apply #'max
- (loop :for i :upto n
- :for deers := (parse-deers data) :then (mapcar #'tick deers)
- :finally (return (mapcar (beef:partial #'nth 4) deers)))))
-
-(defun advent-14-2 (data n)
- (let ((scores (make-hash-table :test #'equal))
- (deers (parse-deers data)))
- (loop :for (name) :in deers
- :do (setf (gethash name scores) 0))
- (loop :for i :upto n
- :do (setf deers (mapcar #'tick deers))
- :do (loop :for (name) :in (find-leaders deers)
- :do (incf (gethash name scores))))
- (apply #'max (beef:hash-values scores))))
-
-
-
-;;;; Day 15
-(defun advent-15-data ()
- (beef:slurp-lines "data/15" :ignore-trailing-newline t))
-
-(defun split-ingredients (line)
- (ppcre:register-groups-bind
- (name (#'parse-integer capacity durability flavor texture calories))
- ("(\\w+): capacity (-?\\d+), durability (-?\\d+), flavor (-?\\d+), texture (-?\\d+), calories (-?\\d+)"
- line)
- (list name capacity durability flavor texture calories)))
-
-(defun calc-contribution (ingr amount)
- (cons (car ingr)
- (mapcar (beef:partial #'* amount)
- (cdr ingr))))
-
-(defun calc-contributions (ingrs alist)
- (mapcar #'calc-contribution ingrs alist))
-
-(defun sum-totals (ingrs)
- (->> ingrs
- (mapcar #'cdr)
- (apply #'mapcar #'+)
- (mapcar (lambda (x) (if (< x 0) 0 x)))))
-
-(defun advent-15-1 (data)
- (let ((ingredients (mapcar #'split-ingredients data))
- (limit 100)
- (amounts (list)))
- ; fuckin lol
- (loop :for a :upto limit :do
- (loop :for b :upto (- limit a) :do
- (loop :for c :upto (- limit a b) :do
- (setf amounts
- (cons (list a b c (- limit a b c))
- amounts)))))
- (loop :for alist :in amounts
- :maximize (->> alist
- (calc-contributions ingredients)
- sum-totals
- butlast
- (apply #'*)))))
-
-(defun advent-15-2 (data)
- (let ((ingredients (mapcar #'split-ingredients data))
- (limit 100)
- (amounts (list)))
- ; fuckin lol
- (loop :for a :upto limit :do
- (loop :for b :upto (- limit a) :do
- (loop :for c :upto (- limit a b) :do
- (setf amounts
- (cons (list a b c (- limit a b c))
- amounts)))))
- (loop :for alist :in amounts
- :for val = (->> alist
- (calc-contributions ingredients)
- sum-totals)
- :when (= (car (last val)) 500)
- :maximize (apply #'* (butlast val)))))
-
-
-;;;; Scratch
-#+comment
-(advent-15-2 (advent-15-data))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/2015/2015.lisp Sun Dec 03 18:39:45 2017 -0500
@@ -0,0 +1,898 @@
+; https://bitbucket.org/sjl/beef
+(ql:quickload "beef")
+(ql:quickload "alexandria")
+(ql:quickload "split-sequence")
+(ql:quickload "cl-arrows")
+(ql:quickload "fset")
+(ql:quickload "cl-ppcre")
+(ql:quickload "ironclad")
+(ql:quickload "smug")
+(ql:quickload "bit-smasher")
+(ql:quickload "optima")
+
+(defpackage #:advent
+ (:use #:cl)
+ (:use #:cl-arrows)
+ (:use #:split-sequence)
+ (:use #:smug))
+
+(in-package #:advent)
+
+(declaim (optimize (debug 3)))
+
+;;;; Day 1
+(defun instruction-to-num (ch)
+ (cond
+ ((eql ch #\() 1)
+ ((eql ch #\)) -1)
+ (t 0)))
+
+(defun advent-1-1 ()
+ (loop :for c :across (beef:slurp "data/1")
+ :sum (instruction-to-num c)))
+
+(defun advent-1-2 ()
+ (loop :for c :across (beef:slurp "data/1")
+ :sum (instruction-to-num c) :into floor
+ :sum 1
+ :until (= floor -1)))
+
+
+;;;; Day 2
+(defun advent-2-data ()
+ (->> (beef:slurp "data/2")
+ beef:trim-whitespace-right
+ beef:split-lines
+ (mapcar (lambda (s)
+ (->> s
+ (split-sequence #\x)
+ (mapcar #'parse-integer))))))
+
+(defun advent-2-1 ()
+ (loop :for dims :in (advent-2-data)
+ :for (w h l) = dims
+ :for sides = (list (* w h)
+ (* w l)
+ (* h l))
+ :for paper = (* 2 (apply #'+ sides))
+ :for slack = (apply #'min sides)
+ :sum (+ paper slack)))
+
+(defun advent-2-2 ()
+ (loop :for dims :in (advent-2-data)
+ :for (w h l) = dims
+ :for sides = (list (* 2 (+ w h))
+ (* 2 (+ w l))
+ (* 2 (+ h l)))
+ :for ribbon = (apply #'min sides)
+ :for bow = (apply #'* dims)
+ :sum (+ ribbon bow)))
+
+
+;;;; Day 3
+(defun advent-3-data ()
+ (beef:trim-whitespace (beef:slurp "data/3")))
+
+(defun instruction-to-offsets (instruction)
+ (case instruction
+ (#\> '(1 0))
+ (#\< '(-1 0))
+ (#\^ '(0 1))
+ (#\v '(0 -1))))
+
+(defun step-santa (loc dir)
+ (destructuring-bind (x y) loc
+ (destructuring-bind (dx dy) (instruction-to-offsets dir)
+ (list (+ x dx) (+ y dy)))))
+
+(defun houses (data)
+ (loop
+ :with loc = '(0 0)
+ :with visited = (fset:set '(0 0))
+ :for dir :across data
+ :do (setq loc (step-santa loc dir))
+ :do (fset:includef visited loc)
+ :finally (return visited)))
+
+(defun advent-3-1 (data)
+ (fset:size (houses data)))
+
+(defun advent-3-2 (data)
+ (fset:size
+ (fset:union
+ ; come directly at me
+ (houses (ppcre:regex-replace-all "(.)." data "\\1"))
+ (houses (ppcre:regex-replace-all ".(.)" data "\\1")))))
+
+
+;;;; Day 4
+(defun advent-4-data ()
+ "ckczppom")
+
+(defun md5 (str)
+ (ironclad:byte-array-to-hex-string
+ (ironclad:digest-sequence :md5
+ (ironclad:ascii-string-to-byte-array str))))
+
+(defun mine (data zeroes)
+ (let ((target (apply #'concatenate 'string
+ (loop :repeat zeroes :collect "0"))))
+ (loop :for i :upfrom 1
+ :for hash = (->> i
+ prin1-to-string
+ (concatenate 'string data)
+ md5)
+ :until (equal target (subseq hash 0 zeroes))
+ :finally (return i))))
+
+(defun advent-4-1 (data)
+ (mine data 5))
+
+(defun advent-4-2 (data)
+ (mine data 6))
+
+
+;;;; Day 5
+(defun advent-5-data ()
+ (-> "data/5"
+ beef:slurp
+ beef:trim-whitespace-right
+ beef:split-lines))
+
+(defun join-strings (strings delim)
+ "Join strings into a single string with the given delimiter string interleaved.
+
+ Delim must not contain a ~.
+
+ "
+ (format nil (concatenate 'string "~{~A~^" delim "~}") strings))
+
+
+(defparameter *bad-pairs* '("ab" "cd" "pq" "xy"))
+
+(defun count-vowels (s)
+ (length (ppcre:regex-replace-all "[^aeiou]" s "")))
+
+(defun has-run (s)
+ (when (ppcre:scan "(.)\\1" s) t))
+
+(defun has-bad (s)
+ (when (ppcre:scan (join-strings *bad-pairs* "|") s) t))
+
+(defun is-nice (s)
+ (and (>= (count-vowels s) 3)
+ (has-run s)
+ (not (has-bad s))))
+
+(defun advent-5-1 (data)
+ (count-if #'is-nice data))
+
+(defun has-run-2 (s)
+ (when (ppcre:scan "(..).*\\1" s) t))
+
+(defun has-repeat (s)
+ (when (ppcre:scan "(.).\\1" s) t))
+
+(defun is-nice-2 (s)
+ (and (has-run-2 s)
+ (has-repeat s)))
+
+(defun advent-5-2 (data)
+ (count-if #'is-nice-2 data))
+
+
+;;;; Day 6
+(defun advent-6-data ()
+ (beef:slurp-lines "data/6" :ignore-trailing-newline t))
+
+(defmacro loop-array (arr name &rest body)
+ (let ((i (gensym "index")))
+ `(loop :for ,i :below (array-total-size ,arr)
+ :for ,name = (row-major-aref ,arr ,i)
+ ,@body)))
+
+(defun parse-indexes (s)
+ (->> s
+ (split-sequence #\,)
+ (mapcar #'parse-integer)))
+
+(defun flip (b)
+ (if (zerop b) 1 0))
+
+(defun parse-line (line)
+ (let ((parts (split-sequence #\space line)))
+ (list (parse-indexes (beef:index parts -3))
+ (parse-indexes (beef:index parts -1))
+ (cond
+ ((equal (car parts) "toggle") :toggle)
+ ((equal (cadr parts) "on") :on)
+ ((equal (cadr parts) "off") :off)
+ (t (error "Unknown operation!"))))))
+
+(defmacro loop-square (r c from-row from-col to-row to-col &rest body)
+ `(loop :for ,r :from ,from-row :to ,to-row
+ :do (loop :for ,c :from ,from-col :to ,to-col
+ ,@body)))
+
+(defun advent-6-1 (data)
+ (let ((lights (make-array '(1000 1000) :element-type 'bit)))
+ (loop
+ :for line :in data
+ :for ((from-row from-col) (to-row to-col) operation) = (parse-line line)
+ :do (loop-square
+ r c from-row from-col to-row to-col
+ :do (setf (bit lights r c)
+ (case operation
+ (:toggle (flip (bit lights r c)))
+ (:on 1)
+ (:off 0)
+ (t 0)))))
+ (loop-array lights b
+ :sum b)))
+
+(defun advent-6-2 (data)
+ (let ((lights (make-array '(1000 1000) :element-type 'integer)))
+ (loop
+ :for line :in data
+ :for ((from-row from-col) (to-row to-col) operation) = (parse-line line)
+ :do (loop-square
+ r c from-row from-col to-row to-col
+ :do (case operation
+ (:toggle (incf (aref lights r c) 2))
+ (:on (incf (aref lights r c)))
+ (:off (when (not (zerop (aref lights r c)))
+ (decf (aref lights r c)))))))
+ (loop-array lights b
+ :sum b)))
+
+
+;;;; Day 7
+(defun advent-7-data ()
+ (beef:slurp-lines "data/7" :ignore-trailing-newline t))
+
+(defun advent-7-2-data ()
+ (beef:slurp-lines "data/7-2" :ignore-trailing-newline t))
+
+(defun int->bits (i)
+ (bitsmash:bits<- (format nil "~4,'0X" i)))
+
+(defun bit-lshift (bit-array distance)
+ (replace (make-array (length bit-array) :element-type 'bit)
+ bit-array
+ :start1 0
+ :start2 (bitsmash:int<- distance)))
+
+(defun bit-rshift (bit-array distance)
+ (let ((width (length bit-array))
+ (distance (bitsmash:int<- distance)))
+ (replace (make-array width :element-type 'bit)
+ bit-array
+ :start1 distance
+ :end2 (- width distance))))
+
+(defun .zero-or-more (parser)
+ (.plus (.let* ((x parser)
+ (xs (.zero-or-more parser)))
+ (.identity (cons x xs)))
+ (.identity ())))
+
+(defun .one-or-more (parser)
+ (.let* ((x parser)
+ (y (.zero-or-more parser)))
+ (.identity (cons x y))))
+
+(defun parse-7 (line)
+ (labels ((.whitespace ()
+ (.first (.one-or-more (.is 'member '(#\space #\tab)))))
+ (.arrow ()
+ (.first (.string= "->")))
+ (.number ()
+ (.let* ((digits (.first (.one-or-more (.is 'digit-char-p)))))
+ (.identity (parse-integer (concatenate 'string digits)))))
+ (.wire ()
+ (.let* ((chars (.first (.one-or-more (.is 'lower-case-p)))))
+ (.identity (concatenate 'string chars))))
+ (.source ()
+ (.or (.wire) (.number)))
+ (.string-choice (strs)
+ (if (not strs)
+ (.fail)
+ (.or (.string= (car strs))
+ (.string-choice (cdr strs)))))
+ (.dest ()
+ (.progn (.whitespace) (.arrow) (.whitespace)
+ (.wire)))
+ (.constant-source ()
+ (.let* ((val (.source)))
+ (.identity (list #'identity (list val)))))
+ (.binary-op ()
+ (let ((ops '(("AND" . bit-and)
+ ("OR" . bit-ior)
+ ("LSHIFT" . bit-lshift)
+ ("RSHIFT" . bit-rshift))))
+ (.let* ((name (.string-choice (mapcar #'car ops))))
+ (.identity (cdr (assoc name ops :test #'equal))))))
+ (.binary-source ()
+ (.let* ((left (.source))
+ (_ (.whitespace))
+ (op (.binary-op))
+ (_ (.whitespace))
+ (right (.source)))
+ (.identity (list op (list left right)))))
+ (.unary-op ()
+ (.let* ((_ (.string= "NOT")))
+ (.identity #'bit-not)))
+ (.unary-source ()
+ (.let* ((op (.unary-op))
+ (_ (.whitespace))
+ (source (.source)))
+ (.identity (list op (list source)))))
+ (.instruction ()
+ (.let* ((source (.or (.binary-source)
+ (.unary-source)
+ (.constant-source)))
+ (dest (.dest)))
+ (.identity (concatenate 'list source (list dest))))))
+ (parse (.instruction) line)))
+
+(defun advent-7-1 (data)
+ (let ((circuit (make-hash-table :test #'equal))
+ (commands (mapcar #'parse-7 data)))
+ (labels ((retrieve (source)
+ (cond
+ ((stringp source) (gethash source circuit))
+ ((integerp source) (int->bits source))
+ (t (error "what?"))))
+ (ready (args)
+ (every #'identity args))
+ (perform (fn args dest)
+ (setf (gethash dest circuit)
+ (apply fn args)))
+ (try-command (command)
+ "If the command is ready to go, run it and return nil. Otherwise,
+ return the command itself."
+ (destructuring-bind (fn args dest) command
+ (let ((vals (mapcar #'retrieve args)))
+ (if (ready vals)
+ (progn
+ (perform fn vals dest)
+ nil)
+ command)))))
+ (loop :while commands
+ :do (setf commands
+ (loop :for command :in commands
+ :when (try-command command)
+ :collect :it)))
+ (bitsmash:bits->int (gethash "a" circuit)))))
+
+
+;;;; Day 8
+(defun advent-8-data ()
+ (beef:slurp-lines "data/8" :ignore-trailing-newline t))
+
+
+(defconstant +backslash+ #\\ )
+(defconstant +quote+ #\" )
+
+(defun parse-8 (line)
+ (labels ((.hex-digit ()
+ (.or
+ (.is #'digit-char-p)
+ (.is #'member '(#\a #\b #\c #\d #\e #\f))))
+ (.hex-escape ()
+ (.let* ((_ (.char= #\x))
+ (a (.hex-digit))
+ (b (.hex-digit)))
+ (.identity
+ (->> (format nil "~A~A" a b)
+ bitsmash:hex->int
+ code-char))))
+ (.escaped-char ()
+ (.progn
+ (.char= +backslash+)
+ (.or (.char= +backslash+)
+ (.char= +quote+)
+ (.hex-escape))))
+ (.normal-char ()
+ (.is-not 'member (list +backslash+ +quote+)))
+ (.string-char ()
+ (.or (.normal-char)
+ (.escaped-char)))
+ (.full-string ()
+ (.prog2
+ (.char= +quote+)
+ (.first (.zero-or-more (.string-char)))
+ (.char= +quote+))))
+ (parse (.full-string) line)))
+
+(defun .wrap (fn parser)
+ (.let* ((v parser))
+ (.identity (funcall fn v))))
+
+(defun parse-8-2 (line)
+ (labels ((.special-char ()
+ (.let* ((ch (.or (.char= +backslash+)
+ (.char= +quote+))))
+ (.identity (list +backslash+ ch))))
+ (.normal-char ()
+ (.wrap #'list
+ (.is-not 'member (list +backslash+ +quote+))))
+ (.string-char ()
+ (.or (.normal-char)
+ (.special-char)))
+ (.full-string ()
+ (.let* ((chars (.zero-or-more (.string-char))))
+ (.identity (apply #'concatenate 'list chars)))))
+ (append (list +quote+)
+ (parse (.full-string) line)
+ (list +quote+))))
+
+(defun advent-8-1 (data)
+ (loop :for line :in data
+ :for chars = (parse-8 line)
+ :sum (- (length line)
+ (length chars))))
+
+(defun advent-8-2 (data)
+ (loop :for line :in data
+ :for chars = (parse-8-2 line)
+ :sum (- (length chars)
+ (length line))))
+
+
+;;;; Day 9
+(defun advent-9-data ()
+ (beef:slurp-lines "data/9" :ignore-trailing-newline t))
+
+; Thanks Norvig
+; http://norvig.com/paip/gps.lisp
+(defun permutations (bag)
+ "Return a list of all the permutations of the input."
+ ;; If the input is nil, there is only one permutation:
+ ;; nil itself
+ (if (null bag)
+ '(())
+ ;; Otherwise, take an element, e, out of the bag.
+ ;; Generate all permutations of the remaining elements,
+ ;; And add e to the front of each of these.
+ ;; Do this for all possible e to generate all permutations.
+ (mapcan #'(lambda (e)
+ (mapcar #'(lambda (p) (cons e p))
+ (permutations
+ (remove e bag :count 1 :test #'eq))))
+ bag)))
+
+(defun advent-9 (data)
+ (let ((distances (make-hash-table :test #'equal)))
+ (loop :for line :in data
+ :for (a to b _ dist) = (split-sequence #\space line)
+ :for distance = (parse-integer dist)
+ :do (progn
+ (setf (gethash (cons a b) distances) distance)
+ (setf (gethash (cons b a) distances) distance)))
+ (labels ((score-route (route)
+ (optima:match route
+ ((list _) 0)
+ ((list* a b _) (+ (gethash (cons a b) distances)
+ (score-route (cdr route))))))
+ (dedupe (l)
+ (remove-duplicates l :test #'equal)))
+ (loop :for route :in (->> distances
+ beef:hash-keys
+ (mapcar #'car)
+ dedupe
+ permutations)
+ :for score = (score-route route)
+ :minimizing score :into min-dist
+ :maximizing score :into max-dist
+ :finally (return (cons min-dist max-dist))))))
+
+
+(defmethod print-object ((object hash-table) stream)
+ (format stream "#HASH{~%~{~{ (~s : ~s)~}~%~}}"
+ (loop for key being the hash-keys of object
+ using (hash-value value)
+ collect (list key value))))
+
+
+;;;; Day 10
+(defun advent-10-data ()
+ "1321131112")
+
+(defun look-and-say (seq)
+ (let ((runs (list))
+ (len 1)
+ (current -1))
+ (flet ((mark-run ()
+ (setf runs (cons current (cons len runs)))))
+ (loop :for n :in seq
+ :do (if (= current n)
+ (incf len)
+ (progn
+ (when (not (= -1 current))
+ (mark-run))
+ (setf len 1)
+ (setf current n)))
+ :finally (mark-run))
+ (reverse runs))))
+
+(defun iterate (n f data)
+ (declare (optimize speed (debug 0)))
+ (dotimes (_ n)
+ (setf data (funcall f data)))
+ data)
+
+(defun las-to-list (s)
+ (loop :for digit :across s
+ :collect (-> digit string parse-integer)))
+
+(defun advent-10-1 (data)
+ (length (iterate 40 #'look-and-say (las-to-list data))))
+
+(defun advent-10-2 (data)
+ (length (iterate 50 #'look-and-say (las-to-list data))))
+
+
+;;;; Day 11
+(defun advent-11-data ()
+ "vzbxkghb")
+
+
+(defparameter base 26)
+(defparameter ascii-alpha-start (char-code #\a))
+(defun num-to-char (n)
+ (code-char (+ n ascii-alpha-start)))
+
+(defun char-to-num (ch)
+ (- (char-code ch) ascii-alpha-start))
+
+
+(defmacro loop-window (seq width binding-form &rest body)
+ (let ((i (gensym "IGNORE"))
+ (s (gensym "SEQ"))
+ (n (gensym "WIDTH"))
+ (tail (gensym "TAIL")))
+ `(let ((,s ,seq)
+ (,n ,width))
+ (loop :for ,i :upto (- (length ,s) ,n)
+ :for ,tail :on ,s
+ :for ,binding-form = (subseq ,tail 0 ,n)
+ ,@body))))
+
+
+(defun is-straight-3 (l)
+ (destructuring-bind (a b c) l
+ (and (= 1 (- b a))
+ (= 1 (- c b)))))
+
+(defun has-straight-3 (nums)
+ (loop-window nums 3 triplet
+ :thereis (is-straight-3 triplet)))
+
+
+(defparameter bad-chars
+ (mapcar #'char-to-num '(#\i #\l #\o)))
+
+(defun no-bad (nums)
+ (loop :for bad :in bad-chars
+ :never (find bad nums)))
+
+
+(defun two-pairs (nums)
+ (-> nums
+ (loop-window 2 (a b)
+ :when (= a b)
+ :collect a)
+ remove-duplicates
+ length
+ (>= 2)))
+
+
+(defun valid (nums)
+ (and (has-straight-3 nums)
+ (no-bad nums)
+ (two-pairs nums)
+ nums))
+
+
+(defun incr-nums (nums)
+ (labels ((inc-mod (x)
+ (mod (1+ x) base))
+ (inc (nums)
+ (if (not nums)
+ '(1)
+ (let ((head (inc-mod (car nums))))
+ (if (zerop head)
+ (cons head (inc (cdr nums)))
+ (cons head (cdr nums)))))))
+ (reverse (inc (reverse nums)))))
+
+
+(defun advent-11-1 (data)
+ (flet ((chars-to-string (chs)
+ (apply #'concatenate 'string (mapcar #'string chs)))
+ (nums-to-chars (nums)
+ (mapcar #'num-to-char nums))
+ (string-to-nums (str)
+ (loop :for ch :across str
+ :collect (char-to-num ch))))
+ (-> (loop :for pw = (incr-nums (string-to-nums data))
+ :then (incr-nums pw)
+ :thereis (valid pw))
+ nums-to-chars
+ chars-to-string)))
+
+
+;;;; Day 12
+(defun advent-12-data ()
+ (beef:trim-whitespace (beef:slurp "data/12")))
+
+
+(defun parse-json (s)
+ (labels ((.number ()
+ (.let* ((negation (.optional (.char= #\-)))
+ (digits (.first (.one-or-more (.is 'digit-char-p)))))
+ (.identity (let ((i (parse-integer (concatenate 'string digits)))
+ (c (if negation -1 1)))
+ (* i c)))))
+ (.string-char ()
+ (.wrap #'list (.is-not 'member (list +quote+))))
+ (.string-guts ()
+ (.let* ((chars (.zero-or-more (.string-char))))
+ (.identity (apply #'concatenate 'string chars))))
+ (.string ()
+ (.prog2
+ (.char= +quote+)
+ (.string-guts)
+ (.char= +quote+)))
+ (.map-pair ()
+ (.let* ((key (.string))
+ (_ (.char= #\:))
+ (value (.expression)))
+ (.identity (cons key value))))
+ (.map-guts ()
+ (.or
+ (.let* ((p (.map-pair))
+ (_ (.char= #\,))
+ (remaining (.map-guts)))
+ (.identity (cons p remaining)))
+ (.wrap #'list (.map-pair))
+ (.identity '())))
+ (.map ()
+ (.prog2
+ (.char= #\{)
+ (.wrap (lambda (v) (cons :map v))
+ (.map-guts))
+ (.char= #\})))
+ (.array-guts ()
+ (.or
+ (.let* ((item (.expression))
+ (_ (.char= #\,))
+ (remaining (.array-guts)))
+ (.identity (cons item remaining)))
+ (.wrap #'list (.expression))
+ (.identity '())))
+ (.array ()
+ (.prog2
+ (.char= #\[)
+ (.wrap (lambda (v) (cons :array v))
+ (.array-guts))
+ (.char= #\])))
+ (.expression ()
+ (.or (.array)
+ (.map)
+ (.string)
+ (.number))))
+ (parse (.expression) s)))
+
+(defun walk-sum (v)
+ (cond
+ ((not v) 0)
+ ((typep v 'integer) v)
+ ((typep v 'string) 0)
+ ((eql (car v) :array) (loop :for value in (cdr v)
+ :sum (walk-sum value)))
+ ((eql (car v) :map) (loop :for (key . value) :in (cdr v)
+ :sum (walk-sum value)))
+ (:else (error (format nil "wat? ~a" v)))))
+
+(defun walk-sum-2 (v)
+ (cond
+ ((not v) 0)
+ ((typep v 'integer) v)
+ ((typep v 'string) 0)
+ ((eql (car v) :array) (loop :for value in (cdr v)
+ :sum (walk-sum-2 value)))
+ ((eql (car v) :map)
+ (if (member "red" (mapcar #'cdr (cdr v))
+ :test #'equal)
+ 0
+ (loop :for (key . value) :in (cdr v)
+ :sum (walk-sum-2 value))))
+ (:else (error (format nil "wat? ~a" v)))))
+
+
+(defun advent-12-1 (data)
+ (walk-sum (parse-json data)))
+
+(defun advent-12-2 (data)
+ (walk-sum-2 (parse-json data)))
+
+
+;;;; Day 13
+(defun advent-13-data ()
+ (beef:slurp-lines "data/13" :ignore-trailing-newline t))
+
+
+(defvar *wat* nil)
+
+(defmacro map-when (test fn val &rest args)
+ (let ((v (gensym "VALUE")))
+ `(let ((,v ,val))
+ (if ,test
+ (apply ,fn ,v ,args)
+ ,v))))
+
+(defun split-lines-13 (lines)
+ (loop :for line :in lines
+ :collect (ppcre:register-groups-bind
+ (a dir amount b)
+ ("(\\w+) would (gain|lose) (\\d+) .*? next to (\\w+)."
+ line)
+ (list a b (map-when (equal "lose" dir)
+ #'-
+ (parse-integer amount))))))
+
+(defun rate-seating (vals arrangement)
+ (labels ((find-val (a b)
+ (or (gethash (cons a b) vals) 0))
+ (rate-one-direction (arr)
+ (+ (loop-window arr 2 (a b) :sum (find-val a b))
+ (find-val (car (last arr)) (car arr)))))
+ (+ (rate-one-direction arrangement)
+ (rate-one-direction (reverse arrangement)))))
+
+(defun advent-13-1 (data)
+ (let* ((tups (split-lines-13 data))
+ (attendees (remove-duplicates (mapcar #'car tups) :test #'equal))
+ (vals (make-hash-table :test #'equal)))
+ (loop :for (a b val) :in tups
+ :do (setf (gethash (cons a b) vals) val))
+ (loop :for arrangement :in (permutations attendees)
+ :maximize (rate-seating vals arrangement))))
+
+(defun advent-13-2 (data)
+ (let* ((tups (split-lines-13 data))
+ (attendees (cons "Self" (remove-duplicates (mapcar #'car tups) :test #'equal)))
+ (vals (make-hash-table :test #'equal)))
+ (loop :for (a b val) :in tups
+ :do (setf (gethash (cons a b) vals) val))
+ (loop :for arrangement :in (permutations attendees)
+ :maximize (rate-seating vals arrangement))))
+
+
+;;;; Day 14
+(defun advent-14-data ()
+ (beef:slurp-lines "data/14" :ignore-trailing-newline t))
+
+
+(defun tick (deer)
+ (destructuring-bind
+ (name speed sprint-period rest-period traveled currently remaining)
+ deer
+ (let ((remaining (1- remaining)))
+ (if (equal currently :resting)
+ (list name speed sprint-period rest-period
+ traveled
+ (if (zerop remaining) :sprinting :resting)
+ (if (zerop remaining) sprint-period remaining))
+ (list name speed sprint-period rest-period
+ (+ traveled speed)
+ (if (zerop remaining) :resting :sprinting)
+ (if (zerop remaining) rest-period remaining))))))
+
+(defun parse-deers (lines)
+ (loop :for line :in lines
+ :collect (ppcre:register-groups-bind
+ (name speed sprint-period rest-period)
+ ("(\\w+) can fly (\\d+) km/s for (\\d+) .* (\\d+) seconds."
+ line)
+ (list name
+ (parse-integer speed)
+ (parse-integer sprint-period)
+ (parse-integer rest-period)
+ 0
+ :sprinting
+ (parse-integer sprint-period)))))
+
+(defun find-leaders (deers)
+ (let ((dist (reduce #'max deers :key (beef:partial #'nth 4))))
+ (remove-if-not (lambda (deer)
+ (= dist (nth 4 deer)))
+ deers)))
+
+
+(defun advent-14-1 (data n)
+ (apply #'max
+ (loop :for i :upto n
+ :for deers := (parse-deers data) :then (mapcar #'tick deers)
+ :finally (return (mapcar (beef:partial #'nth 4) deers)))))
+
+(defun advent-14-2 (data n)
+ (let ((scores (make-hash-table :test #'equal))
+ (deers (parse-deers data)))
+ (loop :for (name) :in deers
+ :do (setf (gethash name scores) 0))
+ (loop :for i :upto n
+ :do (setf deers (mapcar #'tick deers))
+ :do (loop :for (name) :in (find-leaders deers)
+ :do (incf (gethash name scores))))
+ (apply #'max (beef:hash-values scores))))
+
+
+
+;;;; Day 15
+(defun advent-15-data ()
+ (beef:slurp-lines "data/15" :ignore-trailing-newline t))
+
+(defun split-ingredients (line)
+ (ppcre:register-groups-bind
+ (name (#'parse-integer capacity durability flavor texture calories))
+ ("(\\w+): capacity (-?\\d+), durability (-?\\d+), flavor (-?\\d+), texture (-?\\d+), calories (-?\\d+)"
+ line)
+ (list name capacity durability flavor texture calories)))
+
+(defun calc-contribution (ingr amount)
+ (cons (car ingr)
+ (mapcar (beef:partial #'* amount)
+ (cdr ingr))))
+
+(defun calc-contributions (ingrs alist)
+ (mapcar #'calc-contribution ingrs alist))
+
+(defun sum-totals (ingrs)
+ (->> ingrs
+ (mapcar #'cdr)
+ (apply #'mapcar #'+)
+ (mapcar (lambda (x) (if (< x 0) 0 x)))))
+
+(defun advent-15-1 (data)
+ (let ((ingredients (mapcar #'split-ingredients data))
+ (limit 100)
+ (amounts (list)))
+ ; fuckin lol
+ (loop :for a :upto limit :do
+ (loop :for b :upto (- limit a) :do
+ (loop :for c :upto (- limit a b) :do
+ (setf amounts
+ (cons (list a b c (- limit a b c))
+ amounts)))))
+ (loop :for alist :in amounts
+ :maximize (->> alist
+ (calc-contributions ingredients)
+ sum-totals
+ butlast
+ (apply #'*)))))
+
+(defun advent-15-2 (data)
+ (let ((ingredients (mapcar #'split-ingredients data))
+ (limit 100)
+ (amounts (list)))
+ ; fuckin lol
+ (loop :for a :upto limit :do
+ (loop :for b :upto (- limit a) :do
+ (loop :for c :upto (- limit a b) :do
+ (setf amounts
+ (cons (list a b c (- limit a b c))
+ amounts)))))
+ (loop :for alist :in amounts
+ :for val = (->> alist
+ (calc-contributions ingredients)
+ sum-totals)
+ :when (= (car (last val)) 500)
+ :maximize (apply #'* (butlast val)))))
+
+
+;;;; Scratch
+#+comment
+(advent-15-2 (advent-15-data))
--- a/src/main.lisp Sat Dec 02 12:49:22 2017 -0500
+++ b/src/main.lisp Sun Dec 03 18:39:45 2017 -0500
@@ -51,3 +51,30 @@
(somelist #'head-valid-p line)))
(summation (remove nil (read-file-of-lines-of-numbers "data/2017/02"))
:key #'checksum)))
+
+
+(defun day-3-part-1 ()
+ (labels ((manhattan-distance (a b)
+ (+ (abs (- (realpart a)
+ (realpart b)))
+ (abs (- (imagpart a)
+ (imagpart b)))))
+ (distance-to-origin (p)
+ (manhattan-distance #c(0 0) p)))
+ (distance-to-origin (advent.spiral:number-coordinates 325489))))
+
+(defun day-3-part-2 ()
+ (flet ((neighbors (coord)
+ (iterate (for-nested ((dx :from -1 :to 1)
+ (dy :from -1 :to 1)))
+ (unless (= 0 dx dy)
+ (collect (+ coord (complex dx dy)))))))
+ (iterate
+ (with memory = (make-hash-table))
+ (initially (setf (gethash #c(0 0) memory) 1))
+ (for n :from 2)
+ (for coord = (advent.spiral:number-coordinates n))
+ (for value = (summation (neighbors coord) :key (rcurry #'gethash memory 0)))
+ (finding value :such-that (> value 325489))
+ (setf (gethash coord memory) value))))
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/number-spiral.lisp Sun Dec 03 18:39:45 2017 -0500
@@ -0,0 +1,86 @@
+(in-package :advent.spiral)
+
+(defun layer-side-length (layer)
+ "Return the length of one side of `layer`."
+ (1+ (* 2 layer)))
+
+(defun layer-size (layer)
+ "Return the total size of a number spiral with a final layer of `layer`."
+ (square (layer-side-length layer)))
+
+(defun layer-for-number (number)
+ "Return the index of the layer containing `number`."
+ (ceiling (/ (1- (sqrt number)) 2)))
+
+(defun layer-start (layer)
+ "Return the smallest number in `layer`."
+ (if (zerop layer)
+ 1
+ (1+ (layer-size (1- layer)))))
+
+(defun layer-leg-length (layer)
+ "Return the length of one \"leg\" of `layer`."
+ (1- (layer-side-length layer)))
+
+
+(defun leg (layer number)
+ "Return the leg index and offset of `number` in `layer`."
+ (if (= 1 number)
+ (values 0 0)
+ (let ((idx (- number (layer-start layer)))
+ (legsize (layer-leg-length layer)))
+ (values (floor idx legsize)
+ (1+ (mod idx legsize))))))
+
+(defun corner-coordinates (layer leg)
+ "Return the coordinates of the corner starting `leg` in `layer`.
+
+ Leg | Corner
+ 0 | Bottom Right
+ 1 | Top Right
+ 2 | Top Left
+ 3 | Bottom Left
+
+ "
+
+ ;; 2 1
+ ;;
+ ;; 3 0
+ (ccase leg
+ (0 (complex layer (- layer)))
+ (1 (complex layer layer))
+ (2 (complex (- layer) layer))
+ (3 (complex (- layer) (- layer)))))
+
+(defun leg-direction (leg)
+ "Return the direction vector for the given `leg`.
+ "
+ ;; <--
+ ;; 11110
+ ;; | 2 0 ^
+ ;; | 2 0 |
+ ;; v 2 0 |
+ ;; 23333
+ ;; -->
+ (ccase leg
+ (0 (complex 0 1))
+ (1 (complex -1 0))
+ (2 (complex 0 -1))
+ (3 (complex 1 0))))
+
+
+(defun number-coordinates (number)
+ (nest
+ ;; Find the layer the number falls in.
+ (let ((layer (layer-for-number number))))
+
+ ;; Find which leg of that layer it's in, and how far along the leg it is.
+ (multiple-value-bind (leg offset) (leg layer number))
+
+ ;; Find the coordinates of the leg's corner, and its direction vector.
+ (let ((corner (corner-coordinates layer leg))
+ (direction (leg-direction leg))))
+
+ ;; Start at the corner and add the offset in the leg's direction to find the
+ ;; number's coordinates.
+ (+ corner (* direction offset))))
--- a/vendor/make-quickutils.lisp Sat Dec 02 12:49:22 2017 -0500
+++ b/vendor/make-quickutils.lisp Sun Dec 03 18:39:45 2017 -0500
@@ -6,6 +6,8 @@
:curry
:rcurry
+ :range
+ :compose
:read-file-into-string
)
--- a/vendor/quickutils.lisp Sat Dec 02 12:49:22 2017 -0500
+++ b/vendor/quickutils.lisp Sun Dec 03 18:39:45 2017 -0500
@@ -2,7 +2,7 @@
;;;; See http://quickutil.org for details.
;;;; To regenerate:
-;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:CURRY :RCURRY :READ-FILE-INTO-STRING) :ensure-package T :package "ADVENT.QUICKUTILS")
+;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:CURRY :RCURRY :RANGE :COMPOSE :READ-FILE-INTO-STRING) :ensure-package T :package "ADVENT.QUICKUTILS")
(eval-when (:compile-toplevel :load-toplevel :execute)
(unless (find-package "ADVENT.QUICKUTILS")
@@ -14,8 +14,9 @@
(when (boundp '*utilities*)
(setf *utilities* (union *utilities* '(:MAKE-GENSYM-LIST :ENSURE-FUNCTION
- :CURRY :RCURRY :ONCE-ONLY
- :WITH-OPEN-FILE* :WITH-INPUT-FROM-FILE
+ :CURRY :RCURRY :RANGE :COMPOSE
+ :ONCE-ONLY :WITH-OPEN-FILE*
+ :WITH-INPUT-FROM-FILE
:READ-FILE-INTO-STRING))))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun make-gensym-list (length &optional (x "G"))
@@ -71,6 +72,43 @@
(multiple-value-call fn (values-list more) (values-list arguments)))))
+ (defun range (start end &key (step 1) (key 'identity))
+ "Return the list of numbers `n` such that `start <= n < end` and
+`n = start + k*step` for suitable integers `k`. If a function `key` is
+provided, then apply it to each number."
+ (assert (<= start end))
+ (loop :for i :from start :below end :by step :collecting (funcall key i)))
+
+
+ (defun compose (function &rest more-functions)
+ "Returns a function composed of `function` and `more-functions` that applies its ;
+arguments to to each in turn, starting from the rightmost of `more-functions`,
+and then calling the next one with the primary value of the last."
+ (declare (optimize (speed 3) (safety 1) (debug 1)))
+ (reduce (lambda (f g)
+ (let ((f (ensure-function f))
+ (g (ensure-function g)))
+ (lambda (&rest arguments)
+ (declare (dynamic-extent arguments))
+ (funcall f (apply g arguments)))))
+ more-functions
+ :initial-value function))
+
+ (define-compiler-macro compose (function &rest more-functions)
+ (labels ((compose-1 (funs)
+ (if (cdr funs)
+ `(funcall ,(car funs) ,(compose-1 (cdr funs)))
+ `(apply ,(car funs) arguments))))
+ (let* ((args (cons function more-functions))
+ (funs (make-gensym-list (length args) "COMPOSE")))
+ `(let ,(loop for f in funs for arg in args
+ collect `(,f (ensure-function ,arg)))
+ (declare (optimize (speed 3) (safety 1) (debug 1)))
+ (lambda (&rest arguments)
+ (declare (dynamic-extent arguments))
+ ,(compose-1 funs))))))
+
+
(defmacro once-only (specs &body forms)
"Evaluates `forms` with symbols specified in `specs` rebound to temporary
variables, ensuring that each initform is evaluated only once.
@@ -162,6 +200,6 @@
:while (= bytes-read buffer-size)))))))
(eval-when (:compile-toplevel :load-toplevel :execute)
- (export '(curry rcurry read-file-into-string)))
+ (export '(curry rcurry range compose read-file-into-string)))
;;;; END OF quickutils.lisp ;;;;