--- a/src/2018/main.lisp Sun Dec 09 22:15:26 2018 -0500
+++ b/src/2018/main.lisp Mon Dec 10 00:51:46 2018 -0500
@@ -265,45 +265,26 @@
(node-value root)))))
-(defstruct dcons data prev next)
-
(define-problem (2018 9) (data read-file-into-string)
(ppcre:register-groups-bind
((#'parse-integer players marbles))
(#?/(\d+) players\D*(\d+) points/ data)
(labels
- ((kill (dcons)
- (let ((p (dcons-prev dcons))
- (n (dcons-next dcons)))
- (when p (setf (dcons-next p) n))
- (when n (setf (dcons-prev n) p))))
- (insert-after (dcons data)
- (let* ((n (dcons-next dcons))
- (new (make-dcons :data data :prev dcons :next n)))
- (setf (dcons-next dcons) new)
- (when n (setf (dcons-prev n) new))
- new))
- (play (players marbles)
- (let ((circle (make-dcons :data 0))
+ ((play (players marbles)
+ (let ((circle (ring 0))
(elves (make-array players :initial-element 0)))
- (setf (dcons-prev circle) circle
- (dcons-next circle) circle) ; splice into a circular dll
- (flet ((clockwise (n)
- (do-repeat n (callf circle #'dcons-next)))
- (counterclockwise (n)
- (do-repeat n (callf circle #'dcons-prev))))
- (iterate
- (for elf :first 0 :then (mod (1+ elf) players))
- (for marble :from 1 :to marbles)
- (if (dividesp marble 23)
- (progn (incf (aref elves elf) marble)
- (counterclockwise 7)
- (incf (aref elves elf) (dcons-data circle))
- (setf circle (prog1 (dcons-next circle)
- (kill circle))))
- (progn (clockwise 1)
- (setf circle (insert-after circle marble)))))
- (extremum elves '>)))))
+ (iterate
+ (declare (iterate:declare-variables))
+ (for elf :first 0 :then (mod (1+ elf) players))
+ (for marble :from 1 :to marbles)
+ (if (dividesp marble 23)
+ (progn (incf (aref elves elf) marble)
+ (ring-movef circle -7)
+ (incf (aref elves elf) (ring-data circle))
+ (ring-cutf circle))
+ (progn (ring-movef circle 1)
+ (ring-insertf-after circle marble))))
+ (extremum elves '>))))
#+sbcl (sb-ext:gc :full t)
(values (play players marbles)
(play players (* marbles 100))))))
--- a/src/utils.lisp Sun Dec 09 22:15:26 2018 -0500
+++ b/src/utils.lisp Mon Dec 10 00:51:46 2018 -0500
@@ -56,6 +56,120 @@
(collect (str:words line))))
+;;;; Rings --------------------------------------------------------------------
+(declaim (inline ring-prev ring-next ring-data))
+
+(defstruct (ring (:constructor make-ring%))
+ (data)
+ (prev nil :type (or null ring))
+ (next nil :type (or null ring)))
+
+(defmethod print-object ((ring ring) stream)
+ (print-unreadable-object (ring stream :type t :identity t)
+ (format stream "~S" (ring-list ring))))
+
+
+(defun map-ring (function ring)
+ (if (null ring)
+ nil
+ (cons (funcall function (ring-data ring))
+ (loop
+ :for r = (ring-next ring) :then (ring-next r)
+ :until (eql r ring)
+ :collect (funcall function (ring-data r))))))
+
+(defmacro do-ring ((el ring) &body body)
+ (once-only (ring)
+ (with-gensyms (r started)
+ `(if (null ,ring)
+ nil
+ (do* ((,r ,ring (ring-next ,r))
+ (,started nil t))
+ ((and ,started (eql ,ring ,r)) (values))
+ (let ((,el (ring-data ring)))
+ ,@body))))))
+
+
+(defun ring-list (ring)
+ (map-ring #'identity ring))
+
+
+(defun ring-length (ring)
+ (let ((result 0))
+ (do-ring (el ring)
+ (declare (ignore el))
+ (incf result))
+ result))
+
+
+(defun ring-move (ring n)
+ (check-type n fixnum)
+ (if (minusp n)
+ (loop :repeat (- n) :do (setf ring (ring-prev ring)))
+ (loop :repeat n :do (setf ring (ring-next ring))))
+ ring)
+
+
+(defun ring-insert-after (ring element)
+ (if (null ring)
+ (ring element)
+ (let* ((p ring)
+ (n (ring-next ring))
+ (new (make-ring% :data element :prev p :next n)))
+ (setf (ring-next p) new
+ (ring-prev n) new)
+ new)))
+
+(defun ring-insert-before (ring element)
+ (if (null ring)
+ (ring element)
+ (let* ((p (ring-prev ring))
+ (n ring)
+ (new (make-ring% :data element :prev p :next n)))
+ (setf (ring-next p) new
+ (ring-prev n) new)
+ new)))
+
+
+(defun ring-cut (ring &key prev)
+ (assert (not (null ring)) (ring) "Cannot cut from empty ring ~S" ring)
+ (let ((n (ring-next ring)))
+ (if (eql ring n)
+ nil
+ (let ((p (ring-prev ring)))
+ (setf (ring-next p) n
+ (ring-prev n) p
+ (ring-next ring) nil
+ (ring-prev ring) nil)
+ (if prev p n)))))
+
+
+(define-modify-macro ring-cutf (&rest keywords) ring-cut)
+(define-modify-macro ring-movef (n) ring-move)
+(define-modify-macro ring-nextf () ring-next)
+(define-modify-macro ring-prevf () ring-prev)
+(define-modify-macro ring-insertf-after (element) ring-insert-after)
+(define-modify-macro ring-insertf-before (element) ring-insert-before)
+
+
+(defun ring (&rest elements)
+ (if (null elements)
+ nil
+ (iterate
+ (with start)
+ (for element :in elements)
+ (for prev = ring)
+ (for ring = (if-first-time
+ (setf start (make-ring% :data element))
+ (make-ring% :data element :prev prev)))
+ (when prev
+ (setf (ring-next prev) ring
+ (ring-prev ring) prev))
+ (finally (setf (ring-next ring) start
+ (ring-prev start) ring)
+ (return start)))))
+
+
;;;; Miscellaneous ------------------------------------------------------------
(defun hash-table= (h1 h2 &optional (test #'eql))
"Return whether `h1` and `h2` have the same keys and values.
--- a/vendor/make-quickutils.lisp Sun Dec 09 22:15:26 2018 -0500
+++ b/vendor/make-quickutils.lisp Mon Dec 10 00:51:46 2018 -0500
@@ -12,6 +12,8 @@
:flatten-once
:hash-table-keys
:hash-table-values
+ :with-gensyms
+ :once-only
:rcurry
:read-file-into-string
:symb
--- a/vendor/quickutils.lisp Sun Dec 09 22:15:26 2018 -0500
+++ b/vendor/quickutils.lisp Mon Dec 10 00:51:46 2018 -0500
@@ -2,7 +2,7 @@
;;;; See http://quickutil.org for details.
;;;; To regenerate:
-;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:COMPOSE :COPY-HASH-TABLE :CURRY :ENSURE-GETHASH :EXTREMUM :FLATTEN-ONCE :HASH-TABLE-KEYS :HASH-TABLE-VALUES :RCURRY :READ-FILE-INTO-STRING :SYMB) :ensure-package T :package "ADVENT.QUICKUTILS")
+;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:COMPOSE :COPY-HASH-TABLE :CURRY :ENSURE-GETHASH :EXTREMUM :FLATTEN-ONCE :HASH-TABLE-KEYS :HASH-TABLE-VALUES :WITH-GENSYMS :ONCE-ONLY :RCURRY :READ-FILE-INTO-STRING :SYMB) :ensure-package T :package "ADVENT.QUICKUTILS")
(eval-when (:compile-toplevel :load-toplevel :execute)
(unless (find-package "ADVENT.QUICKUTILS")
@@ -13,7 +13,15 @@
(in-package "ADVENT.QUICKUTILS")
(when (boundp '*utilities*)
- (setf *utilities* (union *utilities* '(:MAKE-GENSYM-LIST :ENSURE-FUNCTION :COMPOSE :COPY-HASH-TABLE :CURRY :ENSURE-GETHASH :EXTREMUM :FLATTEN-ONCE :MAPHASH-KEYS :HASH-TABLE-KEYS :MAPHASH-VALUES :HASH-TABLE-VALUES :RCURRY :ONCE-ONLY :WITH-OPEN-FILE* :WITH-INPUT-FROM-FILE :READ-FILE-INTO-STRING :MKSTR :SYMB))))
+ (setf *utilities* (union *utilities* '(:MAKE-GENSYM-LIST :ENSURE-FUNCTION
+ :COMPOSE :COPY-HASH-TABLE :CURRY
+ :ENSURE-GETHASH :EXTREMUM
+ :FLATTEN-ONCE :MAPHASH-KEYS
+ :HASH-TABLE-KEYS :MAPHASH-VALUES
+ :HASH-TABLE-VALUES :STRING-DESIGNATOR
+ :WITH-GENSYMS :ONCE-ONLY :RCURRY
+ :WITH-OPEN-FILE* :WITH-INPUT-FROM-FILE
+ :READ-FILE-INTO-STRING :MKSTR :SYMB))))
(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`,
@@ -209,14 +217,48 @@
values))
- (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)))))
+ (deftype string-designator ()
+ "A string designator type. A string designator is either a string, a symbol,
+or a character."
+ `(or symbol string character))
+
+
+ (defmacro with-gensyms (names &body forms)
+ "Binds each variable named by a symbol in `names` to a unique symbol around
+`forms`. Each of `names` must either be either a symbol, or of the form:
+
+ (symbol string-designator)
+
+Bare symbols appearing in `names` are equivalent to:
+
+ (symbol symbol)
+
+The string-designator is used as the argument to `gensym` when constructing the
+unique symbol the named variable will be bound to."
+ `(let ,(mapcar (lambda (name)
+ (multiple-value-bind (symbol string)
+ (etypecase name
+ (symbol
+ (values name (symbol-name name)))
+ ((cons symbol (cons string-designator null))
+ (values (first name) (string (second name)))))
+ `(,symbol (gensym ,string))))
+ names)
+ ,@forms))
+
+ (defmacro with-unique-names (names &body forms)
+ "Binds each variable named by a symbol in `names` to a unique symbol around
+`forms`. Each of `names` must either be either a symbol, or of the form:
+
+ (symbol string-designator)
+
+Bare symbols appearing in `names` are equivalent to:
+
+ (symbol symbol)
+
+The string-designator is used as the argument to `gensym` when constructing the
+unique symbol the named variable will be bound to."
+ `(with-gensyms ,names ,@forms))
(defmacro once-only (specs &body forms)
@@ -258,6 +300,16 @@
,@forms)))))
+ (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 with-open-file* ((stream filespec &key direction element-type
if-exists if-does-not-exist external-format)
&body body)
@@ -327,6 +379,8 @@
(values (intern (apply #'mkstr args))))
(eval-when (:compile-toplevel :load-toplevel :execute)
- (export '(compose copy-hash-table curry ensure-gethash extremum flatten-once hash-table-keys hash-table-values rcurry read-file-into-string symb)))
+ (export '(compose copy-hash-table curry ensure-gethash extremum flatten-once
+ hash-table-keys hash-table-values with-gensyms with-unique-names
+ once-only rcurry read-file-into-string symb)))
;;;; END OF quickutils.lisp ;;;;