# HG changeset patch # User Steve Losh # Date 1502221854 14400 # Node ID 48e02ac6faae94861b7657bd8627388811eccc7d # Parent 0061265e6b73216af231df218bd8b9d1e4b20e81 Problem 79 diff -r 0061265e6b73 -r 48e02ac6faae data/79-keylog.txt --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/data/79-keylog.txt Tue Aug 08 15:50:54 2017 -0400 @@ -0,0 +1,50 @@ +319 +680 +180 +690 +129 +620 +762 +689 +762 +318 +368 +710 +720 +710 +629 +168 +160 +689 +716 +731 +736 +729 +316 +729 +729 +710 +769 +290 +719 +680 +318 +389 +162 +289 +162 +718 +729 +319 +790 +680 +890 +362 +319 +760 +316 +729 +380 +319 +728 +716 diff -r 0061265e6b73 -r 48e02ac6faae euler.asd --- a/euler.asd Tue Mar 14 13:36:14 2017 +0000 +++ b/euler.asd Tue Aug 08 15:50:54 2017 -0400 @@ -1,4 +1,4 @@ -(asdf:defsystem #:euler +(asdf:defsystem :euler :name "euler" :description "Project Euler solutions." @@ -26,6 +26,7 @@ (:file "package") (:module "src" :serial t :components ((:file "primes") + (:file "utils") (:file "euler") (:file "poker"))))) diff -r 0061265e6b73 -r 48e02ac6faae src/euler.lisp --- a/src/euler.lisp Tue Mar 14 13:36:14 2017 +0000 +++ b/src/euler.lisp Tue Aug 08 15:50:54 2017 -0400 @@ -1,448 +1,5 @@ (in-package :euler) -;;;; Utils -------------------------------------------------------------------- -(defmacro-driver (FOR var ITERATING function SEED value) - (let ((kwd (if generate 'generate 'for))) - (with-gensyms (f) - `(progn - (with ,f = ,function) - (,kwd ,var - :initially (funcall ,f ,value) - :then (funcall ,f ,var)))))) - -(defmacro-driver (FOR var IN-LOOPING list) - (let ((kwd (if generate 'generate 'for))) - (with-gensyms (l remaining) - `(progn - (with ,l = ,list) - (,kwd (,var . ,remaining) - :next (if-first-time - ,l - (if (null ,remaining) - ,l - ,remaining))))))) - -(defmacro-driver (FOR var KEY function &sequence) - (let ((kwd (if generate 'generate 'for))) - (with-gensyms (i f) - `(progn - (with ,f = ,function) - (generate ,i ,@(losh::expand-iterate-sequence-keywords)) - (,kwd ,var :next (funcall ,f (next ,i))))))) - - -(defmacro-driver (FOR var IN-DIGITS-OF integer &optional RADIX (radix 10)) - "Iterate `var` through the digits of `integer` in base `radix`, low-order first." - (let ((kwd (if generate 'generate 'for))) - (with-gensyms (i r remaining digit) - `(progn - (with ,r = ,radix) - (with ,i = (abs ,integer)) - (,kwd ,var :next (if (zerop ,i) - (terminate) - (multiple-value-bind (,remaining ,digit) - (truncate ,i ,r) - (setf ,i ,remaining) - ,digit))))))) - -(defun digits (n &optional (radix 10)) - "Return a fresh list of the digits of `n` in base `radix`." - (iterate (for d :in-digits-of n :radix radix) - (collect d :at :beginning))) - -(defun digits-length (n &optional (radix 10)) - "Return how many digits `n` has in base `radix`." - (if (zerop n) - 1 - (values (1+ (truncate (log (abs n) radix)))))) - - -(defun digits-to-number (digits) - (if digits - (reduce (lambda (total digit) - (+ (* total 10) digit)) - digits) - 0)) - -(defun extremely-fucking-unsafe-digits-to-number (digits) - (declare (optimize (speed 3) (safety 0))) - (if digits - (iterate - (declare (iterate:declare-variables)) - (with (the (unsigned-byte 62) result) = 0) - (for (the (integer 0 9) d) :in digits) - (setf result (the (unsigned-byte 64) (mod (* result 10) (expt 2 62))) - result (the (unsigned-byte 64) (mod (+ result d) (expt 2 62)))) - (finally (return result))) - 0)) - - -(defun palindromep (n &optional (radix 10)) - "Return whether `n` is a palindrome in base `radix`." - (let ((s (format nil "~VR" radix n))) - (string= s (reverse s)))) - - -(defun sum (sequence &key key) - (iterate (for n :in-whatever sequence) - (sum (if key - (funcall key n) - n)))) - -(defun product (sequence &key key) - (iterate (for n :in-whatever sequence) - (multiplying (if key - (funcall key n) - n)))) - - -(defun sort< (sequence) - (sort sequence #'<)) - - -(defun divisors (n) - (sort< (iterate (for i :from 1 :to (sqrt n)) - (when (dividesp n i) - (collect i) - (let ((j (/ n i))) - ;; don't collect the square root twice - (unless (= i j) - (collect j))))))) - -(defun proper-divisors (n) - (remove n (divisors n))) - -(defun count-divisors (n) - (+ (* 2 (iterate (for i :from 1 :below (sqrt n)) - (counting (dividesp n i)))) - (if (squarep n) - 1 - 0))) - - -(defmacro-driver (FOR var IN-COLLATZ n) - (let ((kwd (if generate 'generate 'for))) - `(progn - (,kwd ,var :next (cond ((null ,var) ,n) - ((= 1 ,var) (terminate)) - ((evenp ,var) (/ ,var 2)) - (t (1+ (* 3 ,var)))))))) - -(defun collatz (n) - (iterate (for i :in-collatz n) - (collect i))) - -(defun collatz-length (n) - (iterate (for i :in-collatz n) - (counting t))) - - -(defmacro-driver (FOR var IN-FIBONACCI _) - (declare (ignore _)) - (with-gensyms (a b) - (let ((kwd (if generate 'generate 'for))) - `(progn - (with ,a = 0) - (with ,b = 1) - (,kwd ,var :next (prog1 ,b - (psetf ,a ,b - ,b (+ ,a ,b)))))))) - -(defun fibonacci (n) - "Return the first `n` Fibonacci numbers as a fresh list." - (iterate (repeat n) - (for i :in-fibonacci t) - (collect i))) - - -(defun binomial-coefficient (n k) - "Return `n` choose `k`." - ;; https://en.wikipedia.org/wiki/Binomial_coefficient#Multiplicative_formula - (iterate (for i :from 1 :to k) - (multiplying (/ (+ n 1 (- i)) - i)))) - - -(defun factorial (n) - (iterate (for i :from 1 :to n) - (multiplying i))) - - -(defun perfectp (n) - (= n (sum (proper-divisors n)))) - -(defun abundantp (n) - (< n (sum (proper-divisors n)))) - -(defun deficientp (n) - (> n (sum (proper-divisors n)))) - - -(defun multiplicative-order (integer modulus) - "Return the multiplicative order of `integer` modulo `modulus`." - ;; https://en.wikipedia.org/wiki/Multiplicative_order - (iterate (for i :from 1) - (for v :first integer :then (* v integer)) - (finding i :such-that (= 1 (mod v modulus))))) - - -(defun number-spiral-corners (size) - "Return a list of the corner values of a 'number spiral' of size `size`. - - `size` must be odd. The order of the corners in the resulting list is - unspecified. - - Note that the \"spiral\" of size one has just a single \"corner\": `1`. - - " - (assert (oddp size)) - (if (= 1 size) - (list 1) - (let ((leg (1- size)) - (final (square size))) - (list (- final (* 0 leg)) - (- final (* 1 leg)) - (- final (* 2 leg)) - (- final (* 3 leg)))))) - - -(defun truncate-number-left (n amount &optional (radix 10)) - "Chop `amount` digits off the left side of `n` in base `radix`." - (mod n (expt radix (- (digits-length n radix) amount)))) - -(defun truncate-number-right (n amount &optional (radix 10)) - "Chop `amount` digits off the right side of `n` in base `radix`." - (truncate n (expt radix amount))) - - -(defun hex (n) - (format t "~X" n) - (values)) - - -(defun concatenate-integers (&rest integers) - "Concatenate each integer in `integers` and return a big ol' integer result." - (values (parse-integer - (format nil "~{~D~}" integers)))) - - -(defun pandigitalp (integer &key (start 1) (end 9)) - "Return whether `integer` is `start` to `end` (inclusive) pandigital. - - Examples: - - (pandigitalp 123) ; => nil - (pandigitalp 123 1 3) ; => t - (pandigitalp 123 0 3) ; => nil - - " - (equal (irange start end) - (sort< (digits integer)))) - -(defun pandigitals (&optional (start 1) (end 9)) - "Return a list of all `start` to `end` (inclusive) pandigital numbers." - (gathering - (map-permutations (lambda (digits) - ;; 0-to-n pandigitals are annoying because we don't want - ;; to include those with a 0 first. - (unless (zerop (first digits)) - (gather (digits-to-number digits)))) - (irange start end) - :copy nil))) - - -(defun permutations (sequence &key length) - (gathering (map-permutations #'gather sequence :length length))) - -(defun combinations (sequence &key length) - (gathering (map-combinations #'gather sequence :length length))) - - -(defun-inline digits< (n digits) - "Return whether `n` has fewer than `digits` digits." - (< (abs n) (expt 10 (1- digits)))) - -(defun-inline digits<= (n digits) - "Return whether `n` has `digits` or fewer digits." - (< (abs n) (expt 10 digits))) - - -(defun adjoin% (list item &rest keyword-args) - (apply #'adjoin item list keyword-args)) - -(define-modify-macro adjoinf (item &rest keyword-args) adjoin%) - - -(defun mv* (matrix vector) - (iterate - (with (rows cols) = (array-dimensions matrix)) - (initially (assert (= cols (length vector)))) - (with result = (make-array rows :initial-element 0)) - (for row :from 0 :below rows) - (iterate (for col :from 0 :below cols) - (for v = (aref vector col)) - (for a = (aref matrix row col)) - (incf (aref result row) - (* v a))) - (finally (return result)))) - - -(defun pythagorean-triplet-p (a b c) - (= (+ (square a) (square b)) - (square c))) - -(defun pythagorean-triplets-of-perimeter (p) - (iterate - (with result = '()) - (for c :from 1 :to (- p 2)) - (iterate - (for a :from 1 :below (min c (- p c))) - (for b = (- p c a)) - (when (pythagorean-triplet-p a b c) - (adjoinf result (sort< (list a b c)) - :test #'equal))) - (finally (return result)))) - - -(defun map-primitive-pythagorean-triplets (function stop-predicate) - ;; http://mathworld.wolfram.com/PythagoreanTriple.html - (let ((u #2A(( 1 2 2) - (-2 -1 -2) - ( 2 2 3))) - (a #2A(( 1 2 2) - ( 2 1 2) - ( 2 2 3))) - (d #2A((-1 -2 -2) - ( 2 1 2) - ( 2 2 3)))) - (recursively ((triple (vector 3 4 5))) - (unless (apply stop-predicate (coerce triple 'list)) - (apply function (coerce triple 'list)) - (recur (mv* u triple)) - (recur (mv* a triple)) - (recur (mv* d triple)))))) - - -(defun squarep (n) - "Return whether `n` is a perfect square." - (and (integerp n) - (= n (square (isqrt n))))) - - -(defun cube (n) - (* n n n)) - - -(eval-dammit - (defun build-cube-array () - ;; http://stackoverflow.com/a/32017647 - (iterate - (with arr = (make-array 819 :initial-element nil)) - (for mod in '(0 125 181 818 720 811 532 755 476 - 1 216 90 307 377 694 350 567 442 - 8 343 559 629 658 351 190 91 469 - 27 512 287 252 638 118 603 161 441 - 64 729 99 701 792 378 260 468 728)) - (setf (aref arr mod) t) - (finally (return arr))))) - -(defun slow-cubep (n) - (= n (cube (truncate (expt n 1/3))))) - -(defun cubep (n) - (and (integerp n) - (svref #.(build-cube-array) (mod n 819)) - (slow-cubep n))) - - -(defun triangle (n) - "Return the `n`th triangle number (1-indexed because mathematicians are silly)." - (* 1/2 n (1+ n))) - -(defun trianglep (n) - "Return whether `n` is a triangle number." - ;; http://mathforum.org/library/drmath/view/57162.html - ;; - ;; A number is triangular if and only if 8T + 1 is an odd perfect square. - (let ((x (1+ (* 8 n)))) - (and (oddp x) - (squarep x)))) - - -(defun pentagon (n) - (* n (- (* 3 n) 1) 1/2)) - -(defun pentagonp (n) - ;; We can ignore the - branch of the quadratic equation because negative - ;; numbers aren't indexes. - (dividesp (+ 1 (sqrt (1+ (* 24.0d0 n)))) 6)) - - -(defun hexagon (n) - (* n (1- (* 2 n)))) - -(defun hexagonp (n) - ;; We can ignore the - branch of the quadratic equation because negative - ;; numbers aren't indexes. - (dividesp (+ 1 (sqrt (1+ (* 8.0d0 n)))) 4)) - - -(defun heptagon (n) - (* n (- (* 5 n) 3) 1/2)) - -(defun octagon (n) - (* n (- (* 3 n) 2))) - - -(defun parse-strings-file (filename) - (-<> filename - read-file-into-string - (substitute #\Space #\, <>) - read-all-from-string)) - - -(defun letter-number (char) - "Return the index of `char` in the alphabet (A being 1)." - (1+ (- (char-code (char-upcase char)) (char-code #\A)))) - - -(defun set-equal (list1 list2 &rest args) - (null (apply #'set-exclusive-or list1 list2 args))) - -(defun orderless-equal (list1 list2 &key (sort-predicate #'<)) - (equal (sort (copy-seq list1) sort-predicate) - (sort (copy-seq list2) sort-predicate))) - - -(defun irange (start end &key (step 1) (key 'identity)) - "Inclusive `range`." - (range start (1+ end) :step step :key key)) - - -(defun length= (n sequence) - (= n (length sequence))) - - -(defun reverse-integer (n) - (digits-to-number (nreverse (digits n)))) - - -(defmacro labels-memoized (definitions &body body) - (let ((caches (mapcar #'gensym (range 0 (length definitions))))) - (flet ((build (cache definition) - (destructuring-bind (name lambda-list &body body) definition - `(,name ,lambda-list - (values - (ensure-gethash (list ,@lambda-list) ,cache - (progn ,@body))))))) - `(let (,@(iterate (for cache :in caches) - (collect `(,cache (make-hash-table :test #'equal))))) - (labels (,@(mapcar #'build caches definitions)) - ,@body))))) - - - -;;;; Problems ----------------------------------------------------------------- (defun problem-1 () ;; If we list all the natural numbers below 10 that are multiples of 3 or 5, ;; we get 3, 5, 6 and 9. The sum of these multiples is 23. @@ -1452,8 +1009,7 @@ ;; one we'll ever see. But it happens to accidentally be the ;; correct one, and until I get around to rewriting this with ;; priority queues it'll have to do. - (return-from problem-44 distance) - (setf result distance))) + (return-from problem-44 distance))) (return)))))) (defun problem-45 () @@ -2048,7 +1604,6 @@ (iterate (for n :from 1 :below (find-bound)) (sum (score n))))) - (defun problem-74 () ;; The number 145 is well known for the property that the sum of the factorial ;; of its digits is equal to 145: @@ -2086,6 +1641,30 @@ (iterate (for i :from 1 :below 1000000) (counting (= 60 (term-count i)))))) +(defun problem-79 () + ;; A common security method used for online banking is to ask the user for + ;; three random characters from a passcode. For example, if the passcode was + ;; 531278, they may ask for the 2nd, 3rd, and 5th characters; the expected + ;; reply would be: 317. + ;; + ;; The text file, keylog.txt, contains fifty successful login attempts. + ;; + ;; Given that the three characters are always asked for in order, analyse + ;; the file so as to determine the shortest possible secret passcode of + ;; unknown length. + (let ((attempts (-<> "data/79-keylog.txt" + read-all-from-file + (mapcar #'digits <>) + (mapcar (rcurry #'coerce 'vector) <>)))) + ;; Everyone in the forum is assuming that there are no duplicate digits in + ;; the passcode, but as someone pointed out this isn't necessarily a safe + ;; assumption. If you have attempts of (12 21) then the shortest passcode + ;; would be 121. So we'll do things the safe way and just brute force it. + (iterate (for passcode :from 1) + (finding passcode :such-that + (every (rcurry #'subsequencep (digits passcode)) + attempts))))) + (defun problem-145 () ;; Some positive integers n have the property that the sum [ n + reverse(n) ] ;; consists entirely of odd (decimal) digits. For instance, 36 + 63 = 99 and @@ -2184,6 +1763,7 @@ (test p74 (is (= 402 (problem-74)))) +(test p79 (is (= 73162890 (problem-79)))) (test p145 (is (= 608720 (problem-145)))) diff -r 0061265e6b73 -r 48e02ac6faae src/utils.lisp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/utils.lisp Tue Aug 08 15:50:54 2017 -0400 @@ -0,0 +1,461 @@ +(in-package :euler) + +(defmacro-driver (FOR var ITERATING function SEED value) + (let ((kwd (if generate 'generate 'for))) + (with-gensyms (f) + `(progn + (with ,f = ,function) + (,kwd ,var + :initially (funcall ,f ,value) + :then (funcall ,f ,var)))))) + +(defmacro-driver (FOR var IN-LOOPING list) + (let ((kwd (if generate 'generate 'for))) + (with-gensyms (l remaining) + `(progn + (with ,l = ,list) + (,kwd (,var . ,remaining) + :next (if-first-time + ,l + (if (null ,remaining) + ,l + ,remaining))))))) + +(defmacro-driver (FOR var KEY function &sequence) + (let ((kwd (if generate 'generate 'for))) + (with-gensyms (i f) + `(progn + (with ,f = ,function) + (generate ,i ,@(losh::expand-iterate-sequence-keywords)) + (,kwd ,var :next (funcall ,f (next ,i))))))) + + +(defmacro-driver (FOR var IN-DIGITS-OF integer &optional RADIX (radix 10)) + "Iterate `var` through the digits of `integer` in base `radix`, low-order first." + (let ((kwd (if generate 'generate 'for))) + (with-gensyms (i r remaining digit) + `(progn + (with ,r = ,radix) + (with ,i = (abs ,integer)) + (,kwd ,var :next (if (zerop ,i) + (terminate) + (multiple-value-bind (,remaining ,digit) + (truncate ,i ,r) + (setf ,i ,remaining) + ,digit))))))) + +(defun digits (n &optional (radix 10)) + "Return a fresh list of the digits of `n` in base `radix`." + (iterate (for d :in-digits-of n :radix radix) + (collect d :at :beginning))) + +(defun digits-vector (n &optional (radix 10)) + "Return a fresh vector of the digits of `n` in base `radix`." + (iterate (for d :in-digits-of n :radix radix) + (collect d :at :beginning :result-type 'vector))) + +(defun digits-length (n &optional (radix 10)) + "Return how many digits `n` has in base `radix`." + (if (zerop n) + 1 + (values (1+ (truncate (log (abs n) radix)))))) + + +(defun digits-to-number (digits) + (if digits + (reduce (lambda (total digit) + (+ (* total 10) digit)) + digits) + 0)) + +(defun extremely-fucking-unsafe-digits-to-number (digits) + (declare (optimize (speed 3) (safety 0))) + (if digits + (iterate + (declare (iterate:declare-variables)) + (with (the (unsigned-byte 62) result) = 0) + (for (the (integer 0 9) d) :in digits) + (setf result (the (unsigned-byte 64) (mod (* result 10) (expt 2 62))) + result (the (unsigned-byte 64) (mod (+ result d) (expt 2 62)))) + (finally (return result))) + 0)) + + +(defun palindromep (n &optional (radix 10)) + "Return whether `n` is a palindrome in base `radix`." + (let ((s (format nil "~VR" radix n))) + (string= s (reverse s)))) + + +(defun sum (sequence &key key) + (iterate (for n :in-whatever sequence) + (sum (if key + (funcall key n) + n)))) + +(defun product (sequence &key key) + (iterate (for n :in-whatever sequence) + (multiplying (if key + (funcall key n) + n)))) + + +(defun sort< (sequence) + (sort sequence #'<)) + + +(defun divisors (n) + (sort< (iterate (for i :from 1 :to (sqrt n)) + (when (dividesp n i) + (collect i) + (let ((j (/ n i))) + ;; don't collect the square root twice + (unless (= i j) + (collect j))))))) + +(defun proper-divisors (n) + (remove n (divisors n))) + +(defun count-divisors (n) + (+ (* 2 (iterate (for i :from 1 :below (sqrt n)) + (counting (dividesp n i)))) + (if (squarep n) + 1 + 0))) + + +(defmacro-driver (FOR var IN-COLLATZ n) + (let ((kwd (if generate 'generate 'for))) + `(progn + (,kwd ,var :next (cond ((null ,var) ,n) + ((= 1 ,var) (terminate)) + ((evenp ,var) (/ ,var 2)) + (t (1+ (* 3 ,var)))))))) + +(defun collatz (n) + (iterate (for i :in-collatz n) + (collect i))) + +(defun collatz-length (n) + (iterate (for i :in-collatz n) + (counting t))) + + +(defmacro-driver (FOR var IN-FIBONACCI _) + (declare (ignore _)) + (with-gensyms (a b) + (let ((kwd (if generate 'generate 'for))) + `(progn + (with ,a = 0) + (with ,b = 1) + (,kwd ,var :next (prog1 ,b + (psetf ,a ,b + ,b (+ ,a ,b)))))))) + +(defun fibonacci (n) + "Return the first `n` Fibonacci numbers as a fresh list." + (iterate (repeat n) + (for i :in-fibonacci t) + (collect i))) + + +(defun binomial-coefficient (n k) + "Return `n` choose `k`." + ;; https://en.wikipedia.org/wiki/Binomial_coefficient#Multiplicative_formula + (iterate (for i :from 1 :to k) + (multiplying (/ (+ n 1 (- i)) + i)))) + + +(defun factorial (n) + (iterate (for i :from 1 :to n) + (multiplying i))) + + +(defun perfectp (n) + (= n (sum (proper-divisors n)))) + +(defun abundantp (n) + (< n (sum (proper-divisors n)))) + +(defun deficientp (n) + (> n (sum (proper-divisors n)))) + + +(defun multiplicative-order (integer modulus) + "Return the multiplicative order of `integer` modulo `modulus`." + ;; https://en.wikipedia.org/wiki/Multiplicative_order + (iterate (for i :from 1) + (for v :first integer :then (* v integer)) + (finding i :such-that (= 1 (mod v modulus))))) + + +(defun number-spiral-corners (size) + "Return a list of the corner values of a 'number spiral' of size `size`. + + `size` must be odd. The order of the corners in the resulting list is + unspecified. + + Note that the \"spiral\" of size one has just a single \"corner\": `1`. + + " + (assert (oddp size)) + (if (= 1 size) + (list 1) + (let ((leg (1- size)) + (final (square size))) + (list (- final (* 0 leg)) + (- final (* 1 leg)) + (- final (* 2 leg)) + (- final (* 3 leg)))))) + + +(defun truncate-number-left (n amount &optional (radix 10)) + "Chop `amount` digits off the left side of `n` in base `radix`." + (mod n (expt radix (- (digits-length n radix) amount)))) + +(defun truncate-number-right (n amount &optional (radix 10)) + "Chop `amount` digits off the right side of `n` in base `radix`." + (truncate n (expt radix amount))) + + +(defun hex (n) + (format t "~X" n) + (values)) + + +(defun concatenate-integers (&rest integers) + "Concatenate each integer in `integers` and return a big ol' integer result." + (values (parse-integer + (format nil "~{~D~}" integers)))) + + +(defun pandigitalp (integer &key (start 1) (end 9)) + "Return whether `integer` is `start` to `end` (inclusive) pandigital. + + Examples: + + (pandigitalp 123) ; => nil + (pandigitalp 123 1 3) ; => t + (pandigitalp 123 0 3) ; => nil + + " + (equal (irange start end) + (sort< (digits integer)))) + +(defun pandigitals (&optional (start 1) (end 9)) + "Return a list of all `start` to `end` (inclusive) pandigital numbers." + (gathering + (map-permutations (lambda (digits) + ;; 0-to-n pandigitals are annoying because we don't want + ;; to include those with a 0 first. + (unless (zerop (first digits)) + (gather (digits-to-number digits)))) + (irange start end) + :copy nil))) + + +(defun permutations (sequence &key length) + (gathering (map-permutations #'gather sequence :length length))) + +(defun combinations (sequence &key length) + (gathering (map-combinations #'gather sequence :length length))) + + +(defun-inline digits< (n digits) + "Return whether `n` has fewer than `digits` digits." + (< (abs n) (expt 10 (1- digits)))) + +(defun-inline digits<= (n digits) + "Return whether `n` has `digits` or fewer digits." + (< (abs n) (expt 10 digits))) + + +(defun adjoin% (list item &rest keyword-args) + (apply #'adjoin item list keyword-args)) + +(define-modify-macro adjoinf (item &rest keyword-args) adjoin%) + + +(defun mv* (matrix vector) + (iterate + (with (rows cols) = (array-dimensions matrix)) + (initially (assert (= cols (length vector)))) + (with result = (make-array rows :initial-element 0)) + (for row :from 0 :below rows) + (iterate (for col :from 0 :below cols) + (for v = (aref vector col)) + (for a = (aref matrix row col)) + (incf (aref result row) + (* v a))) + (finally (return result)))) + + +(defun pythagorean-triplet-p (a b c) + (= (+ (square a) (square b)) + (square c))) + +(defun pythagorean-triplets-of-perimeter (p) + (iterate + (with result = '()) + (for c :from 1 :to (- p 2)) + (iterate + (for a :from 1 :below (min c (- p c))) + (for b = (- p c a)) + (when (pythagorean-triplet-p a b c) + (adjoinf result (sort< (list a b c)) + :test #'equal))) + (finally (return result)))) + + +(defun map-primitive-pythagorean-triplets (function stop-predicate) + ;; http://mathworld.wolfram.com/PythagoreanTriple.html + (let ((u #2A(( 1 2 2) + (-2 -1 -2) + ( 2 2 3))) + (a #2A(( 1 2 2) + ( 2 1 2) + ( 2 2 3))) + (d #2A((-1 -2 -2) + ( 2 1 2) + ( 2 2 3)))) + (recursively ((triple (vector 3 4 5))) + (unless (apply stop-predicate (coerce triple 'list)) + (apply function (coerce triple 'list)) + (recur (mv* u triple)) + (recur (mv* a triple)) + (recur (mv* d triple)))))) + + +(defun squarep (n) + "Return whether `n` is a perfect square." + (and (integerp n) + (= n (square (isqrt n))))) + + +(defun cube (n) + (* n n n)) + + +(eval-dammit + (defun build-cube-array () + ;; http://stackoverflow.com/a/32017647 + (iterate + (with arr = (make-array 819 :initial-element nil)) + (for mod in '(0 125 181 818 720 811 532 755 476 + 1 216 90 307 377 694 350 567 442 + 8 343 559 629 658 351 190 91 469 + 27 512 287 252 638 118 603 161 441 + 64 729 99 701 792 378 260 468 728)) + (setf (aref arr mod) t) + (finally (return arr))))) + +(defun slow-cubep (n) + (= n (cube (truncate (expt n 1/3))))) + +(defun cubep (n) + (and (integerp n) + (svref #.(build-cube-array) (mod n 819)) + (slow-cubep n))) + + +(defun triangle (n) + "Return the `n`th triangle number (1-indexed because mathematicians are silly)." + (* 1/2 n (1+ n))) + +(defun trianglep (n) + "Return whether `n` is a triangle number." + ;; http://mathforum.org/library/drmath/view/57162.html + ;; + ;; A number is triangular if and only if 8T + 1 is an odd perfect square. + (let ((x (1+ (* 8 n)))) + (and (oddp x) + (squarep x)))) + + +(defun pentagon (n) + (* n (- (* 3 n) 1) 1/2)) + +(defun pentagonp (n) + ;; We can ignore the - branch of the quadratic equation because negative + ;; numbers aren't indexes. + (dividesp (+ 1 (sqrt (1+ (* 24.0d0 n)))) 6)) + + +(defun hexagon (n) + (* n (1- (* 2 n)))) + +(defun hexagonp (n) + ;; We can ignore the - branch of the quadratic equation because negative + ;; numbers aren't indexes. + (dividesp (+ 1 (sqrt (1+ (* 8.0d0 n)))) 4)) + + +(defun heptagon (n) + (* n (- (* 5 n) 3) 1/2)) + +(defun octagon (n) + (* n (- (* 3 n) 2))) + + +(defun parse-strings-file (filename) + (-<> filename + read-file-into-string + (substitute #\Space #\, <>) + read-all-from-string)) + + +(defun letter-number (char) + "Return the index of `char` in the alphabet (A being 1)." + (1+ (- (char-code (char-upcase char)) (char-code #\A)))) + + +(defun set-equal (list1 list2 &rest args) + (null (apply #'set-exclusive-or list1 list2 args))) + +(defun orderless-equal (list1 list2 &key (sort-predicate #'<)) + (equal (sort (copy-seq list1) sort-predicate) + (sort (copy-seq list2) sort-predicate))) + + +(defun irange (start end &key (step 1) (key 'identity)) + "Inclusive `range`." + (range start (1+ end) :step step :key key)) + + +(defun length= (n sequence) + (= n (length sequence))) + + +(defun reverse-integer (n) + (digits-to-number (nreverse (digits n)))) + + +(defmacro labels-memoized (definitions &body body) + (let ((caches (mapcar #'gensym (range 0 (length definitions))))) + (flet ((build (cache definition) + (destructuring-bind (name lambda-list &body body) definition + `(,name ,lambda-list + (values + (ensure-gethash (list ,@lambda-list) ,cache + (progn ,@body))))))) + `(let (,@(iterate (for cache :in caches) + (collect `(,cache (make-hash-table :test #'equal))))) + (labels (,@(mapcar #'build caches definitions)) + ,@body))))) + + +(defun subsequencep (needles haystack &key key (test #'eql)) + "Return whether `needles` is a (possibly non-contiguous) subsequence of `haystack`." + (ctypecase haystack + (list + (every (lambda (el) + (let ((result (member el haystack :key key :test test))) + (setf haystack (rest result)) + result)) + needles)) + (sequence + (let ((p 0)) + (every (lambda (el) + (setf p (position el haystack :start p :key key :test test))) + needles))))) diff -r 0061265e6b73 -r 48e02ac6faae vendor/make-quickutils.lisp --- a/vendor/make-quickutils.lisp Tue Mar 14 13:36:14 2017 +0000 +++ b/vendor/make-quickutils.lisp Tue Aug 08 15:50:54 2017 -0400 @@ -7,6 +7,7 @@ :compose :curry :define-constant + :emptyp :ensure-boolean :ensure-gethash :equivalence-classes diff -r 0061265e6b73 -r 48e02ac6faae vendor/quickutils.lisp --- a/vendor/quickutils.lisp Tue Mar 14 13:36:14 2017 +0000 +++ b/vendor/quickutils.lisp Tue Aug 08 15:50:54 2017 -0400 @@ -2,7 +2,7 @@ ;;;; See http://quickutil.org for details. ;;;; To regenerate: -;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:COMPOSE :CURRY :DEFINE-CONSTANT :ENSURE-BOOLEAN :ENSURE-GETHASH :EQUIVALENCE-CLASSES :MAP-COMBINATIONS :MAP-PERMUTATIONS :MAXF :MINF :N-GRAMS :RANGE :RCURRY :READ-FILE-INTO-STRING :REMOVEF :SWITCH :WITH-GENSYMS) :ensure-package T :package "EULER.QUICKUTILS") +;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:COMPOSE :CURRY :DEFINE-CONSTANT :EMPTYP :ENSURE-BOOLEAN :ENSURE-GETHASH :EQUIVALENCE-CLASSES :MAP-COMBINATIONS :MAP-PERMUTATIONS :MAXF :MINF :N-GRAMS :RANGE :RCURRY :READ-FILE-INTO-STRING :REMOVEF :SWITCH :WITH-GENSYMS) :ensure-package T :package "EULER.QUICKUTILS") (eval-when (:compile-toplevel :load-toplevel :execute) (unless (find-package "EULER.QUICKUTILS") @@ -15,11 +15,12 @@ (when (boundp '*utilities*) (setf *utilities* (union *utilities* '(:MAKE-GENSYM-LIST :ENSURE-FUNCTION :COMPOSE :CURRY :DEFINE-CONSTANT - :ENSURE-BOOLEAN :ENSURE-GETHASH - :EQUIVALENCE-CLASSES :MAP-COMBINATIONS - :MAP-PERMUTATIONS :MAXF :MINF :TAKE - :N-GRAMS :RANGE :RCURRY :ONCE-ONLY - :WITH-OPEN-FILE* :WITH-INPUT-FROM-FILE + :NON-ZERO-P :EMPTYP :ENSURE-BOOLEAN + :ENSURE-GETHASH :EQUIVALENCE-CLASSES + :MAP-COMBINATIONS :MAP-PERMUTATIONS + :MAXF :MINF :TAKE :N-GRAMS :RANGE + :RCURRY :ONCE-ONLY :WITH-OPEN-FILE* + :WITH-INPUT-FROM-FILE :READ-FILE-INTO-STRING :REMOVEF :STRING-DESIGNATOR :WITH-GENSYMS :EXTRACT-FUNCTION-NAME :SWITCH)))) @@ -133,6 +134,20 @@ ,@(when documentation `(,documentation)))) + (defun non-zero-p (n) + "Check if `n` is non-zero." + (not (zerop n))) + + + (defgeneric emptyp (object) + (:documentation "Determine if `object` is empty.") + (:method ((x null)) t) + (:method ((x cons)) nil) + (:method ((x vector)) (zerop (length x))) ; STRING :< VECTOR + (:method ((x array)) (notany #'non-zero-p (array-dimensions x))) + (:method ((x hash-table)) (zerop (hash-table-count x)))) + + (defun ensure-boolean (x) "Convert `x` into a Boolean value." (and x t)) @@ -511,7 +526,7 @@ (generate-switch-body whole object clauses test key '(cerror "Return NIL from CSWITCH."))) (eval-when (:compile-toplevel :load-toplevel :execute) - (export '(compose curry define-constant ensure-boolean ensure-gethash + (export '(compose curry define-constant emptyp ensure-boolean ensure-gethash equivalence-classes map-combinations map-permutations maxf minf n-grams range rcurry read-file-into-string removef switch eswitch cswitch with-gensyms with-unique-names)))