# HG changeset patch # User Steve Losh # Date 1487767299 0 # Node ID d7c65f771582fff09b0b120f9d22deb083bb17e8 # Parent 0d2671fa1875ae81a377d1c65a74cde33eb7f912 Problem 24 diff -r 0d2671fa1875 -r d7c65f771582 src/euler.lisp --- a/src/euler.lisp Tue Feb 21 21:08:17 2017 +0000 +++ b/src/euler.lisp Wed Feb 22 12:41:39 2017 +0000 @@ -643,6 +643,23 @@ (return t))))) (sum (remove-if #'abundant-sum-p (range 1 (1+ limit))))))) +(defun problem-24 () + ;; A permutation is an ordered arrangement of objects. For example, 3124 is + ;; one possible permutation of the digits 1, 2, 3 and 4. If all of the + ;; permutations are listed numerically or alphabetically, we call it + ;; lexicographic order. The lexicographic permutations of 0, 1 and 2 are: + ;; + ;; 012 021 102 120 201 210 + ;; + ;; What is the millionth lexicographic permutation of the digits 0, 1, 2, 3, + ;; 4, 5, 6, 7, 8 and 9? + (-<> "0123456789" + (gathering-vector (:size (factorial (length <>))) + (map-permutations #'gather <>)) + (map-into <> #'parse-integer <>) + (sort <> #'<) + (elt <> (1- 1000000)))) + ;;;; Tests -------------------------------------------------------------------- (def-suite :euler) @@ -671,6 +688,7 @@ (test p21 (is (= 31626 (problem-21)))) (test p22 (is (= 871198282 (problem-22)))) (test p23 (is (= 4179871 (problem-23)))) +(test p24 (is (= 2783915460 (problem-24)))) ;; (run! :euler) diff -r 0d2671fa1875 -r d7c65f771582 vendor/make-quickutils.lisp --- a/vendor/make-quickutils.lisp Tue Feb 21 21:08:17 2017 +0000 +++ b/vendor/make-quickutils.lisp Wed Feb 22 12:41:39 2017 +0000 @@ -4,13 +4,15 @@ "quickutils.lisp" :utilities '( + :compose :curry :define-constant :ensure-boolean - :read-file-into-string + :map-permutations :n-grams :range :rcurry + :read-file-into-string :switch :with-gensyms diff -r 0d2671fa1875 -r d7c65f771582 vendor/quickutils.lisp --- a/vendor/quickutils.lisp Tue Feb 21 21:08:17 2017 +0000 +++ b/vendor/quickutils.lisp Wed Feb 22 12:41:39 2017 +0000 @@ -2,7 +2,7 @@ ;;;; See http://quickutil.org for details. ;;;; To regenerate: -;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:CURRY :DEFINE-CONSTANT :ENSURE-BOOLEAN :READ-FILE-INTO-STRING :N-GRAMS :RANGE :RCURRY :SWITCH :WITH-GENSYMS) :ensure-package T :package "EULER.QUICKUTILS") +;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:COMPOSE :CURRY :DEFINE-CONSTANT :ENSURE-BOOLEAN :MAP-PERMUTATIONS :N-GRAMS :RANGE :RCURRY :READ-FILE-INTO-STRING :SWITCH :WITH-GENSYMS) :ensure-package T :package "EULER.QUICKUTILS") (eval-when (:compile-toplevel :load-toplevel :execute) (unless (find-package "EULER.QUICKUTILS") @@ -14,13 +14,14 @@ (when (boundp '*utilities*) (setf *utilities* (union *utilities* '(:MAKE-GENSYM-LIST :ENSURE-FUNCTION - :CURRY :DEFINE-CONSTANT - :ENSURE-BOOLEAN :ONCE-ONLY + :COMPOSE :CURRY :DEFINE-CONSTANT + :ENSURE-BOOLEAN :MAP-COMBINATIONS + :MAP-PERMUTATIONS :TAKE :N-GRAMS + :RANGE :RCURRY :ONCE-ONLY :WITH-OPEN-FILE* :WITH-INPUT-FROM-FILE - :READ-FILE-INTO-STRING :TAKE :N-GRAMS - :RANGE :RCURRY :STRING-DESIGNATOR - :WITH-GENSYMS :EXTRACT-FUNCTION-NAME - :SWITCH)))) + :READ-FILE-INTO-STRING + :STRING-DESIGNATOR :WITH-GENSYMS + :EXTRACT-FUNCTION-NAME :SWITCH)))) (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`, @@ -45,6 +46,35 @@ (fdefinition function-designator))) ) ; eval-when + (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)))))) + + (defun curry (function &rest arguments) "Returns a function that applies `arguments` and the arguments it is called with to `function`." @@ -107,6 +137,138 @@ (and x t)) + (defun map-combinations (function sequence &key (start 0) end length (copy t)) + "Calls `function` with each combination of `length` constructable from the +elements of the subsequence of `sequence` delimited by `start` and `end`. `start` +defaults to `0`, `end` to length of `sequence`, and `length` to the length of the +delimited subsequence. (So unless `length` is specified there is only a single +combination, which has the same elements as the delimited subsequence.) If +`copy` is true (the default) each combination is freshly allocated. If `copy` is +false all combinations are `eq` to each other, in which case consequences are +specified if a combination is modified by `function`." + (let* ((end (or end (length sequence))) + (size (- end start)) + (length (or length size)) + (combination (subseq sequence 0 length)) + (function (ensure-function function))) + (if (= length size) + (funcall function combination) + (flet ((call () + (funcall function (if copy + (copy-seq combination) + combination)))) + (etypecase sequence + ;; When dealing with lists we prefer walking back and + ;; forth instead of using indexes. + (list + (labels ((combine-list (c-tail o-tail) + (if (not c-tail) + (call) + (do ((tail o-tail (cdr tail))) + ((not tail)) + (setf (car c-tail) (car tail)) + (combine-list (cdr c-tail) (cdr tail)))))) + (combine-list combination (nthcdr start sequence)))) + (vector + (labels ((combine (count start) + (if (zerop count) + (call) + (loop for i from start below end + do (let ((j (- count 1))) + (setf (aref combination j) (aref sequence i)) + (combine j (+ i 1))))))) + (combine length start))) + (sequence + (labels ((combine (count start) + (if (zerop count) + (call) + (loop for i from start below end + do (let ((j (- count 1))) + (setf (elt combination j) (elt sequence i)) + (combine j (+ i 1))))))) + (combine length start))))))) + sequence) + + + (defun map-permutations (function sequence &key (start 0) end length (copy t)) + "Calls function with each permutation of `length` constructable +from the subsequence of `sequence` delimited by `start` and `end`. `start` +defaults to `0`, `end` to length of the sequence, and `length` to the +length of the delimited subsequence." + (let* ((end (or end (length sequence))) + (size (- end start)) + (length (or length size))) + (labels ((permute (seq n) + (let ((n-1 (- n 1))) + (if (zerop n-1) + (funcall function (if copy + (copy-seq seq) + seq)) + (loop for i from 0 upto n-1 + do (permute seq n-1) + (if (evenp n-1) + (rotatef (elt seq 0) (elt seq n-1)) + (rotatef (elt seq i) (elt seq n-1))))))) + (permute-sequence (seq) + (permute seq length))) + (if (= length size) + ;; Things are simple if we need to just permute the + ;; full START-END range. + (permute-sequence (subseq sequence start end)) + ;; Otherwise we need to generate all the combinations + ;; of LENGTH in the START-END range, and then permute + ;; a copy of the result: can't permute the combination + ;; directly, as they share structure with each other. + (let ((permutation (subseq sequence 0 length))) + (flet ((permute-combination (combination) + (permute-sequence (replace permutation combination)))) + (declare (dynamic-extent #'permute-combination)) + (map-combinations #'permute-combination sequence + :start start + :end end + :length length + :copy nil))))))) + + + (defun take (n sequence) + "Take the first `n` elements from `sequence`." + (subseq sequence 0 n)) + + + (defun n-grams (n sequence) + "Find all `n`-grams of the sequence `sequence`." + (assert (and (plusp n) + (<= n (length sequence)))) + + (etypecase sequence + ;; Lists + (list (loop :repeat (1+ (- (length sequence) n)) + :for seq :on sequence + :collect (take n seq))) + + ;; General sequences + (sequence (loop :for i :to (- (length sequence) n) + :collect (subseq sequence i (+ i n)))))) + + + (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 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. @@ -198,45 +360,6 @@ :while (= bytes-read buffer-size))))))) - (defun take (n sequence) - "Take the first `n` elements from `sequence`." - (subseq sequence 0 n)) - - - (defun n-grams (n sequence) - "Find all `n`-grams of the sequence `sequence`." - (assert (and (plusp n) - (<= n (length sequence)))) - - (etypecase sequence - ;; Lists - (list (loop :repeat (1+ (- (length sequence) n)) - :for seq :on sequence - :collect (take n seq))) - - ;; General sequences - (sequence (loop :for i :to (- (length sequence) n) - :collect (subseq sequence i (+ i n)))))) - - - (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 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." @@ -331,7 +454,8 @@ (generate-switch-body whole object clauses test key '(cerror "Return NIL from CSWITCH."))) (eval-when (:compile-toplevel :load-toplevel :execute) - (export '(curry define-constant ensure-boolean read-file-into-string n-grams - range rcurry switch eswitch cswitch with-gensyms with-unique-names))) + (export '(compose curry define-constant ensure-boolean map-permutations + n-grams range rcurry read-file-into-string switch eswitch cswitch + with-gensyms with-unique-names))) ;;;; END OF quickutils.lisp ;;;;