Euler Project 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 asked 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.
I do it by pencil and paper.

Euler Project 50

The prime 41, can be written as the sum of six consecutive primes:

41 = 2 + 3 + 5 + 7 + 11 + 13

This is the longest sum of consecutive primes that adds to a prime below one-hundred.
The longest sum of consecutive primes below one-thousand that adds to a prime, contains 21 terms, and is equal to 953.
Which prime, below one-million, can be written as the sum of the most consecutive primes?

My Solution Using Mathematica

MyPrimesList = Table[Prime[i], {i, PrimePi[1000000]}]

MostLength = 0; CurrentPrimes = 2; TempValue = 0; TempCount = 0;
For[i = 1, i < 10000, i++, TempValue = 0; TempCount = 0; 
For[j = i, j < 10000, j++, TempCount = TempCount + 1; 
TempValue = TempValue + MyPrimesList[[j]]; 
 If[TempValue > 1000000, Break[]]; 
 If[PrimeQ[TempValue], If[TempCount > MostLength, MostLength = TempCount; CurrentPrimes = i]]]

Others' Solution

First Solution

(defun sieve (lst)
(let ((primes '())
(last (car (last lst))))
(loop while (and lst (> last (* (car lst) (car lst))))
do (let ((factor (car lst)))
(setq primes (cons factor primes))
(setq lst (remove-if
#'(lambda (n)
(= (mod n factor) 0))
(cdr lst)))))
(append (reverse primes) lst)))

(defun seq-list (min max)
(loop for i from min to max collect i))

(defun all-primes (limit)
(sieve (seq-list 2 limit)))

(defun generate-all-primes (limit)
(setq all-primes (all-primes limit))
(setq primehash (make-hash-table))
(loop for p in all-primes
do (setf (gethash p primehash) p)))

(defun primep (p)
(gethash p primehash))

(defun generate-prime-sums (limit)
(setq primesumhash (make-hash-table))
(generate-all-primes limit)
(loop for allp on all-primes
do (loop for p in allp
sum p into pp
while (< pp limit)
append (list p) into pl
if (and (primep pp)
(> (length pl)
(length (gethash pp primesumhash '()))))
do (setf (gethash pp primesumhash) (copy-list pl)))))

(defun euler50 ()
(generate-prime-sums 1000000)
(let ((psums (loop for p being each hash-key of primesumhash
append (list (cons p (gethash p primesumhash))))))
(sort psums #'(lambda (a b) (< (length a) (length b))))
(car (last psums)))) 

Second Solution

p = Prime /@ Range @ 78498;
partialsums = Rest@FoldList[Plus, 0, p];
  

total[a_, b_] :=

     p[[a]] + ( partialsums[[b]] - partialsums[[a]])
  

inrange[a_, b_] := 

    total[a, b] < 1000000
  

hunt[width_] := Module[{a, b, n}, 

    {a, b} = {1, width}; 

     n = Length@ partialsums ; 

    While[b < n && inrange[a, b], 

        If[PrimeQ@total[a, b], Return[{a, b}]]; 

        {a, b} += {1, 1}; 

        ]; 

    Return@{}
]
  

total@@Last@Select[hunt/@Range[1, 1000], Length@# > 0&]

Third Solution

Fourth Solution

(defun longest-cons-primesum (prime-list below)
(do* ((data prime-list (rest data))
(zwischen (loop for i in data
summing i into summe
while (< summe below)
counting i into lang
if (member summe data)
collecting (list lang summe))
(loop for i in data
summing i into summe
while (< summe below)
counting i into lang
if (member summe data)
collecting (list lang summe)))
(result zwischen (if (> (caar (last zwischen))
(caar (last result)))
zwischen
result)))
((> (reduce #'+ (subseq data 0 (caar (last result)))) below)
(last result))))

With this function you just have to generate the data and call it.

(defvar primes-below-million
(loop for i from 1 to 1000000 if (primep i) collecting i))

This takes around 12 seconds.

(longest-cons-primesum primes-below-million 1000000) 

Fifth Solution

(defun length-prime-sum-sequence (n0 max) 

    (let ((sum 0) 

          (seq-length 0)) 

        (iter (for i from n0 below (length *primes*)) 

               (for p = (aref *primes* i)) 

               (for s first p then (+ s p)) 

               (if (>= s max) 

                  (finish)) 

               (when (primep s) 

                    (setq sum s) 

                    (setq seq-length (- i n0))) 

               (finally (return (values (1+ seq-length) sum)))))))
  

(defun longest-sum-sequence (max) 

    (iter (for i from 0 below max) 

          (for (values length sum) = (length-prime-sum-sequence i max)) 

          (finding (list length sum) maximizing length)))

Euler Project 23

A perfect number is a number for which the sum of its proper divisors is exactly equal to the number. For example, the sum of the proper divisors of 28 would be 1 + 2 + 4 + 7 + 14 = 28, which means that 28 is a perfect number.
A number n is called deficient if the sum of its proper divisors is less than n and it is called abundant if this sum exceeds n.
As 12 is the smallest abundant number, 1 + 2 + 3 + 4 + 6 = 16, the smallest number that can be written as the sum of two abundant numbers is 24. By mathematical analysis, it can be shown that all integers greater than 28123 can be written as the sum of two abundant numbers. However, this upper limit cannot be reduced any further by analysis even though it is known that the greatest number that cannot be expressed as the sum of two abundant numbers is less than this limit.
Find the sum of all the positive integers which cannot be written as the sum of two abundant numbers.

My Solution Using Mathematica

MyList = Table[List[i, Total[Divisors[i]] - i], {i, 1, 28124}];

MyList = Select[MyList, #[[1]] < #[[2]] &]

MyList = MyList[[All, 1]]

SumoOfNumber = 0;

For[i = 1, i < 28124, i++, 

 If[Length[IntegerPartitions[i, {2}, MyList]] == 0, 

   SumoOfNumber = SumoOfNumber + i];]; Print[SumoOfNumber]

Euler Project 77

It is possible to write ten as the sum of primes in exactly five different ways:

7 + 3
5 + 5
5 + 3 + 2
3 + 3 + 2 + 2
2 + 2 + 2 + 2 + 2

What is the first value which can be written as the sum of primes in over five thousand different ways?


My Solution Using Mathematica
MyPrimesList = Table[Prime[i], {i, PrimePi[10000]}]

For[i = 2, i < 1000000, i++, 

 If[Length[IntegerPartitions[i, All, MyPrimesList]] > 5000, Print[i]; Break[]]]

Others' Solutions

First Solutions

(defun sieve (lst)
(let ((primes '())
(last (car (last lst))))
(loop while (and lst (> last (* (car lst) (car lst))))
do (let ((factor (car lst)))
(setq primes (cons factor primes))
(setq lst (remove-if
#'(lambda (n)
(= (mod n factor) 0))
(cdr lst)))))
(append (reverse primes) lst)))

(defun seq-list (min max)
(loop for i from min to max collect i))

(defun all-primes (limit)
(sieve (seq-list 2 limit)))

(defun fill-partitions-hash (max)
(setq partitions-hash (make-hash-table :test 'equal))
(setf (gethash (list 0 0) partitions-hash) 1)
(setf (gethash (list 1 1) partitions-hash) 0)
(loop for n from 1 to max
do (fill-partitions-helper n n)))

(defun fill-partitions-helper (n max)
(let ((memo (gethash (list n max) partitions-hash)))
(if memo
memo
(loop for i in all-primes
while (<= i max)
sum (fill-partitions-helper (- n i) (min i (- n i) max)) into p
finally (return (setf (gethash (list n max) partitions-hash) p))))))

(defun euler77 ()
(setq all-primes (all-primes 100))
(fill-partitions-hash 10)
(loop for i from 10
do (fill-partitions-helper i i)
if (> (gethash (list i i) partitions-hash) 5000)
return i)) 

Second Solution

Length@IntegerPartitions[n, n, Prime@Range@n]

Third Solution

(defun init-counts-table (n) 

    (let ((table (make-array (1+ n) :initial-element 0))) 

     table))
  

(defun update-counts-table! (table i n) 

    (incf (aref table i) 1) 

    (iterate loop ((c (+ 2 i))) 

        (unless (> c n) 

            (setf (aref table c) (lengthened-row-size table i c)) 

            (loop (1+ c)))))
  

(defun lengthened-row-size (table i c) 

    (let ((row-c (aref table c)) 

          (row-c-i (aref table (- c i)))) 

        (+ row-c-i row-c)))
  

(defun my-partition-counts.2 (n) 

    (let ((primes-vec (array-of-primes n)) 

          (table (init-counts-table n))) 

        (iterate loop ((i 0)) 

            (if (< i (array-dimension primes-vec 0)) 

                (let ((p (aref primes-vec i))) 

                    (update-counts-table! table p n) 

                    (loop (1+ i))))) 

        (aref table n)))

Euler Project 104

My Solution Using Mathematica,but this method is so bad which waste more than one hour to get the result.
The Fibonacci sequence is defined by the recurrence relation:

F_n = F_n1 + F_n2, where F₁ = 1 and F₂ = 1.

It turns out that F₅₄₁, which contains 113 digits, is the first Fibonacci number for which the last nine digits are 1-9 pandigital (contain all the digits 1 to 9, but not necessarily in order). And F₂₇₄₉, which contains 575 digits, is the first Fibonacci number for which the first nine digits are 1-9 pandigital.
Given that F_k is the first Fibonacci number for which the first nine digits AND the last nine digits are 1-9 pandigital, find k.

{a, b} = {Fibonacci[200000], Fibonacci[200001]}

For[i = 200000, i < 10000000, i++, Tempvalue = a;

 If[Sort[IntegerDigits[Tempvalue][[-9 ;; -1]]] == PandigitalList && 

   Sort[IntegerDigits[Tempvalue][[1 ;; 9]]] == PandigitalList, 

  Print[i], {a, b} = {b, a + b}]]

Others' Solution

First Solution

NextFib[{n_, f1_, f2_}] := {n + 1, f2, f1 + f2}~Mod~1000000000

Fib[n_] := GoldenRatio^n/Sqrt[5] // N // Round

NotPanQ[X_] := Sort[X] ≠ {1, 2, 3, 4, 5, 6, 7, 8, 9}

Test[{n_, f1_, f2_}] :=
NotPanQ @ IntegerDigits[f2] ||
NotPanQ @ Select[IntegerDigits@Fib[n], True &, 9]
NestWhile[NextFib, {2, 1, 1}, Test]

Second Solution

(defparameter *a* 1) 

(defparameter *b* 1) 

(defparameter *i* 1)
  

(defun problema () 

    (let ((a 1) (b 1) c) 

        (do ((i 1 (1+ i))) 

             ((and (pandigital-p (format nil "~a" a)) 

                    (pandigital-p (substring (format nil "~a" (fibo i)) 0 9))) 

                 i) 

            (setf c (mod (+ a b)1000000000) a b b c))))
  

(defun fibo (n) 

    (loop 

        for i from *i* to (1- n) 

        with c 

        do 

        (setf c (+ *a* *b*) *a* *b* *b* c *i* (1+ i)) 

        finally (return *a*)))
  

(defun pandigital-p (str)
(and (find #\1 str)(find #\6 str)
(find #\2 str)(find #\7 str)(find #\3 str)
(find #\8 str)(find #\4 str)(find #\9 str)
(find #\5 str)))
  

(time (print (problema)))

Third Solution

(defun number->digits-h (x digits) 

    (if (= x 0) 

         digits 

        (number->digits-h (/ (- x (mod x 10)) 10) (cons (mod x 10) digits))))
  

(defun number->digits (x) 

    (number->digits-h x ()))
  

(defun check-first-9 (number) 

    (let* ((digits (1+ (floor (log number 10)))) 

            (nl (/ (- number (mod number (expt 10 (- digits 9)))) 

                    (expt 10 (- digits 9)))) 

            (first-9 (number->digits nl))) 

        (= 9 (length (remove 0 (remove-duplicates first-9))))))
  

(defun euler104 () 

    (do* ((a 1 b) 

        (b 1 c) 

        (c (+ a b) (+ a b)) 

        (n 3 (1+ n)) 

        (last 2 (mod c (expt 10 9)))) 

        ((and (= 9 (length (remove 0 (remove-duplicates (number->digits last))))) 

              (check-first-9 c)) (print n)) 

        (if (zerop (mod n 10000)) (print n))))

Forth Solution

Module[{k = 3, f = {0, 1, 1}, fk},
While[True,
fk = Mod[f[[Mod[k - 1, 3] + 1]] + f[[Mod[k - 2, 3] + 1]], 10^9];
f[[Mod[k, 3] + 1]] = fk;
If[Sort@IntegerDigits@fk == Range[9],
If[StringJoin@
Sort@Characters@StringTake[ToString@Fibonacci@k, 9] ==
"123456789", Break[]]]; k++]; k]