--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/LICENSE.markdown Fri Dec 01 13:36:17 2017 -0500
@@ -0,0 +1,19 @@
+Copyright (c) 2017 Steve Losh and contributors
+
+Permission is hereby granted, free of charge, to any person obtaining a copy
+of this software and associated documentation files (the "Software"), to deal
+in the Software without restriction, including without limitation the rights
+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all
+copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+SOFTWARE.
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/Makefile Fri Dec 01 13:36:17 2017 -0500
@@ -0,0 +1,7 @@
+.PHONY: vendor
+
+# Vendor ----------------------------------------------------------------------
+vendor/quickutils.lisp: vendor/make-quickutils.lisp
+ cd vendor && sbcl --noinform --load make-quickutils.lisp --eval '(quit)'
+
+vendor: vendor/quickutils.lisp
--- a/README.markdown Fri Dec 18 16:37:55 2015 +0000
+++ b/README.markdown Fri Dec 01 13:36:17 2017 -0500
@@ -1,1 +1,3 @@
Solutions to http://adventofcode.com/ in Common Lisp (SBCL).
+
+License: MIT/X11
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/advent.asd Fri Dec 01 13:36:17 2017 -0500
@@ -0,0 +1,16 @@
+(asdf:defsystem :advent
+ :description "Advent of Code solutions"
+
+ :author "Steve Losh <steve@stevelosh.com>"
+
+ :license "MIT"
+
+ :depends-on (:iterate :losh)
+
+ :serial t
+ :components ((:module "vendor" :serial t
+ :components ((:file "quickutils-package")
+ (:file "quickutils")))
+ (:file "package")
+ (:module "src" :serial t
+ :components ((:file "main")))))
--- a/advent.lisp Fri Dec 18 16:37:55 2015 +0000
+++ /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/package.lisp Fri Dec 01 13:36:17 2017 -0500
@@ -0,0 +1,2 @@
+(defpackage :advent
+ (:use :cl :losh :iterate :advent.quickutils))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/2015.lisp Fri Dec 01 13:36:17 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))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/main.lisp Fri Dec 01 13:36:17 2017 -0500
@@ -0,0 +1,25 @@
+(in-package :advent)
+
+;;;; Utils --------------------------------------------------------------------
+(defun read-file-of-digits (path)
+ (-<> path
+ read-file-into-string
+ (map 'list #'digit-char-p <>)
+ (remove nil <>)))
+
+
+;;;; Problems -----------------------------------------------------------------
+(defun day-1-part-1 ()
+ (iterate (for (x . y) :pairs-of-list (read-file-of-digits "data/2017/01-1"))
+ (when (= x y)
+ (sum x))))
+
+(defun day-1-part-2 ()
+ (iterate
+ (with data = (coerce (read-file-of-digits "data/2017/01-1") 'vector))
+ (with length = (length data))
+ (with offset = (truncate length 2))
+ (for x :in-vector data :with-index i)
+ (for y = (aref data (mod (+ i offset) length)))
+ (when (= x y)
+ (sum x))))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/vendor/make-quickutils.lisp Fri Dec 01 13:36:17 2017 -0500
@@ -0,0 +1,12 @@
+(ql:quickload 'quickutil)
+
+(qtlc:save-utils-as
+ "quickutils.lisp"
+ :utilities '(
+
+ :curry
+ :rcurry
+ :read-file-into-string
+
+ )
+ :package "ADVENT.QUICKUTILS")
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/vendor/quickutils-package.lisp Fri Dec 01 13:36:17 2017 -0500
@@ -0,0 +1,12 @@
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (unless (find-package "ADVENT.QUICKUTILS")
+ (defpackage "ADVENT.QUICKUTILS"
+ (:documentation "Package that contains Quickutil utility functions.")
+ (:use :cl))))
+
+(in-package "ADVENT.QUICKUTILS")
+
+;; need to define this here so sbcl will shut the hell up about it being
+;; undefined when compiling quickutils.lisp. computers are trash.
+(defparameter *utilities* nil)
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/vendor/quickutils.lisp Fri Dec 01 13:36:17 2017 -0500
@@ -0,0 +1,167 @@
+;;;; This file was automatically generated by Quickutil.
+;;;; 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")
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (unless (find-package "ADVENT.QUICKUTILS")
+ (defpackage "ADVENT.QUICKUTILS"
+ (:documentation "Package that contains Quickutil utility functions.")
+ (:use #:cl))))
+
+(in-package "ADVENT.QUICKUTILS")
+
+(when (boundp '*utilities*)
+ (setf *utilities* (union *utilities* '(:MAKE-GENSYM-LIST :ENSURE-FUNCTION
+ :CURRY :RCURRY :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"))
+ "Returns a list of `length` gensyms, each generated as if with a call to `make-gensym`,
+using the second (optional, defaulting to `\"G\"`) argument."
+ (let ((g (if (typep x '(integer 0)) x (string x))))
+ (loop repeat length
+ collect (gensym g))))
+ ) ; eval-when
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ ;;; To propagate return type and allow the compiler to eliminate the IF when
+ ;;; it is known if the argument is function or not.
+ (declaim (inline ensure-function))
+
+ (declaim (ftype (function (t) (values function &optional))
+ ensure-function))
+ (defun ensure-function (function-designator)
+ "Returns the function designated by `function-designator`:
+if `function-designator` is a function, it is returned, otherwise
+it must be a function name and its `fdefinition` is returned."
+ (if (functionp function-designator)
+ function-designator
+ (fdefinition function-designator)))
+ ) ; eval-when
+
+ (defun curry (function &rest arguments)
+ "Returns a function that applies `arguments` and the arguments
+it is called with to `function`."
+ (declare (optimize (speed 3) (safety 1) (debug 1)))
+ (let ((fn (ensure-function function)))
+ (lambda (&rest more)
+ (declare (dynamic-extent more))
+ ;; Using M-V-C we don't need to append the arguments.
+ (multiple-value-call fn (values-list arguments) (values-list more)))))
+
+ (define-compiler-macro curry (function &rest arguments)
+ (let ((curries (make-gensym-list (length arguments) "CURRY"))
+ (fun (gensym "FUN")))
+ `(let ((,fun (ensure-function ,function))
+ ,@(mapcar #'list curries arguments))
+ (declare (optimize (speed 3) (safety 1) (debug 1)))
+ (lambda (&rest more)
+ (apply ,fun ,@curries more)))))
+
+
+ (defun rcurry (function &rest arguments)
+ "Returns a function that applies the arguments it is called
+with and `arguments` to `function`."
+ (declare (optimize (speed 3) (safety 1) (debug 1)))
+ (let ((fn (ensure-function function)))
+ (lambda (&rest more)
+ (declare (dynamic-extent more))
+ (multiple-value-call fn (values-list more) (values-list arguments)))))
+
+
+ (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.
+
+Each of `specs` must either be a symbol naming the variable to be rebound, or of
+the form:
+
+ (symbol initform)
+
+Bare symbols in `specs` are equivalent to
+
+ (symbol symbol)
+
+Example:
+
+ (defmacro cons1 (x) (once-only (x) `(cons ,x ,x)))
+ (let ((y 0)) (cons1 (incf y))) => (1 . 1)"
+ (let ((gensyms (make-gensym-list (length specs) "ONCE-ONLY"))
+ (names-and-forms (mapcar (lambda (spec)
+ (etypecase spec
+ (list
+ (destructuring-bind (name form) spec
+ (cons name form)))
+ (symbol
+ (cons spec spec))))
+ specs)))
+ ;; bind in user-macro
+ `(let ,(mapcar (lambda (g n) (list g `(gensym ,(string (car n)))))
+ gensyms names-and-forms)
+ ;; bind in final expansion
+ `(let (,,@(mapcar (lambda (g n)
+ ``(,,g ,,(cdr n)))
+ gensyms names-and-forms))
+ ;; bind in user-macro
+ ,(let ,(mapcar (lambda (n g) (list (car n) g))
+ names-and-forms gensyms)
+ ,@forms)))))
+
+
+ (defmacro with-open-file* ((stream filespec &key direction element-type
+ if-exists if-does-not-exist external-format)
+ &body body)
+ "Just like `with-open-file`, but `nil` values in the keyword arguments mean to use
+the default value specified for `open`."
+ (once-only (direction element-type if-exists if-does-not-exist external-format)
+ `(with-open-stream
+ (,stream (apply #'open ,filespec
+ (append
+ (when ,direction
+ (list :direction ,direction))
+ (when ,element-type
+ (list :element-type ,element-type))
+ (when ,if-exists
+ (list :if-exists ,if-exists))
+ (when ,if-does-not-exist
+ (list :if-does-not-exist ,if-does-not-exist))
+ (when ,external-format
+ (list :external-format ,external-format)))))
+ ,@body)))
+
+
+ (defmacro with-input-from-file ((stream-name file-name &rest args
+ &key (direction nil direction-p)
+ &allow-other-keys)
+ &body body)
+ "Evaluate `body` with `stream-name` to an input stream on the file
+`file-name`. `args` is sent as is to the call to `open` except `external-format`,
+which is only sent to `with-open-file` when it's not `nil`."
+ (declare (ignore direction))
+ (when direction-p
+ (error "Can't specifiy :DIRECTION for WITH-INPUT-FROM-FILE."))
+ `(with-open-file* (,stream-name ,file-name :direction :input ,@args)
+ ,@body))
+
+
+ (defun read-file-into-string (pathname &key (buffer-size 4096) external-format)
+ "Return the contents of the file denoted by `pathname` as a fresh string.
+
+The `external-format` parameter will be passed directly to `with-open-file`
+unless it's `nil`, which means the system default."
+ (with-input-from-file
+ (file-stream pathname :external-format external-format)
+ (let ((*print-pretty* nil))
+ (with-output-to-string (datum)
+ (let ((buffer (make-array buffer-size :element-type 'character)))
+ (loop
+ :for bytes-read = (read-sequence buffer file-stream)
+ :do (write-sequence buffer datum :start 0 :end bytes-read)
+ :while (= bytes-read buffer-size)))))))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (export '(curry rcurry read-file-into-string)))
+
+;;;; END OF quickutils.lisp ;;;;