# HG changeset patch # User Steve Losh # Date 1544421106 18000 # Node ID e3e015ad324ca574153f88fd0aab624a753ecc37 # Parent a331ef75f8089907d20f6b935cff195d2fa0bcd9 Implement rings diff -r a331ef75f808 -r e3e015ad324c src/2018/main.lisp --- 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)))))) diff -r a331ef75f808 -r e3e015ad324c src/utils.lisp --- 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. diff -r a331ef75f808 -r e3e015ad324c vendor/make-quickutils.lisp --- 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 diff -r a331ef75f808 -r e3e015ad324c vendor/quickutils.lisp --- 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 ;;;;