├── ArithmeticFunctions.hs ├── Factoring.hs ├── FactoringCFRAC.hs ├── FactoringECM.hs ├── MathsPrimitives.hs ├── MergeSort.hs ├── NumberTheoryFundamentals.hs ├── Primes.hs ├── README.md ├── RandomGenerator.hs ├── atkin_vector.hs ├── eratosthene_tmws.hs ├── expmod_1.hs └── expmod_2.hs /ArithmeticFunctions.hs: -------------------------------------------------------------------------------- 1 | -- arithmeticfunctions.hs 2 | 3 | module ArithmeticFunctions where 4 | 5 | import NumberTheoryFundamentals (divides) 6 | import Primes 7 | -- import Bits ( (.&.) ) 8 | 9 | 10 | 11 | -- EULER'S TOTIENT FUNCTION 12 | 13 | eulerTotient n = 14 | let factors = primePowerFactors n 15 | in product (map (\(p,a) -> p^(a-1) * (p-1)) factors) 16 | 17 | -- much less efficient - only used for testing 18 | eulerTotient2 n = length [x | x <- [1..n], gcd n x == 1] 19 | 20 | 21 | -- MOBIUS FUNCTION 22 | 23 | mobius n 24 | | n <= 0 = error "mobius: not defined for n <= 0" 25 | | otherwise = doMobius n (primesTo10000 ++ [p | p <- [10001,10003..], isPrime p]) 26 | where 27 | doMobius n (p:ps) 28 | | n == 1 = 1 29 | | (p*p) `divides` n = 0 30 | | p `divides` n = negate (doMobius (n `div` p) ps) 31 | | otherwise = doMobius n ps 32 | 33 | 34 | -- SIGMA FUNCTIONS 35 | 36 | -- see Hardy and Wright p239 for full explanation 37 | 38 | numDivisors :: Integer -> Integer 39 | -- the number of divisors of n ( = sigma 0 n) 40 | numDivisors n = product [ toInteger (a+1) | (p,a) <- primePowerFactors n] 41 | -- we return an Integer, not an Int 42 | -- for example, the product of the first 32 primes has 2^32 factors 43 | 44 | sigma1 :: Integer -> Integer 45 | -- sigma1 n is the sum of the divisors of n 46 | sigma1 n = product [((p^(a+1)) - 1) `div` (p - 1) | (p,a) <- primePowerFactors n] 47 | 48 | sigma :: Int -> Integer -> Integer 49 | -- sigma k n is the sum of the kth powers of the divisors of n 50 | sigma k n 51 | | n <= 0 = error "sigma: n <= 0" 52 | | k < 0 = error "sigma: k < 0" 53 | | k == 0 = numDivisors n 54 | | otherwise = product [(p^((a+1)*k) - 1) `div` (p^k - 1) | (p,a) <- primePowerFactors n] 55 | 56 | 57 | sigma1' n = sum [d | d <- [1..n], n `mod` d == 0] 58 | -- very inefficient for large n - defined for testing purposes only 59 | 60 | sigma' k n = sum [d^k | d <- [1..n], n `mod` d == 0] 61 | -- very inefficient for large n - defined for testing purposes only 62 | 63 | sigma1primePowerProduct :: [(Integer,Int)] -> Integer 64 | -- sigma1primeProduct takes its input already factorised 65 | sigma1primePowerProduct factors = product [(p^(a+1) - 1) `div` (p - 1) | (p,a) <- factors] 66 | 67 | 68 | -- HARMONIC FUNCTION 69 | 70 | gamma = 0.5772156649015328606065 :: Double 71 | -- Euler's constant, == lim (n -> inf) (sum [h k | k <- [1..n]] - log n) 72 | -- Source: Gamma by Julian Havil 73 | 74 | harmonicFunction :: Integer -> Double 75 | harmonicFunction n 76 | | n <= 0 = error "harmonicFunction: not defined for n <= 0" 77 | | n <= 20 = harmonicFunction1 n 78 | | otherwise = harmonicFunction2 n 79 | -- for n <= 20, harmonicFunction1 probably faster to calculate, and of course it is more accurate 80 | -- for n > 20, the error in harmonicFunction2 is less than 1 part in 10^10 81 | 82 | harmonicFunction1 n = sum [1.0 / (fromInteger k) | k <- [1..n]] 83 | -- too slow to use for large n 84 | 85 | harmonicFunction2 n = 86 | let n' = fromInteger n 87 | in log n' + gamma + (1 / (2*n')) - (1 / (12*n'*n')) + (1 / (120*n'*n'*n'*n')) 88 | -- this estimate is accurate to O(1/n^6) 89 | -- see Aigner, Ziegler, p11 90 | 91 | -- Doubles valid up to about 1.75e308 92 | 93 | -------------------------------------------------------------------------------- /Factoring.hs: -------------------------------------------------------------------------------- 1 | -- factoring.hs 2 | 3 | module Factoring where 4 | 5 | import List (partition) 6 | import MergeSort 7 | import NumberTheoryFundamentals (splitWith) 8 | import Primes 9 | import FactoringECM 10 | 11 | import FactoringCFRAC 12 | 13 | -- In tests, ECM comes out faster than CFRAC, but not hugely so. 14 | 15 | factors n 16 | | isPrime n = [n] 17 | | otherwise = merge (factors d) (factors (n `div` d)) 18 | where d = findFactorECM n 19 | 20 | -- version of primePowerFactors which finds large factors too 21 | primePowerFactorsL :: Integer -> [(Integer,Int)] 22 | primePowerFactorsL n | n > 0 = takeOutFactors n primesTo10000 23 | where 24 | takeOutFactors n (p:ps) 25 | -- | n == 1 = [] -- unnecessary, caught by following test 26 | | p*p > n = finish n 27 | | otherwise = 28 | let (s,n') = n `splitWith` p 29 | in if s > 0 then (p,s) : takeOutFactors n' ps else takeOutFactors n ps 30 | takeOutFactors n [] = finish n 31 | finish 1 = [] 32 | finish n = 33 | if n < 100000000 -- we already know it's a trial division prime up to 10000 34 | then [(n,1)] 35 | else counts (factors n) 36 | counts [] = [] 37 | counts fs@(x:_) = let (xs,ys) = partition (==x) fs in (x, length xs) : counts ys 38 | 39 | 40 | pairProducts [] = [] 41 | pairProducts (x:xs) = map (x*) xs ++ pairProducts xs -------------------------------------------------------------------------------- /FactoringCFRAC.hs: -------------------------------------------------------------------------------- 1 | -- factoringCFRAC.hs 2 | 3 | module FactoringCFRAC where 4 | 5 | import RedBlackTree 6 | import MergeSort 7 | import Primes 8 | import NumberTheoryFundamentals (splitWith, extendedEuclid, intSqrt, legendreSymbol) 9 | import ContinuedFraction (convergentsForSqrt) 10 | 11 | 12 | -- FACTORING (LARGE PRIMES) 13 | 14 | -- The algorithm is as follows: 15 | 16 | -- 1. Find some numbers b s.t b*b mod n is small (or sometimes small and negative) 17 | -- (Fermat's method would be to try numbers around intSqrt (k*n) for small k) 18 | -- The continued fraction method uses the fact that continued fractions can provide good rational approximations to sqrt (k*n) 19 | 20 | -- 2. For each b we have found, reduce b*b mod n to a factor base of small primes 21 | -- (eg b1 -> p1^2*p2, b2 -> p3*p4^2, b3 -> p2*p3 etc) 22 | 23 | -- (now we regard these reductions as vectors over F2, eg p2^2*p3 = (0,2,1,0,0,...) ) 24 | -- 3. Perform gaussian elimination on the vectors over the factor base, until we have a product of even powers of small primes 25 | -- (eg b1*b2*b3 -> p1^2 * p2^2 * p3^2 * p4^2) 26 | 27 | -- 4. Then we have x, a product of bis, and y, a product of pis, s.t x^2 = y^2 (mod n) - we are hoping, x /= +/- y (mod n) 28 | -- (for example, we have (b1*b2*b3)^2 = (p1*p2*p3*p4)^2 ) 29 | -- Then we have x^2 - y^2 = 0 (mod n), so (x+y)(x-y) = kn. 30 | -- What we're hoping is that either gcd (x+y,n) or gcd (x-y,n) will give us a factor 31 | -- (It's not guaranteed, as we may find x+y = n, x-y = k, for example) 32 | 33 | 34 | 35 | -- CONTINUED FRACTION CANDIDATES 36 | -- We use the continued fraction expansion of sqrt kn to find numbers x s.t. x^2 `mod` n is small ( o(sqrt n) ) 37 | 38 | -- returns the least absolute residue, ie using a small negative number rather than a large positive number where possible 39 | lmod x n = let x' = x `mod` n in if x' + x' < n then x' else x' - n 40 | 41 | cfracCandidates k n = [(b `mod` n, (b*b) `lmod` n) | (_,(b,c)) <- convergentsForSqrt (k*n)] 42 | -- b/c is an approximation to sqrt kn 43 | -- hence we expect b*b - k*n*c*c == b*b `lmod` n to be small 44 | 45 | 46 | -- REDUCTION TO FACTOR BASE 47 | 48 | 49 | reduceToFactorBase :: [Integer] -> Integer -> (Integer, [(Integer,Int)]) 50 | -- the factor base should be a list of small primes 51 | reduceToFactorBase fbase m 52 | | m > 0 = doReduceToFactorBase fbase m [] 53 | | m < 0 = doReduceToFactorBase fbase (-m) [(-1,1)] 54 | where 55 | doReduceToFactorBase ps 1 factors = (1, factors) 56 | doReduceToFactorBase [] m factors = (m, factors) 57 | doReduceToFactorBase (p:ps) m factors = 58 | let (s, m') = m `splitWith` p 59 | in 60 | if (s>0) 61 | then doReduceToFactorBase ps m' ((p,s):factors) 62 | else doReduceToFactorBase ps m factors 63 | 64 | 65 | 66 | -- This value is actually for MPQS (from Landquis) 67 | -- However, brief experimentation shows it is good for CFRAC too 68 | optimalFactorBase n = fromInteger (round (exp (sqrt (log n' * log (log n'))) ** (sqrt 2 / 4))) :: Int 69 | where n' = fromInteger n 70 | 71 | factorBase k n = take b [p | p <- primesTo10000 ++ filter isPrime [10001,10003..], legendreSymbol (k*n) p `elem` [0,1]] 72 | where b = optimalFactorBase n 73 | 74 | 75 | -- CONSTRUCTING OUR TABLE OF FACTORS 76 | 77 | -- What we need to do now is take the cfracCandidates, reduce them to a factor base 78 | -- until the number of candidates we have exceeds the number of factors we're using from the factor base 79 | -- at that point we can expect to have linear dependencies between entries in the table 80 | 81 | 82 | constructFactorTable k n = 83 | let 84 | fbase = factorBase k n 85 | candidates = [(b,factors) | (b,b2) <- cfracCandidates k n, (unfactored,factors) <- [reduceToFactorBase fbase b2], unfactored == 1] 86 | in doConstructFactorTable [] rbempty candidates 87 | where 88 | doConstructFactorTable table factors (entry@(b,ps):entries) = 89 | if length table > rbcount factors 90 | then reverse table -- !! reverse is temporary to help debugging 91 | else 92 | let factors' = foldl rbinsert factors (map fst ps) 93 | in doConstructFactorTable (entry:table) factors' entries 94 | -- rather than counting the factors, we could just use the size of the factor base as our stopping point 95 | -- test to see if it makes a significant difference 96 | 97 | 98 | 99 | -- Cohen p479 says that k must be square-free, and kn = 0 or 1 (mod 4) 100 | -- reverse order of last two clauses for slight speed improvement 101 | allFactorTables n = [constructFactorTable k n | k <- [1..], isSquareFree k, k * n `mod` 4 `elem` [0,1] ] 102 | 103 | 104 | -- GAUSSIAN ELIMINATION 105 | 106 | -- We now regard [(b,[(p,a)])] as a sparse matrix over F2 (where p is the column index, and a `mod` 2 is the value) 107 | 108 | -- For Gaussian elimination, we should choose the column having the least non-zero entries, and pivot on one of the rows having a non-zero entry in that column 109 | -- We approximate this by pivoting on rows having the largest prime factor first 110 | -- !! We could almost certainly do better by implementing this in a more sophisticated way 111 | 112 | -- Calculate the weights of the columns (ie the number of non-zero entries) 113 | columnWeights t = doAnalyzeFactorTable rbempty t 114 | where 115 | doAnalyzeFactorTable factors [] = rbtolist factors 116 | doAnalyzeFactorTable factors ((b,ps):rows) = 117 | let factors' = foldl (\rb (p,a) -> if even a then rb else rb `rbaddupdate` (p,1)) factors ps 118 | in doAnalyzeFactorTable factors' rows 119 | 120 | 121 | -- Remove columns of weight 1, and the rows in which those columns have non-zero coefficients 122 | -- (In other words, if there is a p, such that only one row contains (p,a) with a odd, then remove that row) 123 | removeWeight1s ftable = doRemoveSingletons1 rbempty ftable 124 | where 125 | doRemoveSingletons1 factors ((b,ps):rows) = 126 | let factors' = foldl (doupdate b) factors ps 127 | in doRemoveSingletons1 factors' rows 128 | doRemoveSingletons1 factors [] = doRemoveSingletons2 factors 129 | doupdate b rb (p,a) 130 | | even a = rb 131 | | otherwise = case rb `rblookup` p of 132 | Nothing -> rb `rbupdate` (p,Just b) -- this prime hasn't been seen before 133 | Just (Just b') -> rb `rbupdate` (p,Nothing) -- this prime has been seen only once before 134 | Just Nothing -> rb -- this prime has been seen more than once already 135 | doRemoveSingletons2 factors = 136 | let singletonrows = filter (/= Nothing) (rbvalues factors) 137 | in filter (\(b,ps) -> Just b `notElem` singletonrows) ftable 138 | 139 | 140 | addRow n (b,ps) (b',ps') = (b*b' `mod` n, multps ps ps') 141 | where 142 | multps as [] = as 143 | multps [] bs = bs 144 | multps ((p1,a1):ps) ((p2,a2):qs) 145 | | p1 > p2 = (p1,a1) : multps ps ((p2,a2):qs) 146 | | p1 == p2 = (p1,a1+a2) : multps ps qs 147 | | p1 < p2 = (p2,a2) : multps ((p1,a1):ps) qs 148 | 149 | 150 | orderRows rows = map snd (mergeSort' (>) (map (\(b,ps) -> (largestPrime ps ,(b,ps)) ) rows)) 151 | where 152 | largestPrime [] = 100000000 -- ie we want this row ordered before any other, as it is already reduced 153 | largestPrime ((p,a):pas) = if odd a then p else largestPrime pas 154 | 155 | 156 | gaussElim _ [] = [] 157 | gaussElim n ((b,ps):rows) = 158 | if all (\(p,a) -> even a) ps 159 | then (b,ps) : gaussElim n rows 160 | else 161 | let (p,_) = head (filter (\(p,a) -> odd a) ps) -- ie the last prime with odd exponent 162 | in gaussElim n (map (\row@(_,qs) -> if qs `hasOddPower` p then addRow n row (b,ps) else row) rows) 163 | where 164 | hasOddPower ((q,a):qs) p 165 | | q > p = hasOddPower qs p 166 | | q == p = odd a 167 | | otherwise = False 168 | hasOddPower [] _ = False 169 | 170 | 171 | -- FINDING A FACTOR 172 | -- putting it all together, to use the results of Gaussian elimination to find a factor 173 | 174 | -- find a factor once we have a (b,ps) with all exponents even 175 | findFactorFromPair n (b,ps) = 176 | let y = product [p ^ (a `div` 2) | (p,a) <- ps] `mod` n 177 | in gcd n (b+y) 178 | 179 | factorSplits n = map (findFactorFromPair n) (concat (map ( (gaussElim n) . orderRows . removeWeight1s) (allFactorTables n))) 180 | 181 | 182 | findFactorCFRAC n = let n' = intSqrt n in if n == n' * n' then n' else findFactorCFRAC' n 183 | -- we perform this test because the continued fraction code doesn't work if n is a perfect square 184 | 185 | findFactorCFRAC' n = head [d | d <- factorSplits n, d /= 1, d /= n] 186 | 187 | 188 | 189 | 190 | -- LARGE PRIME VARIATION 191 | 192 | -- At the moment, if our b^2 `mod` n doesn't factor completely over our factor base, we throw it away 193 | -- In the large prime variation, then if the unfactored part is a prime, we don't throw it away 194 | -- What we do instead is store it in a separate large prime table 195 | -- (Suppose b^2 `mod` n = ps * q, where q is the large prime - then we store (q, (b,ps)) in our rbtree) 196 | -- If we ever get a collision, ie (q,(b,ps)) is already in the table, and we try to add (q,(b',ps')) 197 | -- then we take both out of the table, and combine them to get an entry for the main table 198 | -- b^2 = ps * q, and b'^2 = ps' * q, 199 | -- so (b*b'/q)^2 = ps * ps' (mod n) 200 | -- (we can calculate 1/q using extended Euclid) 201 | 202 | constructFactorTableLP k n = 203 | let 204 | fbase = factorBase k n 205 | candidates = [(unfactored,(b,factors)) | (b,b2) <- cfracCandidates k n, (unfactored,factors) <- [reduceToFactorBase fbase b2] ] 206 | in doConstructFactorTable [] rbempty rbempty candidates 207 | where 208 | doConstructFactorTable table factors lptable (entry@(unfactored,(b,ps)):entries) 209 | | unfactored == 1 = 210 | if length table > rbcount factors 211 | then reverse table -- !! reverse is temporary to help debugging 212 | else 213 | let factors' = foldl rbinsert factors (map fst ps) 214 | in doConstructFactorTable ((b,ps):table) factors' lptable entries 215 | | isPrime unfactored = case lptable `rblookup` unfactored of 216 | Nothing -> 217 | let lptable' = lptable `rbupdate` (unfactored,[(b,ps)]) 218 | in doConstructFactorTable table factors lptable' entries 219 | Just bps -> 220 | let 221 | lptable' = lptable `rbupdate` (unfactored,(b,ps):bps) 222 | tableadditions = map (lpentryfrom n unfactored (b,ps)) bps 223 | table' = tableadditions ++ table 224 | in doConstructFactorTable table' factors lptable' entries 225 | | otherwise = doConstructFactorTable table factors lptable entries 226 | -- !! we don't check for duplicates when adding tableadditions - perhaps we should 227 | 228 | lpentryfrom n q (b1,ps1) (b2,ps2) = 229 | let (u,v,d) = extendedEuclid n q -- so un + vq = 1, so v is inverse of q mod n 230 | in 231 | if d == 1 232 | then 233 | let (b',ps') = addRow n (b1,ps1) (b2,ps2) 234 | in (b' * v `mod` n, ps') 235 | else error ("lpentryfrom: found factorization early: " ++ show d) 236 | 237 | allFactorTablesLP n = [constructFactorTableLP k n | k <- [1..], isSquareFree k, k * n `mod` 4 `elem` [0,1] ] 238 | 239 | factorSplitsLP n = map (findFactorFromPair n) (concat (map ( (gaussElim n) . orderRows . removeWeight1s) (allFactorTablesLP n))) 240 | 241 | findFactorLP n = head [d | d <- factorSplitsLP n, d /= 1, d /= n] 242 | 243 | -------------------------------------------------------------------------------- /FactoringECM.hs: -------------------------------------------------------------------------------- 1 | -- factoringecm.hs 2 | 3 | module FactoringECM where 4 | 5 | import NumberTheoryFundamentals (divides, extendedEuclid) 6 | import MathsPrimitives (partialProducts) 7 | import Primes 8 | 9 | 10 | -- ELLIPTIC CURVE CODE 11 | -- This code is based on module EllipticCurves 12 | -- but with slight modifications to bail out when we find a factor 13 | 14 | data EllipticCurve' = EC' Integer Integer Integer deriving (Eq, Show) 15 | -- EC p a b represents the curve y^2 == x^3+ax+b over Fp 16 | 17 | data EllipticCurvePt' = Inf' | P' Integer Integer deriving (Eq, Show) 18 | -- P x y 19 | 20 | -- Optim voir Mongoméry optim http://programmingpraxis.com/2010/04/23/modern-elliptic-curve-factorization-part-1/ 21 | isEltEC _ Inf' = True 22 | isEltEC (EC' n a b) (P' x y) = (y*y - x*x*x - a*x - b) `mod` n == 0 23 | 24 | 25 | -- Koblitz p34 26 | 27 | -- assumes Fractional a 28 | ecAdd' _ Inf' pt = Left pt 29 | ecAdd' _ pt Inf' = Left pt 30 | ecAdd' (EC' n a b) (P' x1 y1) (P' x2 y2) 31 | | x1 /= x2 = 32 | let 33 | (u,v,d) = extendedEuclid n ((x1-x2) `mod` n) -- we're expecting d == 1, v == 1/(x1-x2) (mod n) 34 | m = (y1-y2) * v `mod` n 35 | x3 = (m*m - x1 - x2) `mod` n 36 | y3 = (- y1 + m * (x1 - x3)) `mod` n 37 | in if d == 1 then Left (P' x3 y3) else Right d 38 | | x1 == x2 = 39 | if (y1 + y2) `mod` n == 0 -- includes the case y1 == y2 == 0 40 | then Left Inf' 41 | else 42 | let 43 | (u,v,d) = extendedEuclid n ((2*y1) `mod` n) -- we're expecting d == 1, v == 1/(2*y1) (mod n) 44 | m = (3 * x1 * x1 + a) * v `mod` n 45 | x3 = (m*m - 2*x1) `mod` n 46 | y3 = (- y1 + m * (x1 - x3)) `mod` n 47 | in if d == 1 then Left (P' x3 y3) else Right d 48 | 49 | -- Note, it would be nice to avoid taking (x1-x2) `mod` n and (2*y1) `mod` n 50 | -- but unfortunately extendedEuclid can return d -ve if either input is -ve 51 | -- This could easily be fixed - if d -ve, change (u,v,d) -> (-u,-v,-d) 52 | 53 | ecMult' _ 0 _ = Left Inf' 54 | ecMult' ec k pt | k > 0 = doECMult Inf' pt k 55 | where 56 | -- doECMult p q n = p + n * q 57 | doECMult p _ 0 = Left p 58 | doECMult p q n = 59 | let p' = if odd n then ecAdd' ec p q else Left p 60 | q' = ecAdd' ec q q 61 | in case (p',q') of 62 | (Left p'', Left q'') -> doECMult p'' q'' (n `div` 2) 63 | (Right _, _) -> p' 64 | (_, Right _) -> q' 65 | 66 | discriminantEC' a b = 4 * a * a * a + 27 * b * b 67 | 68 | 69 | -- FACTORIZATION CODE 70 | 71 | -- We choose an elliptic curve E over Zn, and a point P on the curve 72 | -- We then try to calculate kP, for suitably chosen k 73 | -- What we are hoping is that at some stage we will fail because we can't invert an element in Zn 74 | -- This will lead to finding a non-trivial factor of n 75 | 76 | 77 | l n = exp (sqrt (log n * log (log n))) 78 | -- L(n) is some sort of measure of the average smoothness of numbers up to n 79 | -- # [x <= n | x is L(n)^a-smooth] = n L(n)^(-1/2a+o(1)) -- Cohen p 482 80 | 81 | ecTrial ec@(EC' n a b) ms pt = 82 | let d = gcd n (discriminantEC' a b) 83 | in if d == 1 then doECTrial ec ms pt else Right d 84 | where 85 | doECTrial ec [] pt = Left pt 86 | doECTrial ec (m:ms) pt = case ecMult' ec m pt of 87 | Left pt' -> doECTrial ec ms pt' 88 | Right d -> Right d 89 | 90 | -- q is the largest prime we're looking for - normally sqrt n 91 | -- the b figure here is from Cohen p488 92 | multipliers q = [largestPowerLE p b | p <- (2:[3,5..b]), isPrime p] 93 | where b = round ((l q) ** (1/sqrt 2)) 94 | largestPowerLE p m = last (takeWhile (<= m) (iterate (*p) p)) 95 | 96 | findFactorECM n | gcd n 6 == 1 = 97 | let ms = multipliers (sqrt n') 98 | in doFindFactor [ecTrial (EC' n a 1) ms (P' 0 1) | a <- [1..] ] 99 | where 100 | n' = fromInteger n 101 | doFindFactor ((Left _) : ts) = doFindFactor ts 102 | doFindFactor ((Right m) : ts) = 103 | if n `divides` m -- this can happen, for example if the problem was that the discriminant was divisible by n 104 | then doFindFactor ts 105 | else m 106 | 107 | 108 | -- OPTIMISED VERSION USING PARALLEL GCD 109 | -- from Cohen 110 | -- (Not fully implemented) 111 | 112 | -- There is a possible optimisation where we can do several curves in parallel 113 | -- (The point being that extendedEuclid is slow compared to multiplication mod n, and we can bundle up several extendedEuclids together at the expense of a few multiplications) 114 | -- Not clear this would be a huge gain for smallish numbers 115 | -- For n having 10 - 15 digits, we tend to need only 1 or a few curves 116 | -- However, for n having 25 - 30 digits, we tend to need about a hundred curves 117 | -- Even if we need only 1 curve, it might be that working in parallel will find our divisor sooner on one of the curves 118 | 119 | recipMod a n = let (u,v,d) = extendedEuclid a n in if d == 1 then Left u else Right d 120 | 121 | 122 | recipModParallel as n = 123 | let 124 | cs = map (`mod` n) (partialProducts as) -- can be optimised 125 | (u,v,d) = extendedEuclid (last cs) n 126 | in 127 | if d == 1 128 | then Left (reverse (computeInverses u (tail (reverse (1:cs))) (reverse as))) 129 | else Right (head [d | a <- as, d <- [gcd n a], d /= 1]) 130 | where 131 | computeInverses u (c:cs) (a:as) = (u * c `mod` n) : computeInverses (u * a `mod` n) cs as 132 | computeInverses _ [] [] = [] 133 | 134 | -- recipMod sometimes returns -ve numbers, indicating that a (`mod` n) might be in order 135 | -- alternatively we could just remove some of the (`mod` n)s from recipModParallel, and handle them later on in the code. 136 | -- (but might not be a good idea as means our integer arithmetic is correspondingly slower) 137 | 138 | 139 | 140 | -- ALTERNATIVE CODE 141 | 142 | -- version which tells us how many curves it had to check 143 | findFactorECMCount n | gcd n 6 == 1 = 144 | let ms = multipliers (sqrt n') 145 | in doFindFactor 1 [ecTrial (EC' n a 1) ms (P' 0 1) | a <- [1..] ] 146 | where 147 | n' = fromInteger n 148 | doFindFactor i ((Left _) : ts) = doFindFactor (i+1) ts 149 | doFindFactor i ((Right m) : ts) = 150 | if n `divides` m -- this can happen, for example if the problem was that the discriminant was divisible by n 151 | then doFindFactor (i+1) ts 152 | else (m,i) 153 | 154 | -- The c figure here is from Koblitz. However, he doesn't specify how to choose the b figure 155 | multipliers2 q = [largestPowerLE p c | p <- (2:[3,5..b]), isPrime p] 156 | where b = round ((l q) ** (1/sqrt 2)) 157 | c = round (q + 1 + 2 * sqrt q) 158 | largestPowerLE p m = last (takeWhile (<= m) (iterate (*p) p)) 159 | 160 | findFactorECM2 n | gcd n 6 == 1 = 161 | let ms = multipliers2 (sqrt n') 162 | in doFindFactor [ecTrial (EC' n a 1) ms (P' 0 1) | a <- [1..] ] 163 | where 164 | n' = fromInteger n 165 | doFindFactor ((Left _) : ts) = doFindFactor ts 166 | doFindFactor ((Right m) : ts) = 167 | if n `divides` m -- this can happen, for example if the problem was that the discriminant was divisible by n 168 | then doFindFactor ts 169 | else m 170 | 171 | -------------------------------------------------------------------------------- /MathsPrimitives.hs: -------------------------------------------------------------------------------- 1 | -- mathsprimitives.hs 2 | 3 | module MathsPrimitives where 4 | 5 | -- primitive operations on sequences (lists) of numbers 6 | -- used in implementation of vectors, matrices, polynomials, cyclotomic fields, etc 7 | 8 | import List (transpose) 9 | 10 | infixr 8 */, *// 11 | infixl 7 $*, $., $$* 12 | infixl 6 $+, $-, $$+, $$- 13 | 14 | 15 | -- addition of sequences 16 | (a:as) $+ (b:bs) = (a+b) : (as $+ bs) 17 | as $+ [] = as 18 | [] $+ bs = bs 19 | 20 | as $- bs = as $+ (map negate bs) 21 | 22 | -- scalar multiplication 23 | a */ bs = map (a*) bs 24 | 25 | 26 | -- polynomial multiplication 27 | [] $* _ = [] 28 | _ $* [] = [] 29 | (a:as) $* (b:bs) = [a*b] $+ shift (map (a*) bs $+ map (*b) as) $+ shift (shift (as $* bs)) 30 | 31 | shift [] = [] 32 | shift as = 0 : as 33 | 34 | 35 | -- dot product of vectors (also called inner or scalar product) 36 | u $. v = sum (zipWith (*) u v) 37 | 38 | 39 | -- tensor product of vectors (also called outer or matrix product) 40 | (a:as) $** v = map (a*) v : (as $** v) 41 | [] $** _ = [] 42 | 43 | 44 | 45 | -- matrix operations 46 | 47 | a $$+ b = zipWith (zipWith (+)) a b 48 | 49 | a $$- b = zipWith (zipWith (-)) a b 50 | 51 | a $$* b = doMultMx a (transpose b) 52 | where 53 | doMultMx [] _ = [] 54 | -- doMultMx (u:us) bT = map (u $.) bT : doMultMx us bT 55 | doMultMx (u:us) bT = ((:) $! (map (u $.) bT)) (doMultMx us bT) 56 | 57 | -- scalar multiplication 58 | k *// m = map (map (k*)) m 59 | 60 | 61 | fMatrix f n = [[f i j | j <- [1..n]] | i <- [1..n]] 62 | 63 | 64 | partialSums xs = scanl1 (+) xs 65 | 66 | partialProducts xs = scanl1 (*) xs 67 | 68 | factorials :: [Integer] 69 | factorials = scanl (*) 1 [1..] 70 | 71 | 72 | -- A class for types which represent mathematical functions 73 | class FunctionRep f where 74 | compose :: f -> f -> f 75 | deriv :: f -> f 76 | integ :: f -> f 77 | nthderiv :: Int -> f -> f 78 | nthderiv n f = iterate deriv f !! n 79 | 80 | 81 | 82 | 83 | 84 | 85 | {- 86 | -- action on the left 87 | [] <. _ = [] 88 | (row:rows) <. xs = 89 | sum (zipWith (*) row xs) : (rows <. xs) 90 | 91 | -- action on the right 92 | v .> m = doApplyRightMx [] v m 93 | where 94 | doApplyRightMx ys [] [] = foldl1 (zipWith (+)) ys 95 | doApplyRightMx ys (x:xs) (row:rows) = doApplyRightMx (map (x *) row : ys) xs rows 96 | 97 | -} -------------------------------------------------------------------------------- /MergeSort.hs: -------------------------------------------------------------------------------- 1 | -- MergeSort.hs 2 | 3 | module MergeSort where 4 | 5 | 6 | -- based on Rabhi, Lapalme, Algorithms: A functional programming approach 7 | 8 | 9 | -- MERGESORT 10 | -- This version requires the input to be an Ord type, and uses the <= operator to do the comparisons 11 | 12 | split :: [a] -> [[a]] 13 | split [] = [] 14 | split (x:xs) = [x] : split xs 15 | 16 | merge :: Ord a => [a] -> [a] -> [a] 17 | merge [] b = b 18 | merge a [] = a 19 | merge a@(x:xs) b@(y:ys) = 20 | if x <= y 21 | then x : (merge xs b) 22 | else y : (merge a ys) 23 | 24 | mergePairs :: Ord a => [[a]] -> [[a]] 25 | mergePairs [] = [] 26 | mergePairs x@[l] = x -- ie [l] 27 | mergePairs (l1:l2:ls) = ((:) $! (merge l1 l2)) (mergePairs ls) 28 | 29 | mergeSort :: Ord a => [a] -> [a] 30 | mergeSort xs = ms (split xs) 31 | where 32 | ms [] = [] 33 | ms [x] = x 34 | ms xs = ms (mergePairs xs) 35 | 36 | 37 | -- MERGESORT TAKING COMPARISON FUNCTION 38 | -- This version takes the comparison operator as an input 39 | 40 | merge' :: (a -> a -> Bool) -> [a] -> [a] -> [a] 41 | merge' _ [] b = b 42 | merge' _ a [] = a 43 | merge' before a@(x:xs) b@(y:ys) = 44 | if x `before` y 45 | then x : (merge' before xs b) 46 | else y : (merge' before a ys) 47 | 48 | mergePairs' :: (a -> a -> Bool) -> [[a]] -> [[a]] 49 | mergePairs' _ [] = [] 50 | mergePairs' _ x@[l] = x -- ie [l] 51 | mergePairs' before (l1:l2:ls) = ((:) $! (merge' before l1 l2)) (mergePairs' before ls) 52 | 53 | mergeSort' :: (a -> a -> Bool) -> [a] -> [a] 54 | mergeSort' before xs = ms' (split xs) 55 | where 56 | ms' [] = [] 57 | ms' [x] = x 58 | ms' xs = ms' (mergePairs' before xs) 59 | -------------------------------------------------------------------------------- /NumberTheoryFundamentals.hs: -------------------------------------------------------------------------------- 1 | -- numbertheoryfundamentals.hs 2 | 3 | module NumberTheoryFundamentals where 4 | 5 | -- Ch 1 of Cohen, A Course in Computational Algebraic Number Theory 6 | 7 | 8 | import Bits (shiftL, shiftR) 9 | import RandomGenerator (randomInteger) -- for sqrts mod p 10 | 11 | 12 | -- BASICS 13 | 14 | d `divides` n = n `mod` d == 0 15 | 16 | 17 | -- splitWith :: Integer -> Integer -> (Int, Integer) 18 | -- n `splitWith` p = (s,t), where n = p^s * t 19 | n `splitWith` p = doSplitWith 0 n 20 | where doSplitWith s t 21 | | p `divides` t = doSplitWith (s+1) (t `div` p) 22 | | otherwise = (s, t) 23 | 24 | 25 | -- calculate x^n in a (semi)group 26 | power (idG,multG) x n = doPower idG x n 27 | where 28 | doPower y _ 0 = y 29 | doPower y x n = 30 | let y' = if odd n then (y `multG` x) else y 31 | x' = x `multG` x 32 | n' = n `div` 2 33 | in doPower y' x' n' 34 | 35 | 36 | -- EXTENDED EUCLID 37 | 38 | -- extendedEuclid a b returns (u,v,d) such that u*a + v*b = d 39 | 40 | extendedEuclid a b | a >= 0 && b >= 0 = extendedEuclid' a b 41 | 42 | extendedEuclid' a b = doExtendedEuclid a b [] 43 | where 44 | doExtendedEuclid d 0 qs = let (u,v) = unwind 1 0 qs in (u,v,d) 45 | doExtendedEuclid a b qs = let (q,r) = quotRem a b in doExtendedEuclid b r (q:qs) 46 | unwind u v [] = (u,v) 47 | unwind u v (q:qs) = unwind v (u-v*q) qs 48 | 49 | 50 | -- from Cohen, p16 51 | -- appears to be slightly slower than the above 52 | extendedEuclidCohen d 0 | d > 0 = (1,0,d) 53 | extendedEuclidCohen a b | a >= 0 && b >= 0 = doExtendedEuclid a b a 1 0 b 54 | where 55 | doExtendedEuclid a b d u _ 0 = (u, (d-a*u) `div` b, d) 56 | doExtendedEuclid a b d u v1 v3 = 57 | let 58 | (q,t3) = quotRem d v3 59 | t1 = u - q * v1 60 | in doExtendedEuclid a b v3 v1 t1 t3 61 | 62 | 63 | 64 | -- INTEGER SQUARE ROOT 65 | 66 | intSqrt :: Integer -> Integer 67 | intSqrt 0 = 0 68 | intSqrt n = newtonianIteration n (findx0 n 1) 69 | where 70 | -- find x0 == 2^(a+1), such that 4^a <= n < 4^(a+1). 71 | findx0 a b = if a == 0 then b else findx0 (a `shiftR` 2) (b `shiftL` 1) 72 | newtonianIteration n x = 73 | let x' = (x + n `div` x) `div` 2 74 | in if x' < x then newtonianIteration n x' else x 75 | 76 | 77 | 78 | minus1to n = if even n then 1 else -1 79 | 80 | 81 | -- LEGENDRE SYMBOL 82 | 83 | -- from Koblitz, A Course in Number Theory and Cryptography 47-8 84 | -- see also Cohen p29,30 85 | 86 | -- Legendre symbol, via Jacobi symbol 87 | -- returns 0 if p divides a, 1 if a is a square mod p, -1 if a is not a square mod p 88 | legendreSymbol a p | p > 0 && odd p = legendreSymbol' a p 89 | legendreSymbol a 2 = a `mod` 2 90 | 91 | -- strictly speaking, legendreSymbol is only defined for odd p 92 | -- we define it for p == 2 as a convenience 93 | -- !! note that in some applications you should use the Kronecker symbol instead, which gives a *different* answer for p == 2 94 | 95 | legendreSymbol' a p = if a' == 0 then 0 else twoSymbol * oddSymbol 96 | where 97 | a' = a `mod` p -- hence a' >= 0 98 | (s,q) = a' `splitWith` 2 -- a' == 2^s * q, hence (a'/p) == (2/p)^s * (q/p) 99 | twoSymbol = if (p `mod` 8) `elem` [1,7] then 1 else minus1to s -- (2/p) == (-1)^((p^2-1)/8), p odd 100 | oddSymbol = if q == 1 then 1 else qrMultiplier * legendreSymbol' p q 101 | qrMultiplier = if p `mod` 4 == 3 && q `mod` 4 == 3 then -1 else 1 -- == (-1)^((p-1)*(q-1)/4), p, q odd 102 | -- a slight optimisation would be to use .&. 7 an .&. 3 instead of `mod` 8 and `mod` 4 103 | 104 | legendreSymbolTest a p = 105 | if p `divides` a 106 | then 0 107 | else if or [(x*x-a) `mod` p == 0 | x <- [1..p `div` 2]] then 1 else -1 108 | -- !! brute force method - for testing purposes only 109 | 110 | 111 | -- KRONECKER SYMBOL 112 | 113 | -- Cohen p28 114 | 115 | kroneckerSymbol a 0 = if a `elem` [-1,1] then 1 else 0 116 | kroneckerSymbol a b = kroneckerSign * kroneckerTwo * kroneckerOdd 117 | where 118 | (b2s,bOdd) = (abs b) `splitWith` 2 119 | kroneckerSign = if b < 0 && a < 0 then -1 else 1 120 | kroneckerTwo 121 | | even a = if b2s == 0 then 1 else 0 -- (a/2) == 0, a even 122 | | odd a = if (a `mod` 8) `elem` [1,7] then 1 else minus1to b2s -- (a/2) == (-1)^((a^2-1)/8), a odd 123 | kroneckerOdd 124 | | bOdd == 1 = 1 125 | | otherwise = legendreSymbol' a bOdd 126 | 127 | -- Cohen p29 has an algorithm which may be faster 128 | 129 | 130 | -- SQRTS MOD P 131 | 132 | -- based on Cohen p32-3 133 | -- note that this implementation is poor when p-1 is divisible by a large power of 2 134 | -- Koblitz, A Course in Number Theory and Cryptography, 48-9, explains how to fix this (so does Cohen, but rather incomprehensibly) 135 | 136 | sqrtsmodp a p = sqrtsmodp' (a `mod` p) p 137 | 138 | sqrtsmodp' 0 _ = [0] 139 | sqrtsmodp' 1 2 = [1] 140 | sqrtsmodp' a p = 141 | let 142 | (e,q) = (p-1) `splitWith` 2 143 | z = findSylow2Generator q 144 | zpowers = take (2^(e-1)) (iterate (\(z_k,z_2k)->(z * z_k `mod` p ,z * z * z_2k `mod` p)) (1,1)) 145 | a_q = power (1, \x y -> x*y `mod` p) a q -- powerMod p a q 146 | in case (filter (\(_,z_2k) -> a_q * z_2k `mod` p == 1) zpowers) of 147 | [] -> [] 148 | (z_k,_):_ -> let x = power (1, \x y -> x*y `mod` p) a ((q+1) `div` 2) * z_k `mod` p in ascendingPair [x,p-x] 149 | -- (z_k,_):_ -> let x = powerMod p a ((q+1) `div` 2) * z_k `mod` p in ascendingPair [x,p-x] 150 | where 151 | findSylow2Generator q = 152 | let nonresidue = head [n | (n,_) <- iterate (\(_,seed) -> randomInteger p seed) (0,342349871), legendreSymbol n p == -1] 153 | in power (1, \x y -> x*y `mod` p) nonresidue q -- powerMod p nonresidue q 154 | 155 | ascendingPair [x,y] = if x < y then [x,y] else [y,x] 156 | 157 | sqrtsmodptest a p = [x | x <- [0..p-1], (x*x-a) `mod` p == 0] 158 | -------------------------------------------------------------------------------- /Primes.hs: -------------------------------------------------------------------------------- 1 | -- primes.hs 2 | 3 | module Primes (primesTo100, primesTo10000, isPrime, nextPrime, 4 | primePowerFactors, -- primeFactors, 5 | fromPrimePowerFactors, isMillerRabinPrime, 6 | isSquareFree, isPrimePower) where 7 | 8 | 9 | import NumberTheoryFundamentals (divides, splitWith, power) 10 | import FF 11 | 12 | 13 | -- sieve of Eratosthenes - much slower than below 14 | primesTo10000' = doPrimesTo10000 (2:[3,5..10000]) 15 | where 16 | doPrimesTo10000 (p:ps) = p : doPrimesTo10000 (filter (\n -> not (p `divides` n)) ps) 17 | doPrimesTo10000 [] = [] 18 | 19 | primes = sieve [2..] 20 | where sieve (p:ns) = p : sieve (filter (notdiv p) ns) 21 | notdiv p n = n `mod` p /= 0 22 | 23 | 24 | -- PRIMES 25 | 26 | primesTo100 :: [Integer] 27 | primesTo100 = [2,3,5,7,11,13,17,19,23,29,31,37,41,43,47,53,59,61,67,71,73,79,83,89,97] 28 | 29 | trialDivision ps n = doTrialDivision ps 30 | where doTrialDivision (p:ps) = let (q,r) = n `quotRem` p in if r == 0 then False else if q < p then True else doTrialDivision ps 31 | doTrialDivision [] = True 32 | -- q < p => p > sqrt n 33 | 34 | primesTo10000 = primesTo100 ++ filter (trialDivision primesTo100) [101,103..9999] 35 | 36 | isTrialDivisionPrime 2 = True -- special case, not caught by above code 37 | isTrialDivisionPrime n = trialDivision (primesTo10000 ++ [10001,10003..]) n 38 | 39 | 40 | -- MILLER-RABIN TEST 41 | -- Cohen, A Course in Computational Algebraic Number Theory 42 | -- Koblitz, A Course in Number Theory and Cryptography 43 | 44 | 45 | -- Let n-1 = 2^s * t 46 | -- Then n is a strong pseudoprime to base b if 47 | -- either b^t == 1 (mod n) 48 | -- or b^(2^r * t) == -1 (mod n) for some 0 <= r < s 49 | -- (For we know that if n is prime, then b^(n-1) == 1 (mod n) 50 | 51 | isStrongPseudoPrime :: Integer -> (Int,Integer) -> Integer -> Bool 52 | -- call with n the modulus, (s,t) such that 2^s * t == n-1, b the base 53 | -- (s,t) then used internally for iteration 54 | isStrongPseudoPrime n (s,t) b = 55 | -- let b' = powerMod n b t 56 | let b' = power (1, \x y -> x*y `mod` n) b t 57 | in if b' == 1 then True else doSquaring s b' 58 | where 59 | doSquaring 0 x = False 60 | doSquaring s x 61 | | x == n-1 = True 62 | | x == 1 = False 63 | | otherwise = doSquaring (s-1) (x*x `mod` n) 64 | 65 | -- this is my own variant on the Miller-Rabin test 66 | -- the Rabin test involves selecting random bases b and checking that p is a strong pseudoprime to that base 67 | -- if p passes the strong pseudoprime test for k bases, the probability of a false positive is 4^-k. 68 | -- Rather than using random bases, I simply use the first 25 primes 69 | 70 | isMillerRabinPrime :: Integer -> Bool 71 | isMillerRabinPrime n 72 | | n < 100 = n `elem` primesTo100 -- the test below would not be valid 73 | | otherwise = all (isStrongPseudoPrime n (s,t)) primesTo100 74 | where (s,t) = (n-1) `splitWith` 2 -- so n-1 == 2^s * t 75 | 76 | -- to test the algorithm, following set should be empty (replace numbers as required) 77 | -- [n | n<-[100000..101000], isTrialDivisionPrime n /= isMillerRabinPrime n] 78 | 79 | 80 | isPrime :: Integer -> Bool 81 | isPrime n 82 | | n < 2 = False 83 | | n < 500000000 = isTrialDivisionPrime n 84 | | n >= 500000000 = isMillerRabinPrime n 85 | -- 5*10^8 appears to be about the point at which on average Miller Rabin becomes faster than trial division 86 | 87 | 88 | nextPrime :: Integer -> Integer 89 | nextPrime n = head [p | p <- [n..], isPrime p] 90 | 91 | 92 | 93 | 94 | smallMersennePrimes = map (\p -> 2^p-1) [2,3,5,7,13,17,19,31,61,89,107,127] 95 | -- useful in testing 96 | 97 | 98 | 99 | -- FACTORING (SMALL PRIMES) 100 | 101 | -- Factoring by trial division of primes up to 10000 102 | 103 | primePowerFactors :: Integer -> [(Integer,Int)] 104 | primePowerFactors n | n > 0 = takeOutFactors n primesTo10000 105 | where 106 | takeOutFactors n (p:ps) 107 | -- | n == 1 = [] -- unnecessary, caught by following test 108 | | p*p > n = finish n 109 | | otherwise = 110 | let (s,n') = n `splitWith` p 111 | in if s > 0 then (p,s) : takeOutFactors n' ps else takeOutFactors n ps 112 | takeOutFactors n [] = finish n 113 | finish 1 = [] 114 | finish n = 115 | if n < 100000000 || isMillerRabinPrime n -- we already know it's a trial division prime up to 10000 116 | then [(n,1)] 117 | else error ("primePowerFactors: unable to factor " ++ show n) 118 | 119 | 120 | -- !! what's the point of this 121 | primeFactors :: Integer -> [Integer] 122 | primeFactors n = concat (map (\(p,a) -> replicate a p) (primePowerFactors n)) 123 | -- it would probably be slightly faster to do this directly 124 | 125 | fromPrimePowerFactors :: [(Integer,Int)] -> Integer 126 | fromPrimePowerFactors factors = product [p^a | (p,a) <- factors] 127 | 128 | 129 | 130 | -- SIMPLE APPLICATIONS 131 | 132 | isSquareFree n = all (\(p,a)-> a == 1) (primePowerFactors n) 133 | 134 | isPrimePower n = length (primePowerFactors n) == 1 135 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Haskell math for Primes, Factorization, and the first few problems of Project Euler 2 | 3 | 6 years ago I started learning Haskell 4 | This is a collection of programs I did while solving Project Euler problems and also programming praxis exercises 5 | I often far beyond what was asked to optimize compute time 6 | 7 | What you will find : 8 | * For primes : 9 | * Prime Generation 10 | * Sieve of Atkin, speed comparable to C ([primegen 0.97](https://cr.yp.to/primegen.html) and [primesieve v4.0](primesieve.org)) 11 | * Sieve of Erathosthene 12 | * Trial division 13 | * Factoring Function including 14 | * Trial division 15 | * Continued Fraction Canditates method 16 | * Elliptic Curve Factorization method (non-finished) 17 | * Random Function 18 | * Miller-Rabin Primality test 19 | * Helper Functions 20 | * Merge Sort 21 | * Matrix 22 | * Scalar Multiplication 23 | * Polynomial Multiplication 24 | * dot product 25 | * tensor product 26 | * Matrix product 27 | * scalar Multiplication 28 | * Number Theory 29 | * x^n in a (semi)group 30 | * Diophantine ? (see extended Euclide) 31 | * Integer square root 32 | * Modulo square root 33 | * Modulo Exponentiation 34 | * Legendre symbol 35 | * Kronecker Symbol 36 | * Arithmetic Function 37 | * Euler Totient 38 | * Moebius 39 | * Sigma Function 40 | * Harmonic Function 41 | 42 | Unfortunately I probably lost the actual code used in Project Euler and other stuff like Pollard p-1, and pollard rho factorization methods 43 | 44 | ## List of solved problems 45 | 1. Add all the natural numbers below 1000 that are multiples of 3 or 5. 46 | 2. Find the sum of all the even-valued terms in the Fibonacci sequence which do not exceed one million. 47 | 3. Find the largest prime factor of 600851475143. 48 | 4. Find the largest palindrome made from the product of two 3-digit numbers. 49 | 5. What is the smallest number divisible by each of the numbers 1 to 20? 50 | 6. What is the difference between the sum of the squares and the square of the sums? 51 | 7. Find the 10001st prime. 52 | 8. Discover the largest product of thirteen consecutive digits in the 1000-digit number. 53 | 9. There is only one Pythagorean triplet, {a, b, c}, for which a + b + c = 1000. Find the product abc. 54 | 10. Calculate the sum of all the primes below one million. 55 | 56 | ** ** 57 | 12. What is the first triangle number to have over five-hundred divisors? 58 | 13. Find the first ten digits of the sum of one-hundred 50-digit numbers. 59 | 14. Find the longest sequence using a starting number under one million. 60 | 15. Starting in the top left corner in a 20 by 20 grid, how many routes are there to the bottom right corner? 61 | 16. What is the sum of the digits of the number 21000? 62 | 63 | ** ** 64 | 19. You are given the following information, but you may prefer to do some research for yourself. 65 | 66 | 1 Jan 1900 was a Monday. 67 | Thirty days has September, 68 | April, June and November. 69 | All the rest have thirty-one, 70 | Saving February alone, 71 | Which has twenty-eight, rain or shine. And on leap years, twenty-nine. 72 | 73 | A leap year occurs on any year evenly divisible by 4, but not on a century unless it is divisible by 400. 74 | How many Sundays fell on the first of the month during the twentieth century (1 Jan 1901 to 31 Dec 2000)? 75 | 76 | ** ** 77 | 20. Find the sum of digits in 100! 78 | 79 | ** ** 80 | 25. The Fibonacci sequence is defined by the recurrence relation: 81 | 82 | Fn = Fn−1 + Fn−2, where F1 = 1 and F2 = 1. 83 | Hence the first 12 terms will be: 84 | 85 | F1 = 1 86 | F2 = 1 87 | F3 = 2 88 | F4 = 3 89 | F5 = 5 90 | F6 = 8 91 | F7 = 13 92 | F8 = 21 93 | F9 = 34 94 | F10 = 55 95 | F11 = 89 96 | F12 = 144 97 | The 12th term, F12, is the first term to contain three digits. 98 | 99 | What is the index of the first term in the Fibonacci sequence to contain 1000 digits? 100 | 101 | ** ** 102 | 27. Euler discovered the remarkable quadratic formula: 103 | 104 | n^2+n+41 105 | 106 | It turns out that the formula will produce 40 primes for the consecutive integer values 0≤n≤390≤n≤39. However, when n=40,402+40+41=40(40+1)+41n=40,402+40+41=40(40+1)+41 is divisible by 41, and certainly when n=41,412+41+41n=41,412+41+41 is clearly divisible by 41. 107 | 108 | The incredible formula n^2−79n+1601 was discovered, which produces 80 primes for the consecutive values 0≤n≤790≤n≤79. The product of the coefficients, −79 and 1601, is −126479. 109 | 110 | Considering quadratics of the form: 111 | 112 | n^2+an+b, where |a|<1000|a|<1000 and |b|≤1000|b|≤1000 113 | 114 | where |n||n| is the modulus/absolute value of nn 115 | e.g. |11|=11|11|=11 and |−4|=4|−4|=4 116 | Find the product of the coefficients, aa and bb, for the quadratic expression that produces the maximum number of primes for consecutive values of nn, starting with n=0n=0. 117 | 118 | 119 | ** ** 120 | 29. Consider all integer combinations of ab for 2 ≤ a ≤ 5 and 2 ≤ b ≤ 5: 121 | 122 | 2^2=4, 2^3=8, 2^4=16, 2^5=32 123 | 3^2=9, 3^3=27, 3^4=81, 3^5=243 124 | 4^2=16, 4^3=64, 4^4=256, 4^5=1024 125 | 5^2=25, 5^3=125, 5^4=625, 5^5=3125 126 | If they are then placed in numerical order, with any repeats removed, we get the following sequence of 15 distinct terms: 127 | 128 | 4, 8, 9, 16, 25, 27, 32, 64, 81, 125, 243, 256, 625, 1024, 3125 129 | 130 | How many distinct terms are in the sequence generated by ab for 2 ≤ a ≤ 100 and 2 ≤ b ≤ 100? 131 | 132 | 133 | ** ** 134 | 48. The series, 1^1 + 2^2 + 3^3 + ... + 10^10 = 10405071317. 135 | 136 | Find the last ten digits of the series, 1^1 + 2^2 + 3^3 + ... + 1000^1000. 137 | -------------------------------------------------------------------------------- /RandomGenerator.hs: -------------------------------------------------------------------------------- 1 | -- randomgenerator.hs 2 | 3 | module RandomGenerator where 4 | 5 | import Bits (shiftL, shiftR, testBit) 6 | 7 | -- !! WARNING 8 | -- If using this code in GHCi < 6.4.1, then compile using -fvia-c option 9 | 10 | one29 = 1 `shiftL` 29 :: Int 11 | 12 | -- Schneier, Applied Cryptography, p376 13 | bitGenerator :: Int -> (Int,Int) 14 | bitGenerator seed = 15 | let 16 | feedback = if (seed + seed `shiftR` 2 + seed `shiftR` 29) `testBit` 0 then one29 else 0 17 | seed' = seed `shiftR` 1 + feedback 18 | bit = if seed' `testBit` 0 then 1 else 0 19 | in (bit, seed') 20 | 21 | 22 | randomBitset :: Int -> Int -> (Integer,Int) 23 | randomBitset bitLength seed = doRandomBitset (bitLength, 0, seed) 24 | where 25 | doRandomBitset (0, n, seed) = (n,seed) 26 | doRandomBitset (bitLength, n, seed) = 27 | let (bit, seed') = bitGenerator seed 28 | in doRandomBitset $! (bitLength - 1, n `shiftL` 1 + toInteger bit, seed') 29 | 30 | randomInteger :: Integer -> Int -> (Integer, Int) 31 | randomInteger n seed 32 | | n <= 0 = error "randomInteger: n <= 0" 33 | | otherwise = doRandomInteger n (0,1,seed) 34 | where 35 | doRandomInteger n (i,m,seed) = 36 | if m >= n -- i is now a random integer between 0 and m-1, where m is a power of 2 37 | then 38 | if i < n 39 | then (i,seed) 40 | else (doRandomInteger n) $! (0,1,seed) -- we have to start again 41 | else 42 | let (bit,seed') = bitGenerator seed 43 | in (doRandomInteger n) $! (i `shiftL` 1 + toInteger bit, m `shiftL` 1, seed') 44 | 45 | 46 | randomInt :: Int -> Int -> (Int,Int) 47 | randomInt n seed 48 | | n <= 0 = error "randomInt: n <= 0" 49 | | otherwise = doRandomInt n (0,1,seed) 50 | where 51 | doRandomInt n (i,m,seed) = 52 | if m >= n -- i is now a random integer between 0 and m-1, where m is a power of 2 53 | then 54 | if i < n 55 | then (i,seed) 56 | else doRandomInt n (0,1,seed) -- we have to start again 57 | -- else (doRandomInt n) $! (0,1,seed) -- we have to start again 58 | else 59 | let (bit,seed') = bitGenerator seed 60 | in doRandomInt n (i `shiftL` 1 + bit, m `shiftL` 1, seed') 61 | -- in (doRandomInt n) $! (i `shiftL` 1 + bit, m `shiftL` 1, seed') 62 | 63 | two48 = fromInteger (2^48) :: Double 64 | 65 | random01 :: Int -> (Double,Int) 66 | random01 seed = 67 | let (n,seed') = randomBitset 48 seed 68 | -- in (fromInteger n / (fromInteger (2^48)), seed') 69 | in (fromInteger n / two48, seed') 70 | -- doubles appear to have a 49 bit mantissa 71 | 72 | 73 | 74 | -- NORMAL (GAUSSIAN) DISTRIBUTION 75 | 76 | -- returns two N(0,1) random variables 77 | -- Box-Muller algorithm, from Robert and Casella p62 78 | 79 | randomNormal01 seed = 80 | let 81 | (u1,seed') = random01 seed 82 | (u2,seed'') = random01 seed' 83 | u1' = 2 * u1 - 1 84 | u2' = 2 * u2 - 1 85 | s = u1' * u1' + u2' * u2' 86 | in 87 | if s <= 1 88 | then 89 | let z = sqrt (-2 * log s / s) 90 | in (z * u1', z * u2', seed'') 91 | else randomNormal01 seed'' 92 | 93 | 94 | -- FAST RANDOM (LOWER QUALITY) 95 | 96 | a = 8121 :: Int 97 | b = 28411 :: Int 98 | m = 134456 :: Int 99 | -- from Schneier p370 100 | -- won't overflow, since 134455 * 8121 + 28411 = 1091937466 < 2^31 101 | 102 | fastRandomInt :: Int -> Int -> (Int,Int) 103 | fastRandomInt n seed = 104 | let seed' = (a*seed+b) `mod` m 105 | in (seed' `mod` n, seed') 106 | 107 | 108 | -------------------------------------------------------------------------------- /atkin_vector.hs: -------------------------------------------------------------------------------- 1 | import System.Environment 2 | import Data.List 3 | import Control.Monad.State (forM_,when) 4 | import Control.Monad.Primitive (PrimState) 5 | import Control.Monad.ST 6 | import qualified Data.Vector.Unboxed.Mutable as VUM 7 | import qualified Data.Vector.Unboxed as VU 8 | 9 | main = do 10 | args <- getArgs 11 | let lim = read $ head args 12 | -- v <- (VUM.replicate lim False) >>= VU.unsafeFreeze >>= (return . VU.toList) 13 | -- print $ primes_dualfeed lim 14 | -- print $ (2:).(3:) $ VU.toList $ VU.elemIndices True $ candidates lim 15 | print $(2:).(3:). VU.toList $ VU.elemIndices True $ sieve $ candidates lim 16 | 17 | vecInv :: Int -> VU.Vector Bool -> VU.Vector Bool 18 | vecInv i v = runST $ do 19 | u <- VU.unsafeThaw v 20 | VUM.unsafeRead u i >>= (return.not) >>=(VUM.unsafeWrite u i) 21 | u <- VU.unsafeFreeze u 22 | return u 23 | 24 | 25 | isqrt = floor . sqrt . fromIntegral 26 | 27 | 28 | candidates limit = candidates' limit 1 [(x,y) | x <- [1..isqrt limit], y <- [1..isqrt limit]] 29 | $ (VU.replicate limit False) 30 | where candidates' _ _ [] bvec = bvec 31 | candidates' lim step ((x,y):xys) bvec 32 | | step ==1 && s1 <= lim && (m1 == 1 || m1 ==5) = candidates' lim 2 ((x,y):xys) (vecInv s1 bvec) 33 | | step ==1 = candidates' lim 2 ((x,y):xys) bvec 34 | | step ==2 && s2 <= lim && m2 == 7 = candidates' lim 3 ((x,y):xys) (vecInv s2 bvec) 35 | | step ==2 = candidates' lim 3 ((x,y):xys) bvec 36 | | step ==3 && s3 <= lim && x>y && m3 == 11 = candidates' lim 1 xys (vecInv s3 bvec) 37 | | otherwise = candidates' lim 1 xys bvec 38 | where 39 | s1 = 4*x*x + y*y 40 | s2 = 3*x*x + y*y 41 | s3 = 3*x*x - y*y 42 | m1 = s1 `rem` 12 43 | m2 = s2 `rem` 12 44 | m3 = s3 `rem` 12 45 | 46 | ------v3 ultrafast, low memory footprint 47 | removeSquares :: VU.MVector (PrimState (ST s)) Bool -> Int -> ST s () 48 | removeSquares v i = do 49 | forM_ [i*i,2*i*i..VUM.length v] $ \j -> do 50 | VUM.unsafeWrite v j False 51 | 52 | sieve vcand = runST $ do 53 | u <- VU.unsafeThaw vcand 54 | limn <- return (VUM.length u) >>= (return.isqrt) 55 | forM_ [0..limn] $ \i -> do 56 | VUM.unsafeRead u i >>= (flip when (removeSquares u i)) 57 | u <- VU.unsafeFreeze u 58 | return u 59 | 60 | 61 | {- 62 | ------v1 faster less memory 63 | primes_dualfeed lim = 2 : 3:((VU.toList $ VU.elemIndices True $ candidates lim) `minus` joinL [[p*p, 2*p*p..] | p <- primes']) 64 | where 65 | primes' = 3 : 5 : ((tail $ VU.toList $ VU.elemIndices True $ candidates lim) `minus` joinL [[p*p, 2*p*p..] | p <- primes']) 66 | 67 | joinL ((x:xs):t) = x : fuse xs (joinL t) 68 | 69 | minus (x:xs) (y:ys) = case (compare x y) of 70 | LT -> x : minus xs (y:ys) 71 | EQ -> minus xs ys 72 | GT -> minus (x:xs) ys 73 | minus xs _ = xs 74 | 75 | fuse (x:xs) (y:ys) = case (compare x y) of 76 | LT -> x : fuse xs (y:ys) 77 | EQ -> x : fuse xs ys 78 | GT -> y : fuse (x:xs) ys 79 | fuse xs [] = xs 80 | fuse [] ys = ys 81 | 82 | 83 | -----v2 a bit slower, 3x more memory usage 84 | squarefree _ [] = [] 85 | squarefree lim xs'@(x:xs) 86 | | x <= lim = (x:) . squarefree lim . mergeRemove xs 87 | . takeWhile (<=lim) $ [ k*x*x | k <- [1..] ] 88 | | otherwise = xs' 89 | 90 | mergeRemove [] ys = [] 91 | mergeRemove xs [] = xs 92 | mergeRemove xs'@(x:xs) ys'@(y:ys) 93 | = case compare x y of 94 | EQ -> mergeRemove xs ys 95 | LT -> x : mergeRemove xs ys' 96 | GT -> mergeRemove xs' ys-} 97 | -------------------------------------------------------------------------------- /eratosthene_tmws.hs: -------------------------------------------------------------------------------- 1 | import Data.List 2 | import System.Environment 3 | 4 | {-# OPTIONS_GHC -O2 -fno-cse #-} 5 | primesTMWE = 2:3:5:7: gapsW 11 wheel (joinT3 $ rollW 11 wheel primes') 6 | where 7 | primes' = 11: gapsW 13 (tail wheel) (joinT3 $ rollW 11 wheel primes') 8 | 9 | pairs ((x:xs):ys:t) = (x : union xs ys) : pairs t 10 | 11 | gapsW k ws@(w:t) cs@(c:u) | k==c = gapsW (k+w) t u 12 | | True = k : gapsW (k+w) t cs 13 | rollW k ws@(w:t) ps@(p:u) | k==p = scanl (\c d->c+p*d) (p*p) ws 14 | : rollW (k+w) t u 15 | | True = rollW (k+w) t ps 16 | joinT3 ((x:xs): ~(ys:zs:t)) = x : union xs (union ys zs) 17 | `union` joinT3 (pairs t) 18 | wheel = 2:4:2:4:6:2:6:4:2:4:6:6:2:6:4:2:6:4:6:8:4:2:4:2: 19 | 4:8:6:4:6:2:4:6:2:6:6:4:2:4:6:2:6:4:2:4:2:10:2:10:wheel 20 | 21 | main = do 22 | args <- getArgs 23 | let lim = read $ head args 24 | print $ takeWhile ( Integer -> Integer -> Integer 8 | expm b e m = foldl' (\r (b', _) -> mod (r * b') m) 1 . 9 | filter (flip testBit 0 . snd) . 10 | zip (iterate (flip mod m . (^ 2)) b) . 11 | takeWhile (> 0) $ iterate (`shiftR` 1) e 12 | 13 | rInteger :: String -> Integer 14 | rInteger = read 15 | 16 | 17 | main = do 18 | args <- getArgs 19 | let [a,b,c] = map rInteger args 20 | print $ expm a b c 21 | 22 | 23 | -- Explanation : 24 | -- takeWhile (> 0) $ iterate (`shiftR` 1) e 25 | -- -> Store the quotient of successive division by 2 of the exponent 26 | -- (flip mod m . (^ 2)) b 27 | -- -> Calculate mod (b^2) m equivalent to (b^2 `mod` m) 28 | -- ---> (flip mod m . (^ 2)) b = f(b) 29 | -- zip (iterate (flip mod m . (^ 2)) b) . takeWhile (> 0) $ iterate (`shiftR` 1) e 30 | -- ---> iterate [b,f b, f.f b, f.f.f b, ...] 31 | -- ---> successive squaring of b 32 | -- ---> zip [(b,e),(fb,e/2),(ffb,e/4),(fffb,e/8),...] 33 | -- ---> successive squaring of b until exponent is null 34 | -- filter (flip testBit 0 . snd) 35 | -- -> remove even number from list 36 | -- scanl g 1 [(a,b),(c,d),(e,f)] 37 | -- -> [g 1 (a,b), g (g 1 (a,b)) (c,d), g(g(g 1 (a,b)) (c,d)) (e,f))] 38 | -- foldl g 1 [(a,b),(c,d),(e,f)] 39 | -- -> g(g(g 1 (a,b)) (c,d)) (e,f)) 40 | -- ---> (\r (b', _) -> mod (r * b') m) z [(x,y)] 41 | -- -------> mod (z*x) m ; y is ignored 42 | 43 | {- 44 | Remco Niemeijer Says: 45 | May 2, 2009 at 11:13 pm | Reply 46 | 47 | The expm in my code is more complicated because I based it on the pseudocode in the wikipedia article on modular exponentiation, which is probably more appropriate for C than for Haskell. The expmod version in Codec.Encryption.RSA.NumberTheory uses the same algorithm you do, which is cleaner. It’s possible the one with bitshifting is slightly faster, but I can’t be sure without benchmarking. 48 | 49 | -} 50 | 51 | {- 52 | The following is an example in pseudocode based on Applied Cryptography by Bruce Schneier.[1] The inputs base, exponent, and modulus correspond to b, e, and m in the equations given above. 53 | 54 | function modular_pow(base, exponent, modulus) 55 | result := 1 56 | while exponent > 0 57 | if (exponent mod 2 == 1): 58 | result := (result * base) mod modulus 59 | exponent := exponent >> 1 60 | base = (base * base) mod modulus 61 | return result 62 | -} 63 | 64 | -------------------------------------------------------------------------------- /expmod_2.hs: -------------------------------------------------------------------------------- 1 | import Data.Bits 2 | import Data.List 3 | import System.Environment 4 | 5 | 6 | -- From Codec.Encryption.RSA.NumberTheory 7 | expmod :: Integer -> Integer -> Integer -> Integer 8 | expmod a x m | x == 0 = 1 9 | | x == 1 = a `mod` m 10 | | even x = let p = (expmod a (x `div` 2) m) `mod` m 11 | in (p^2) `mod` m 12 | | otherwise = (a * expmod a (x-1) m) `mod` m 13 | 14 | 15 | rInteger :: String -> Integer 16 | rInteger = read 17 | 18 | 19 | main = do 20 | args <- getArgs 21 | let [a,b,c] = map rInteger args 22 | print $ expmod a b c 23 | 24 | -- Stack overflow if b is negative --------------------------------------------------------------------------------