diff --git a/Changes b/Changes --- a/Changes +++ b/Changes @@ -1,3 +1,64 @@ +0.8.0.0 + This release supports GHC 7.10, 8.0, 8.2, 8.4 and 8.6. + + Breaking changes: + + Stop reporting units (1, -1, i, -i) as a part of factorisation + for integers and Gaussian integers (#101). Now `factorise (-2)` + is `[(2, 1)]` and not `[(-1, 1), (2, 1)]`. + + Deprecate an old interface of 'Math.NumberTheory.Moduli.Sqrt' + and roll out a new one, more robust and type safe (#87). + + Deprecate 'Math.NumberTheory.GCD' and 'Math.NumberTheory.GCD.LowLevel' (#80). + Use 'Math.NumberTheory.Euclidean' instead (#128). + Move 'splitIntoCoprimes' to 'Math.NumberTheory.Euclidean.Coprimes'. + + Change types of 'splitIntoCoprimes', 'fromFactors' and 'prefFactors' + using newtype 'Coprimes' (#89). + + Redesign API to modular square roots (#108) + + Deprecate 'jacobi'' (#103). + + Sort Gaussian primes by norm (#124). + + Deprecate 'Math.NumberTheory.GaussianIntegers' in favor of + 'Math.NumberTheory.Quadratic.GaussianIntegers'. + + New features: + + Implement Ramanujan tau function (#112): + + > map ramanujan [1..10] + [1,-24,252,-1472,4830,-6048,-16744,84480,-113643,-115920] + + Implement partition function (#115): + + > take 10 partition + [1,1,2,3,5,7,11,15,22,30] + + Add the Dirichlet beta function on non-negative integer arguments (#120). + E. g., + + > take 5 $ Math.NumberTheory.Zeta.Dirichlet.betas 1e-15 + [0.5,0.7853981633974483,0.9159655941772191,0.9689461462593693,0.9889445517411055] + + Solve linear and quadratic congruences (#129). + + Support Eisenstein integers (#121). + + Implement discrete logarithm (#88). + + Improvements: + + Make return type of 'primes' and 'primeList' polymorphic instead of + being limited to 'Integer' only (#109). + + Speed up factorisation of Gaussian integers (#116). + + Speed up computation of primitive roots for prime powers (#127). + 0.7.0.0 This release supports GHC 7.8, 7.10, 8.0, 8.2 and 8.4. diff --git a/Math/NumberTheory/ArithmeticFunctions/Class.hs b/Math/NumberTheory/ArithmeticFunctions/Class.hs --- a/Math/NumberTheory/ArithmeticFunctions/Class.hs +++ b/Math/NumberTheory/ArithmeticFunctions/Class.hs @@ -25,11 +25,6 @@ import Data.Semigroup #endif -#if MIN_VERSION_base(4,8,0) -#else -import Data.Word -#endif - import Math.NumberTheory.UniqueFactorisation -- | A typical arithmetic function operates on the canonical factorisation of diff --git a/Math/NumberTheory/ArithmeticFunctions/Mertens.hs b/Math/NumberTheory/ArithmeticFunctions/Mertens.hs --- a/Math/NumberTheory/ArithmeticFunctions/Mertens.hs +++ b/Math/NumberTheory/ArithmeticFunctions/Mertens.hs @@ -17,9 +17,6 @@ ) where import qualified Data.Vector.Unboxed as U -#if __GLASGOW_HASKELL__ < 709 -import Data.Word -#endif import Math.NumberTheory.Powers.Cubes import Math.NumberTheory.Powers.Squares @@ -27,8 +24,8 @@ -- | Compute individual values of Mertens function in O(n^(2/3)) time and space. -- --- > > map (mertens . (10 ^)) [0..9] --- > [1,-1,1,2,-23,-48,212,1037,1928,-222] +-- >>> map (mertens . (10 ^)) [0..9] +-- [1,-1,1,2,-23,-48,212,1037,1928,-222] -- -- The implementation follows Theorem 3.1 from by G. Hurst, excluding segmentation of sieves. mertens :: Word -> Int diff --git a/Math/NumberTheory/ArithmeticFunctions/Moebius.hs b/Math/NumberTheory/ArithmeticFunctions/Moebius.hs --- a/Math/NumberTheory/ArithmeticFunctions/Moebius.hs +++ b/Math/NumberTheory/ArithmeticFunctions/Moebius.hs @@ -126,8 +126,8 @@ -- -- Based on the sieving algorithm from p. 3 of by G. Hurst. It is approximately 5x faster than 'Math.NumberTheory.ArithmeticFunctions.SieveBlock.sieveBlockUnboxed'. -- --- > > sieveBlockMoebius 1 10 --- > [MoebiusP, MoebiusN, MoebiusN, MoebiusZ, MoebiusN, MoebiusP, MoebiusN, MoebiusZ, MoebiusZ, MoebiusP] +-- >>> sieveBlockMoebius 1 10 +-- [MoebiusP, MoebiusN, MoebiusN, MoebiusZ, MoebiusN, MoebiusP, MoebiusN, MoebiusZ, MoebiusZ, MoebiusP] sieveBlockMoebius :: Word -> Word diff --git a/Math/NumberTheory/ArithmeticFunctions/SieveBlock.hs b/Math/NumberTheory/ArithmeticFunctions/SieveBlock.hs --- a/Math/NumberTheory/ArithmeticFunctions/SieveBlock.hs +++ b/Math/NumberTheory/ArithmeticFunctions/SieveBlock.hs @@ -32,9 +32,6 @@ import qualified Data.Vector as V import qualified Data.Vector.Mutable as MV import GHC.Exts -#if __GLASGOW_HASKELL__ < 709 -import Data.Monoid -#endif import Math.NumberTheory.ArithmeticFunctions.Class import Math.NumberTheory.ArithmeticFunctions.Moebius (sieveBlockMoebius) @@ -58,8 +55,8 @@ -- -- This is a thin wrapper over 'sieveBlock', read more details there. -- --- > > runFunctionOverBlock carmichaelA 1 10 --- > [1,1,2,2,4,2,6,2,6,4] +-- >>> runFunctionOverBlock carmichaelA 1 10 +-- [1,1,2,2,4,2,6,2,6,4] runFunctionOverBlock :: ArithmeticFunction Word a -> Word @@ -82,8 +79,13 @@ -- -- For example, following code lists smallest prime factors: -- --- > > sieveBlock (SieveBlockConfig maxBound min (\p _ -> p) 2 10) --- > [2,3,2,5,2,7,2,3,2,11] +-- >>> sieveBlock (SieveBlockConfig maxBound (\p _ -> p) min) 2 10 +-- [2,3,2,5,2,7,2,3,2,11] +-- +-- And this is how to factorise all numbers in a block: +-- +-- >>> sieveBlock (SieveBlockConfig [] (\p k -> [(p,k)]) (++)) 2 10 +-- [[(2,1)],[(3,1)],[(2,2)],[(5,1)],[(2,1),(3,1)],[(7,1)],[(2,3)],[(3,2)],[(2,1),(5,1)],[(11,1)]] sieveBlock :: SieveBlockConfig a -> Word diff --git a/Math/NumberTheory/ArithmeticFunctions/SieveBlock/Unboxed.hs b/Math/NumberTheory/ArithmeticFunctions/SieveBlock/Unboxed.hs --- a/Math/NumberTheory/ArithmeticFunctions/SieveBlock/Unboxed.hs +++ b/Math/NumberTheory/ArithmeticFunctions/SieveBlock/Unboxed.hs @@ -76,8 +76,8 @@ -- -- For example, here is an analogue of divisor function 'tau': -- --- > > sieveBlockUnboxed (SieveBlockConfig 1 (*) (\_ a -> a + 1) 1 10) --- > [1,2,2,3,2,4,2,4,3,4] +-- >>> sieveBlockUnboxed (SieveBlockConfig 1 (\_ a -> a + 1) (*)) 1 10 +-- [1,2,2,3,2,4,2,4,3,4] sieveBlockUnboxed :: V.Unbox a => SieveBlockConfig a diff --git a/Math/NumberTheory/ArithmeticFunctions/Standard.hs b/Math/NumberTheory/ArithmeticFunctions/Standard.hs --- a/Math/NumberTheory/ArithmeticFunctions/Standard.hs +++ b/Math/NumberTheory/ArithmeticFunctions/Standard.hs @@ -26,6 +26,7 @@ , sigma, sigmaA , totient, totientA , jordan, jordanA + , ramanujan, ramanujanA , moebius, moebiusA, Moebius(..), runMoebius , liouville, liouvilleA -- * Additive functions @@ -51,12 +52,6 @@ import Numeric.Natural -#if MIN_VERSION_base(4,8,0) -#else -import Data.Foldable -import Data.Word -#endif - -- | Create a multiplicative function from the function on prime's powers. See examples below. multiplicative :: Num a => (Prime n -> Word -> a) -> ArithmeticFunction n a multiplicative f = ArithmeticFunction ((Product .) . f) getProduct @@ -154,6 +149,27 @@ jordanHelper pa 2 = (pa - 1) * pa jordanHelper pa k = (pa - 1) * pa ^ wordToInt (k - 1) {-# INLINE jordanHelper #-} + +ramanujan :: Integer -> Integer +ramanujan = runFunction ramanujanA + +-- | Calculates the +-- of a positive number @n@, using formulas given +ramanujanA :: ArithmeticFunction Integer Integer +ramanujanA = multiplicative $ \(unPrime -> p) -> ramanujanHelper p + +ramanujanHelper :: Integer -> Word -> Integer +ramanujanHelper _ 0 = 1 +ramanujanHelper 2 1 = -24 +ramanujanHelper p 1 = (65 * sigmaHelper (p ^ (11 :: Int)) 1 + 691 * sigmaHelper (p ^ (5 :: Int)) 1 - 691 * 252 * 2 * sum [sigma 5 k * sigma 5 (p-k) | k <- [1..(p `quot` 2)]]) `quot` 756 +ramanujanHelper p k = sum $ zipWith3 (\a b c -> a * b * c) paPowers tpPowers binomials + where pa = p ^ (11 :: Int) + tp = ramanujanHelper p 1 + paPowers = iterate (* (-pa)) 1 + binomials = scanl (\acc j -> acc * (k' - 2 * j) * (k' - 2 * j - 1) `quot` (k' - j) `quot` (j + 1)) 1 [0 .. k' `quot` 2 - 1] + k' = fromIntegral k + tpPowers = reverse $ take (length binomials) $ iterate (* tp^(2::Int)) (if even k then 1 else tp) +{-# INLINE ramanujanHelper #-} moebius :: UniqueFactorisation n => n -> Moebius moebius = runFunction moebiusA diff --git a/Math/NumberTheory/Curves/Montgomery.hs b/Math/NumberTheory/Curves/Montgomery.hs --- a/Math/NumberTheory/Curves/Montgomery.hs +++ b/Math/NumberTheory/Curves/Montgomery.hs @@ -33,10 +33,11 @@ import Data.Proxy import GHC.Exts -import GHC.Integer.GMP.Internals import GHC.Integer.Logarithms import GHC.TypeNats.Compat +import Math.NumberTheory.Utils (recipMod) + -- | We use the Montgomery form of elliptic curve: -- b Y² = X³ + a X² + X (mod n). -- See Eq. (10.3.1.1) at p. 260 of by P. L. Montgomery. @@ -90,9 +91,7 @@ -- by K. Gaj, S. Kwon et al. newPoint :: Integer -> Integer -> Maybe SomePoint newPoint s n = do - a24denRecip <- case recipModInteger a24den n of - 0 -> Nothing - t -> Just t + a24denRecip <- recipMod a24den n a24 <- case a24num * a24denRecip `rem` n of -- (a+2)/4 = 0 corresponds to singular curve with A = -2 0 -> Nothing diff --git a/Math/NumberTheory/Euclidean.hs b/Math/NumberTheory/Euclidean.hs new file mode 100644 --- /dev/null +++ b/Math/NumberTheory/Euclidean.hs @@ -0,0 +1,165 @@ +-- | +-- Module: Math.NumberTheory.Euclidean +-- Copyright: (c) 2018 Alexandre Rodrigues Baldé +-- Licence: MIT +-- Maintainer: Alexandre Rodrigues Baldé +-- Stability: Provisional +-- Portability: Non-portable (GHC extensions) +-- +-- This module exports a class to represent Euclidean domains. +-- + +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Math.NumberTheory.Euclidean + ( Euclidean(..) + , WrappedIntegral(..) + ) where + +import Prelude hiding (divMod, div, gcd, lcm, mod, quotRem, quot, rem) +import qualified Prelude as P + +import GHC.Exts +import GHC.Integer.GMP.Internals +import Numeric.Natural + +-- | A class to represent a Euclidean domain, +-- which is basically an 'Integral' without 'toInteger'. +class (Eq a, Num a) => Euclidean a where + -- | When restriced to a subring of the Euclidean domain @a@ isomorphic to + -- @Integer@, this function should match @quotRem@ for Integers. + quotRem :: a -> a -> (a, a) + -- | When restriced to a subring of the Euclidean domain @a@ isomorphic to + -- @Integer@, this function should match @divMod@ for Integers. + divMod :: a -> a -> (a, a) + + quot :: a -> a -> a + quot x y = fst (quotRem x y) + + rem :: a -> a -> a + rem x y = snd (quotRem x y) + + div :: a -> a -> a + div x y = fst (divMod x y) + + mod :: a -> a -> a + mod x y = snd (divMod x y) + + -- | @'gcd' x y@ is the greatest number that divides both @x@ and @y@. + gcd :: a -> a -> a + gcd x y = gcd' (abs x) (abs y) + where + gcd' :: a -> a -> a + gcd' a 0 = a + gcd' a b = gcd' b (abs (a `mod` b)) + + -- | @'lcm' x y@ is the smallest number that both @x@ and @y@ divide. + lcm :: a -> a -> a + lcm _ 0 = 0 + lcm 0 _ = 0 + lcm x y = abs ((x `quot` (gcd x y)) * y) + + -- | Test whether two numbers are coprime . + coprime :: a -> a -> Bool + coprime x y = gcd x y == 1 + + -- | Calculate the greatest common divisor of two numbers and coefficients + -- for the linear combination. + -- + -- For signed types satisfies: + -- + -- > case extendedGCD a b of + -- > (d, u, v) -> u*a + v*b == d + -- > && d == gcd a b + -- + -- For unsigned and bounded types the property above holds, but since @u@ and @v@ must also be unsigned, + -- the result may look weird. E. g., on 64-bit architecture + -- + -- > extendedGCD (2 :: Word) (3 :: Word) == (1, 2^64-1, 1) + -- + -- For unsigned and unbounded types (like 'Numeric.Natural.Natural') the result is undefined. + -- + -- For signed types we also have + -- + -- > abs u < abs b || abs b <= 1 + -- > + -- > abs v < abs a || abs a <= 1 + -- + -- (except if one of @a@ and @b@ is 'minBound' of a signed type). + extendedGCD :: a -> a -> (a, a, a) + extendedGCD a b = (d, x * signum a, y * signum b) + where + (d, x, y) = eGCD 0 1 1 0 (abs a) (abs b) + eGCD !n1 o1 !n2 o2 r s + | s == 0 = (r, o1, o2) + | otherwise = case r `quotRem` s of + (q, t) -> eGCD (o1 - q*n1) n1 (o2 - q*n2) n2 s t + +coprimeIntegral :: Integral a => a -> a -> Bool +coprimeIntegral x y = (odd x || odd y) && P.gcd x y == 1 + +-- | Wrapper around 'Integral', which has an 'Eucledian' instance. +newtype WrappedIntegral a = WrappedIntegral { unWrappedIntegral :: a } + deriving (Eq, Ord, Show, Num, Integral, Real, Enum) + +instance Integral a => Euclidean (WrappedIntegral a) where + quotRem = P.quotRem + divMod = P.divMod + quot = P.quot + rem = P.rem + div = P.div + mod = P.mod + gcd = P.gcd + lcm = P.lcm + coprime = coprimeIntegral + +instance Euclidean Int where + quotRem = P.quotRem + divMod = P.divMod + quot = P.quot + rem = P.rem + div = P.div + mod = P.mod + gcd (I# x) (I# y) = I# (gcdInt x y) + lcm = P.lcm + coprime = coprimeIntegral + +instance Euclidean Word where + quotRem = P.quotRem + divMod = P.divMod + quot = P.quot + rem = P.rem + div = P.div + mod = P.mod + gcd (W# x) (W# y) = W# (gcdWord x y) + lcm = P.lcm + coprime = coprimeIntegral + +instance Euclidean Integer where + quotRem = P.quotRem + divMod = P.divMod + quot = P.quot + rem = P.rem + div = P.div + mod = P.mod + gcd = gcdInteger + lcm = lcmInteger + coprime = coprimeIntegral + -- Blocked by GHC bug + -- https://ghc.haskell.org/trac/ghc/ticket/15350 + -- extendedGCD = gcdExtInteger + +instance Euclidean Natural where + quotRem = P.quotRem + divMod = P.divMod + quot = P.quot + rem = P.rem + div = P.div + mod = P.mod + gcd = P.gcd + lcm = P.lcm + coprime = coprimeIntegral diff --git a/Math/NumberTheory/Euclidean/Coprimes.hs b/Math/NumberTheory/Euclidean/Coprimes.hs new file mode 100644 --- /dev/null +++ b/Math/NumberTheory/Euclidean/Coprimes.hs @@ -0,0 +1,124 @@ +-- | +-- Module: Math.NumberTheory.Euclidean.Coprimes +-- Copyright: (c) 2017-2018 Andrew Lelechenko +-- Licence: MIT +-- Maintainer: Andrew Lelechenko +-- +-- Container for pairwise coprime numbers. + +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Math.NumberTheory.Euclidean.Coprimes + ( splitIntoCoprimes + , Coprimes + , unCoprimes + , singleton + , insert + ) where + +import Prelude hiding (gcd, quot, rem) +import Data.Coerce +import Data.List (tails, mapAccumL) +#if __GLASGOW_HASKELL__ < 803 +import Data.Semigroup +#endif + +import Math.NumberTheory.Euclidean + +-- | A list of pairwise coprime numbers +-- with their multiplicities. +newtype Coprimes a b = Coprimes { + unCoprimes :: [(a, b)] -- ^ Unwrap. + } + deriving (Eq, Show) + +doPair :: (Euclidean a, Eq b, Num b) => a -> b -> a -> b -> (a, a, [(a, b)]) +doPair x xm y ym = case gcd x y of + 1 -> (x, y, []) + g -> (x', y', concat rests) + where + (x', g', xgs) = doPair (x `quot` g) xm g (xm + ym) + xgs' = if g' == 1 then xgs else ((g', xm + ym) : xgs) + + (y', rests) = mapAccumL go (y `quot` g) xgs' + go w (t, tm) = (w', if t' == 1 then acc else (t', tm) : acc) + where + (w', t', acc) = doPair w ym t tm + +_propDoPair :: (Euclidean a, Integral b) => a -> b -> a -> b -> Bool +_propDoPair x xm y ym + = x `rem` x' == 0 + && y `rem` y' == 0 + && coprime x' y' + && all (coprime x') (map fst rest) + && all (coprime y') (map fst rest) + && all (/= 1) (map fst rest) + && and [ coprime s t | (s, _) : ts <- tails rest, (t, _) <- ts ] + && (x ^ xm) * (y ^ ym) == (x' ^ xm) * (y' ^ ym) * product (map (\(r, k) -> r ^ k) rest) + where + (x', y', rest) = doPair x xm y ym + +insertInternal + :: forall a b. + (Euclidean a, Eq b, Num b) + => a + -> b + -> Coprimes a b + -> (Coprimes a b, Coprimes a b) +insertInternal 0 _ = const (Coprimes [(0, 1)], Coprimes []) +insertInternal xx xm = coerce (go ([], []) xx) + where + go :: ([(a, b)], [(a, b)]) -> a -> [(a, b)] -> ([(a, b)], [(a, b)]) + go (old, new) 1 rest = (rest ++ old, new) + go (old, new) x [] = (old, (x, xm) : new) + go _ _ ((0, _) : _) = ([(0, 1)], []) + go (old, new) x ((y, ym) : rest) + | y' == 1 = go (old, xys ++ new) x' rest + | otherwise = go ((y', ym) : old, xys ++ new) x' rest + where + (x', y', xys) = doPair x xm y ym + +-- | Wrap a non-zero number with its multiplicity into 'Coprimes'. +-- +-- >>> singleton 210 1 +-- Coprimes {unCoprimes = [(210,1)]} +singleton :: (Eq a, Num a, Eq b, Num b) => a -> b -> Coprimes a b +singleton 0 0 = Coprimes [] +singleton 1 _ = Coprimes [] +singleton a b = Coprimes [(a, b)] + +-- | Add a non-zero number with its multiplicity to 'Coprimes'. +-- +-- >>> insert 360 1 (singleton 210 1) +-- Coprimes {unCoprimes = [(7,1),(5,2),(3,3),(2,4)]} +-- >>> insert 2 4 (insert 7 1 (insert 5 2 (singleton 4 3))) +-- Coprimes {unCoprimes = [(7,1),(5,2),(2,10)]} +insert :: (Euclidean a, Eq b, Num b) => a -> b -> Coprimes a b -> Coprimes a b +insert x xm ys = Coprimes $ unCoprimes zs <> unCoprimes ws + where + (zs, ws) = insertInternal x xm ys + +instance (Euclidean a, Eq b, Num b) => Semigroup (Coprimes a b) where + (Coprimes xs) <> ys = Coprimes $ unCoprimes zs <> foldMap unCoprimes wss + where + (zs, wss) = mapAccumL (\vs (x, xm) -> insertInternal x xm vs) ys xs + +instance (Euclidean a, Eq b, Num b) => Monoid (Coprimes a b) where + mempty = Coprimes [] + mappend = (<>) + +-- | The input list is assumed to be a factorisation of some number +-- into a list of powers of (possibly, composite) non-zero factors. The output +-- list is a factorisation of the same number such that all factors +-- are coprime. Such transformation is crucial to continue factorisation +-- (lazily, in parallel or concurrent fashion) without +-- having to merge multiplicities of primes, which occurs more than in one +-- composite factor. +-- +-- >>> splitIntoCoprimes [(140, 1), (165, 1)] +-- Coprimes {unCoprimes = [(28,1),(33,1),(5,2)]} +-- >>> splitIntoCoprimes [(360, 1), (210, 1)] +-- Coprimes {unCoprimes = [(7,1),(5,2),(3,3),(2,4)]} +splitIntoCoprimes :: (Euclidean a, Eq b, Num b) => [(a, b)] -> Coprimes a b +splitIntoCoprimes = foldl (\acc (x, xm) -> insert x xm acc) mempty diff --git a/Math/NumberTheory/GCD.hs b/Math/NumberTheory/GCD.hs --- a/Math/NumberTheory/GCD.hs +++ b/Math/NumberTheory/GCD.hs @@ -21,19 +21,23 @@ -- When using this module, always compile with optimisations turned on to -- benefit from GHC's primops and the rewrite rules. -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MagicHash #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MagicHash #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +{-# OPTIONS_GHC -fno-warn-deprecations #-} + module Math.NumberTheory.GCD ( binaryGCD , extendedGCD , coprime - , splitIntoCoprimes ) where import Data.Bits +import Data.Semigroup + import GHC.Word import GHC.Int @@ -80,6 +84,8 @@ binaryGCD :: (Integral a, Bits a) => a -> a -> a binaryGCD = binaryGCDImpl +{-# DEPRECATED binaryGCD "Use 'Math.NumberTheory.Euclidean.gcd'" #-} + #if WORD_SIZE_IN_BITS < 64 {-# SPECIALISE binaryGCDImpl :: Word64 -> Word64 -> Word64, Int64 -> Int64 -> Int64 #-} @@ -136,6 +142,7 @@ | s == 0 = (r, o1, o2) | otherwise = case r `quotRem` s of (q, t) -> eGCD (o1 - q*n1) n1 (o2 - q*n2) n2 s t +{-# DEPRECATED extendedGCD "Use 'Math.NumberTheory.Euclidean.extendedGCD'" #-} {-# RULES "coprime/Int" coprime = coprimeInt @@ -170,6 +177,7 @@ -- Relies on twos complement or sign and magnitude representaion for signed types. coprime :: (Integral a, Bits a) => a -> a -> Bool coprime = coprimeImpl +{-# DEPRECATED coprime "Use 'Math.NumberTheory.Euclidean.coprime'" #-} -- Separate implementation to give the rules a chance to fire by not inlining -- before phase 1, and yet have a specialisation for the types without rules @@ -251,37 +259,3 @@ cw32 :: Word32 -> Word32 -> Bool cw32 (W32# x#) (W32# y#) = coprimeWord# x# y# - --- | The input list is assumed to be a factorisation of some number --- into a list of powers of (possibly, composite) non-zero factors. The output --- list is a factorisation of the same number such that all factors --- are coprime. Such transformation is crucial to continue factorisation --- (lazily, in parallel or concurrent fashion) without --- having to merge multiplicities of primes, which occurs more than in one --- composite factor. --- --- > > splitIntoCoprimes [(140, 1), (165, 1)] --- > [(5,2),(28,1),(33,1)] --- > > splitIntoCoprimes [(360, 1), (210, 1)] --- > [(2,4),(3,3),(5,2),(7,1)] -splitIntoCoprimes :: (Integral a, Eq b, Num b) => [(a, b)] -> [(a, b)] -splitIntoCoprimes xs = if any ((== 0) . fst) ys then [(0, 1)] else go ys - where - ys = filter (/= (0, 0)) xs - - go = \case - [] -> [] - ((1, _) : rest) -> go rest - ((x, xm) : rest) -> case popSuchThat (\(r, _) -> gcd x r /= 1) rest of - Nothing -> (x, xm) : go rest - Just ((y, ym), zs) -> let g = gcd x y in - go ((g, xm + ym) : (x `quot` g, xm) : (y `quot` g, ym) : zs) - -popSuchThat :: (a -> Bool) -> [a] -> Maybe (a, [a]) -popSuchThat predicate = go - where - go = \case - [] -> Nothing - (x : xs) - | predicate x -> Just (x, xs) - | otherwise -> fmap (fmap (x :)) (go xs) diff --git a/Math/NumberTheory/GCD/LowLevel.hs b/Math/NumberTheory/GCD/LowLevel.hs --- a/Math/NumberTheory/GCD/LowLevel.hs +++ b/Math/NumberTheory/GCD/LowLevel.hs @@ -31,6 +31,9 @@ import Math.NumberTheory.Utils +{-# DEPRECATED gcdInt, gcdWord, gcdInt#, gcdWord# "Use Math.NumberTheory.Euclidean.gcd" #-} +{-# DEPRECATED coprimeInt, coprimeWord, coprimeInt#, coprimeWord# "Math.NumberTheory.Euclidean." #-} + -- | Greatest common divisor of two 'Int's, calculated with the binary gcd algorithm. gcdInt :: Int -> Int -> Int gcdInt (I# a#) (I# b#) = I# (gcdInt# a# b#) diff --git a/Math/NumberTheory/GaussianIntegers.hs b/Math/NumberTheory/GaussianIntegers.hs --- a/Math/NumberTheory/GaussianIntegers.hs +++ b/Math/NumberTheory/GaussianIntegers.hs @@ -10,226 +10,9 @@ -- computing their prime factorisations. -- -{-# LANGUAGE BangPatterns #-} - -module Math.NumberTheory.GaussianIntegers ( - GaussianInteger((:+)), - ι, - real, - imag, - conjugate, - norm, - divModG, - divG, - modG, - quotRemG, - quotG, - remG, - (.^), - isPrime, - primes, - gcdG, - gcdG', - findPrime, - findPrime', - factorise, -) where - -import qualified Math.NumberTheory.Moduli as Moduli -import qualified Math.NumberTheory.Powers as Powers -import qualified Math.NumberTheory.Primes.Factorisation as Factorisation -import qualified Math.NumberTheory.Primes.Sieve as Sieve -import qualified Math.NumberTheory.Primes.Testing as Testing - -infix 6 :+ -infixr 8 .^ --- |A Gaussian integer is a+bi, where a and b are both integers. -data GaussianInteger = (:+) { real :: !Integer, imag :: !Integer } deriving (Eq) - --- |The imaginary unit, where --- --- > ι .^ 2 == -1 -ι :: GaussianInteger -ι = 0 :+ 1 - -instance Show GaussianInteger where - show (a :+ b) - | b == 0 = show a - | a == 0 = s ++ b' - | otherwise = show a ++ op ++ b' - where - b' = if abs b == 1 then "ι" else show (abs b) ++ "*ι" - op = if b > 0 then "+" else "-" - s = if b > 0 then "" else "-" - -instance Num GaussianInteger where - (+) (a :+ b) (c :+ d) = (a + c) :+ (b + d) - (*) (a :+ b) (c :+ d) = (a * c - b * d) :+ (a * d + b * c) - abs z@(a :+ b) - | a == 0 && b == 0 = z -- origin - | a > 0 && b >= 0 = z -- first quadrant: (0, inf) x [0, inf)i - | a <= 0 && b > 0 = b :+ (-a) -- second quadrant: (-inf, 0] x (0, inf)i - | a < 0 && b <= 0 = (-a) :+ (-b) -- third quadrant: (-inf, 0) x (-inf, 0]i - | otherwise = (-b) :+ a -- fourth quadrant: [0, inf) x (-inf, 0)i - negate (a :+ b) = (-a) :+ (-b) - fromInteger n = n :+ 0 - signum z@(a :+ b) - | a == 0 && b == 0 = z -- hole at origin - | otherwise = z `divG` abs z - --- |Simultaneous 'quot' and 'rem'. -quotRemG :: GaussianInteger -> GaussianInteger -> (GaussianInteger, GaussianInteger) -quotRemG = divHelper quot - --- |Gaussian integer division, truncating toward zero. -quotG :: GaussianInteger -> GaussianInteger -> GaussianInteger -n `quotG` d = q where (q,_) = quotRemG n d - --- |Gaussian integer remainder, satisfying --- --- > (x `quotG` y)*y + (x `remG` y) == x -remG :: GaussianInteger -> GaussianInteger -> GaussianInteger -n `remG` d = r where (_,r) = quotRemG n d - --- |Simultaneous 'div' and 'mod'. -divModG :: GaussianInteger -> GaussianInteger -> (GaussianInteger, GaussianInteger) -divModG = divHelper div - --- |Gaussian integer division, truncating toward negative infinity. -divG :: GaussianInteger -> GaussianInteger -> GaussianInteger -n `divG` d = q where (q,_) = divModG n d - --- |Gaussian integer remainder, satisfying --- --- > (x `divG` y)*y + (x `modG` y) == x -modG :: GaussianInteger -> GaussianInteger -> GaussianInteger -n `modG` d = r where (_,r) = divModG n d - -divHelper :: (Integer -> Integer -> Integer) -> GaussianInteger -> GaussianInteger -> (GaussianInteger, GaussianInteger) -divHelper divide g h = - let nr :+ ni = g * conjugate h - denom = norm h - q = divide nr denom :+ divide ni denom - p = h * q - in (q, g - p) - --- |Conjugate a Gaussian integer. -conjugate :: GaussianInteger -> GaussianInteger -conjugate (r :+ i) = r :+ (-i) - --- |The square of the magnitude of a Gaussian integer. -norm :: GaussianInteger -> Integer -norm (x :+ y) = x * x + y * y - --- |Compute whether a given Gaussian integer is prime. -isPrime :: GaussianInteger -> Bool -isPrime g@(x :+ y) - | x == 0 && y /= 0 = abs y `mod` 4 == 3 && Testing.isPrime y - | y == 0 && x /= 0 = abs x `mod` 4 == 3 && Testing.isPrime x - | otherwise = Testing.isPrime $ norm g - --- |An infinite list of the Gaussian primes. Uses primes in Z to exhaustively --- generate all Gaussian primes, but not quite in order of ascending magnitude. -primes :: [GaussianInteger] -primes = [ g - | p <- Sieve.primes - , g <- if p `mod` 4 == 3 - then [p :+ 0] - else - if p == 2 - then [1 :+ 1] - else let x :+ y = findPrime' p - in [x :+ y, y :+ x] - ] - --- |Compute the GCD of two Gaussian integers. Enforces the precondition that each --- integer must be in the first quadrant (or zero). -gcdG :: GaussianInteger -> GaussianInteger -> GaussianInteger -gcdG g h = gcdG' (abs g) (abs h) - --- |Compute the GCD of two Gauss integers. Does not check the precondition. -gcdG' :: GaussianInteger -> GaussianInteger -> GaussianInteger -gcdG' g h - | h == 0 = g --done recursing - | otherwise = gcdG' h (abs (g `modG` h)) - --- |Find a Gaussian integer whose norm is the given prime number. --- Checks the precondition that p is prime and that p `mod` 4 /= 3. -findPrime :: Integer -> GaussianInteger -findPrime p - | p == 2 || (p `mod` 4 == 1 && Testing.isPrime p) = findPrime' p - | otherwise = error "p must be prime, and not congruent to 3 (mod 4)" - --- |Find a Gaussian integer whose norm is the given prime number. Does not --- check the precondition. -findPrime' :: Integer -> GaussianInteger -findPrime' p = - let (Just c) = Moduli.sqrtModP (-1) p - k = Powers.integerSquareRoot p - bs = [1 .. k] - asbs = map (\b' -> ((b' * c) `mod` p, b')) bs - (a, b) = head [ (a', b') | (a', b') <- asbs, a' <= k] - in a :+ b - --- |Raise a Gaussian integer to a given power. -(.^) :: (Integral a) => GaussianInteger -> a -> GaussianInteger -a .^ e - | e < 0 && norm a == 1 = - case a of - 1 :+ 0 -> 1 - (-1) :+ 0 -> if even e then 1 else (-1) - 0 :+ 1 -> (0 :+ (-1)) .^ (abs e `mod` 4) - _ -> (0 :+ 1) .^ (abs e `mod` 4) - | e < 0 = error "Cannot exponentiate non-unit Gaussian Int to negative power" - | a == 0 = 0 - | e == 0 = 1 - | even e = s * s - | otherwise = a * a .^ (e - 1) - where - s = a .^ div e 2 - --- |Compute the prime factorisation of a Gaussian integer. This is unique up to units (+/- 1, +/- i). -factorise :: GaussianInteger -> [(GaussianInteger, Int)] -factorise g = helper (Factorisation.factorise $ norm g) g - where - helper [] g' = if g' == 1 then [] else [(g', 1)] -- include the unit, if it isn't 1 - helper ((!p, !e) : pt) g' = - -- For a given prime factor p of the magnitude squared... - let (!g'', !facs) = if p `mod` 4 == 3 - then - -- if the p is congruent to 3 (mod 4), then g' is divisible by - -- p^(e/2). - let pow = div e 2 - gp = fromInteger p - in (g' `divG` (gp .^ pow), [(gp, pow)]) - else - -- otherwise: find a Gaussian prime gp for which `norm gp == - -- p`. Then do trial divisions to find out how many times g' is - -- divisible by gp or its conjugate. - let gp = findPrime' p - in trialDivide g' [gp, abs $ conjugate gp] - in facs ++ helper pt g'' - --- Divide a Gaussian integer by a set of (relatively prime) Gaussian integers, --- as many times as possible, and return the final quotient as well as a count --- of how many times each factor divided the original. -trialDivide :: GaussianInteger -> [GaussianInteger] -> (GaussianInteger, [(GaussianInteger, Int)]) -trialDivide = helper [] - where - helper fs g [] = (g, fs) - helper fs g (pf : pft) - | g `modG` pf == 0 = - let (cnt, g') = countEvenDivisions g pf - in helper ((pf, cnt) : fs) g' pft - | otherwise = helper fs g pft +module Math.NumberTheory.GaussianIntegers + {-# DEPRECATED "Use Math.NumberTheory.Quadratic.GaussianIntegers instead" #-} + ( module Math.NumberTheory.Quadratic.GaussianIntegers + ) where --- Divide a Gaussian integer by a possible factor, and return how many times --- the factor divided it evenly, as well as the result of dividing the original --- that many times. -countEvenDivisions :: GaussianInteger -> GaussianInteger -> (Int, GaussianInteger) -countEvenDivisions g pf = helper g 0 - where - helper :: GaussianInteger -> Int -> (Int, GaussianInteger) - helper g' acc - | g' `modG` pf == 0 = helper (g' `divG` pf) (1 + acc) - | otherwise = (acc, g') +import Math.NumberTheory.Quadratic.GaussianIntegers diff --git a/Math/NumberTheory/Moduli.hs b/Math/NumberTheory/Moduli.hs --- a/Math/NumberTheory/Moduli.hs +++ b/Math/NumberTheory/Moduli.hs @@ -12,11 +12,15 @@ module Math.NumberTheory.Moduli ( module Math.NumberTheory.Moduli.Class , module Math.NumberTheory.Moduli.Chinese + , module Math.NumberTheory.Moduli.DiscreteLogarithm , module Math.NumberTheory.Moduli.Jacobi + , module Math.NumberTheory.Moduli.PrimitiveRoot , module Math.NumberTheory.Moduli.Sqrt ) where import Math.NumberTheory.Moduli.Chinese import Math.NumberTheory.Moduli.Class +import Math.NumberTheory.Moduli.DiscreteLogarithm import Math.NumberTheory.Moduli.Jacobi +import Math.NumberTheory.Moduli.PrimitiveRoot import Math.NumberTheory.Moduli.Sqrt diff --git a/Math/NumberTheory/Moduli/Chinese.hs b/Math/NumberTheory/Moduli/Chinese.hs --- a/Math/NumberTheory/Moduli/Chinese.hs +++ b/Math/NumberTheory/Moduli/Chinese.hs @@ -17,9 +17,9 @@ ) where import Control.Monad (foldM) -import GHC.Integer.GMP.Internals -import Math.NumberTheory.GCD (extendedGCD) +import Math.NumberTheory.Euclidean (extendedGCD) +import Math.NumberTheory.Utils (recipMod) -- | Given a list @[(r_1,m_1), ..., (r_n,m_n)]@ of @(residue,modulus)@ -- pairs, @chineseRemainder@ calculates the solution to the simultaneous @@ -52,8 +52,3 @@ chineseRemainder2 (r1, md1) (r2,md2) = case extendedGCD md1 md2 of (_,u,v) -> ((1 - u*md1)*r1 + (1 - v*md2)*r2) `mod` (md1*md2) - -recipMod :: Integer -> Integer -> Maybe Integer -recipMod x m = case recipModInteger x m of - 0 -> Nothing - y -> Just y diff --git a/Math/NumberTheory/Moduli/Class.hs b/Math/NumberTheory/Moduli/Class.hs --- a/Math/NumberTheory/Moduli/Class.hs +++ b/Math/NumberTheory/Moduli/Class.hs @@ -9,7 +9,6 @@ -- Safe modular arithmetic with modulo on type level. -- -{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -29,6 +28,11 @@ , invertMod , powMod , (^%) + -- * Multiplicative group + , MultMod + , multElement + , isMultElement + , invertGroup -- * Unknown modulo , SomeMod(..) , modulo @@ -40,19 +44,12 @@ import Data.Proxy import Data.Ratio +import Data.Semigroup import Data.Type.Equality import GHC.Integer.GMP.Internals import GHC.TypeNats.Compat -#if __GLASGOW_HASKELL__ < 709 -import Data.Word -import Numeric.Natural (Natural) - -powModNatural :: Natural -> Natural -> Natural -> Natural -powModNatural b e m = fromInteger $ powModInteger (toInteger b) (toInteger e) (toInteger m) -#else import GHC.Natural (Natural, powModNatural) -#endif -- | Wrapper for residues modulo @m@. -- @@ -60,10 +57,11 @@ -- The modulo is stored on type level, so it is impossible, for example, to add up by mistake -- residues with different moduli. -- --- > > (3 :: Mod 10) + (4 :: Mod 12) --- > error: Couldn't match type ‘12’ with ‘10’... --- > > (3 :: Mod 10) + 8 --- > (1 `modulo` 10) +-- >>> :set -XDataKinds +-- >>> (3 :: Mod 10) + (4 :: Mod 12) +-- error: Couldn't match type ‘12’ with ‘10’... +-- >>> (3 :: Mod 10) + 8 +-- (1 `modulo` 10) -- -- Note that modulo cannot be negative. newtype Mod (m :: Nat) = Mod Natural @@ -128,33 +126,36 @@ {-# INLINE getNatMod #-} -- | The canonical representative of the residue class, always between 0 and @m-1@ inclusively. -getVal :: KnownNat m => Mod m -> Integer +getVal :: Mod m -> Integer getVal (Mod x) = toInteger x {-# INLINE getVal #-} -- | The canonical representative of the residue class, always between 0 and @m-1@ inclusively. -getNatVal :: KnownNat m => Mod m -> Natural +getNatVal :: Mod m -> Natural getNatVal (Mod x) = x {-# INLINE getNatVal #-} -- | Computes the modular inverse, if the residue is coprime with the modulo. -- --- > > invertMod (3 :: Mod 10) --- > Just (7 `modulo` 10) -- because 3 * 7 = 1 :: Mod 10 --- > > invertMod (4 :: Mod 10) --- > Nothing +-- >>> :set -XDataKinds +-- >>> invertMod (3 :: Mod 10) +-- Just (7 `modulo` 10) -- because 3 * 7 = 1 :: Mod 10 +-- >>> invertMod (4 :: Mod 10) +-- Nothing invertMod :: KnownNat m => Mod m -> Maybe (Mod m) invertMod mx = if y <= 0 then Nothing else Just $ Mod $ fromInteger y where + -- first argument of recipModInteger is guaranteed to be positive y = recipModInteger (getVal mx) (getMod mx) {-# INLINABLE invertMod #-} -- | Drop-in replacement for '^', with much better performance. -- --- > > powMod (3 :: Mod 10) 4 +-- >>> :set -XDataKinds +-- >>> powMod (3 :: Mod 10) 4 -- > (1 `modulo` 10) powMod :: (KnownNat m, Integral a) => Mod m -> a -> Mod m powMod mx a @@ -185,18 +186,51 @@ -- of type classes in Core. -- {-# RULES "^%Mod" forall (x :: KnownNat m => Mod m) p. x ^ p = x ^% p #-} +-- | This type represents elements of the multiplicative group mod m, i.e. +-- those elements which are coprime to m. Use @toMultElement@ to construct. +newtype MultMod m = MultMod { multElement :: Mod m } + deriving (Eq, Ord, Show) + +instance KnownNat m => Semigroup (MultMod m) where + MultMod a <> MultMod b = MultMod (a * b) + stimes k a@(MultMod a') + | k >= 0 = MultMod (powMod a' k) + | otherwise = invertGroup $ stimes (-k) a + -- ^ This Semigroup is in fact a group, so @stimes@ can be called with a negative first argument. + +instance KnownNat m => Monoid (MultMod m) where + mempty = MultMod 1 + mappend = (<>) + +instance KnownNat m => Bounded (MultMod m) where + minBound = MultMod 1 + maxBound = MultMod (-1) + +-- | Attempt to construct a multiplicative group element. +isMultElement :: KnownNat m => Mod m -> Maybe (MultMod m) +isMultElement a = if getNatVal a `gcd` getNatMod a == 1 + then Just $ MultMod a + else Nothing + +-- | For elements of the multiplicative group, we can safely perform the inverse +-- without needing to worry about failure. +invertGroup :: KnownNat m => MultMod m -> MultMod m +invertGroup (MultMod a) = case invertMod a of + Just b -> MultMod b + Nothing -> error "Math.NumberTheory.Moduli.invertGroup: failed to invert element" + -- | This type represents residues with unknown modulo and rational numbers. -- One can freely combine them in arithmetic expressions, but each operation -- will spend time on modulo's recalculation: -- --- > > 2 `modulo` 10 + 4 `modulo` 15 --- > (1 `modulo` 5) --- > > 2 `modulo` 10 * 4 `modulo` 15 --- > (3 `modulo` 5) --- > > 2 `modulo` 10 + fromRational (3 % 7) --- > (1 `modulo` 10) --- > > 2 `modulo` 10 * fromRational (3 % 7) --- > (8 `modulo` 10) +-- >>> 2 `modulo` 10 + 4 `modulo` 15 +-- (1 `modulo` 5) +-- >>> 2 `modulo` 10 * 4 `modulo` 15 +-- (3 `modulo` 5) +-- >>> 2 `modulo` 10 + fromRational (3 % 7) +-- (1 `modulo` 10) +-- >>> 2 `modulo` 10 * fromRational (3 % 7) +-- (8 `modulo` 10) -- -- If performance is crucial, it is recommended to extract @Mod m@ for further processing -- by pattern matching. E. g., @@ -286,12 +320,12 @@ -- | Computes the inverse value, if it exists. -- --- > > invertSomeMod (3 `modulo` 10) --- > Just (7 `modulo` 10) -- because 3 * 7 = 1 :: Mod 10 --- > > invertMod (4 `modulo` 10) --- > Nothing --- > > invertSomeMod (fromRational (2 % 5)) --- > Just 5 % 2 +-- >>> invertSomeMod (3 `modulo` 10) +-- Just (7 `modulo` 10) -- because 3 * 7 = 1 :: Mod 10 +-- >>> invertMod (4 `modulo` 10) +-- Nothing +-- >>> invertSomeMod (fromRational (2 % 5)) +-- Just 5 % 2 invertSomeMod :: SomeMod -> Maybe SomeMod invertSomeMod = \case SomeMod m -> fmap SomeMod (invertMod m) @@ -307,8 +341,8 @@ -- | Drop-in replacement for '^', with much better performance. -- When -O is enabled, there is a rewrite rule, which specialises '^' to 'powSomeMod'. -- --- > > powSomeMod (3 `modulo` 10) 4 --- > (1 `modulo` 10) +-- >>> powSomeMod (3 `modulo` 10) 4 +-- (1 `modulo` 10) powSomeMod :: Integral a => SomeMod -> a -> SomeMod powSomeMod (SomeMod m) a = SomeMod (m ^% a) powSomeMod (InfMod r) a = InfMod (r ^ a) diff --git a/Math/NumberTheory/Moduli/DiscreteLogarithm.hs b/Math/NumberTheory/Moduli/DiscreteLogarithm.hs new file mode 100644 --- /dev/null +++ b/Math/NumberTheory/Moduli/DiscreteLogarithm.hs @@ -0,0 +1,123 @@ +-- | +-- Module: Math.NumberTheory.Moduli.DiscreteLogarithm +-- Copyright: (c) 2018 Bhavik Mehta +-- License: MIT +-- Maintainer: Andrew Lelechenko +-- Stability: Provisional +-- Portability: Non-portable +-- + +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} + +module Math.NumberTheory.Moduli.DiscreteLogarithm + ( discreteLogarithm + ) where + +import qualified Data.IntMap.Strict as M +import Data.Maybe (maybeToList) +import Data.Proxy +import Numeric.Natural (Natural) +import GHC.Integer.GMP.Internals (recipModInteger, powModInteger) +import GHC.TypeNats.Compat + +import Math.NumberTheory.Moduli.Chinese (chineseRemainder2) +import Math.NumberTheory.Moduli.Class (KnownNat, MultMod(..), Mod, getVal) +import Math.NumberTheory.Moduli.Equations (solveLinear) +import Math.NumberTheory.Moduli.PrimitiveRoot (PrimitiveRoot(..), CyclicGroup(..)) +import Math.NumberTheory.Powers.Squares (integerSquareRoot) +import Math.NumberTheory.UniqueFactorisation (unPrime) + +-- | Computes the discrete logarithm. Currently uses a combination of the baby-step +-- giant-step method and Pollard's rho algorithm, with Bach reduction. +discreteLogarithm :: KnownNat m => PrimitiveRoot m -> MultMod m -> Natural +discreteLogarithm a b = discreteLogarithm' (getGroup a) (multElement $ unPrimitiveRoot a) (multElement b) + +discreteLogarithm' + :: KnownNat m + => CyclicGroup Natural -- ^ group structure (must be the multiplicative group mod m) + -> Mod m -- ^ a + -> Mod m -- ^ b + -> Natural -- ^ result +discreteLogarithm' cg a b = + case cg of + CG2 -> 0 + -- the only valid input was a=1, b=1 + CG4 -> if b == 1 then 0 else 1 + -- the only possible input here is a=3 with b = 1 or 3 + CGOddPrimePower (unPrime -> p) k -> discreteLogarithmPP p k (getVal a) (getVal b) + CGDoubleOddPrimePower (unPrime -> p) k -> discreteLogarithmPP p k (getVal a `rem` p^k) (getVal b `rem` p^k) + -- we have the isomorphism t -> t `rem` p^k from (Z/2p^kZ)* -> (Z/p^kZ)* + +-- Implementation of Bach reduction (https://www2.eecs.berkeley.edu/Pubs/TechRpts/1984/CSD-84-186.pdf) +{-# INLINE discreteLogarithmPP #-} +discreteLogarithmPP :: Integer -> Word -> Integer -> Integer -> Natural +discreteLogarithmPP p 1 a b = discreteLogarithmPrime p a b +discreteLogarithmPP p k a b = fromInteger result + where + baseSol = toInteger $ discreteLogarithmPrime p (a `rem` p) (b `rem` p) + thetaA = theta p pkMinusOne a + thetaB = theta p pkMinusOne b + pkMinusOne = p^(k-1) + c = (recipModInteger thetaA pkMinusOne * thetaB) `rem` pkMinusOne + result = chineseRemainder2 (baseSol, p-1) (c, pkMinusOne) + +-- compute the homomorphism theta given in https://math.stackexchange.com/a/1864495/418148 +{-# INLINE theta #-} +theta :: Integer -> Integer -> Integer -> Integer +theta p pkMinusOne a = (numerator `quot` pk) `rem` pkMinusOne + where + pk = pkMinusOne * p + p2kMinusOne = pkMinusOne * pk + numerator = (powModInteger a (pk - pkMinusOne) p2kMinusOne - 1) `rem` p2kMinusOne + +-- TODO: Use Pollig-Hellman to reduce the problem further into groups of prime order. +-- While Bach reduction simplifies the problem into groups of the form (Z/pZ)*, these +-- have non-prime order, and the Pollig-Hellman algorithm can reduce the problem into +-- smaller groups of prime order. +-- In addition, the gcd check before solveLinear is applied in Pollard below will be +-- made redundant, since n would be prime. +discreteLogarithmPrime :: Integer -> Integer -> Integer -> Natural +discreteLogarithmPrime p a b + | p < 100000000 = fromIntegral $ discreteLogarithmPrimeBSGS (fromInteger p) (fromInteger a) (fromInteger b) + | otherwise = discreteLogarithmPrimePollard p a b + +discreteLogarithmPrimeBSGS :: Int -> Int -> Int -> Int +discreteLogarithmPrimeBSGS p a b = head [i*m + j | (v,i) <- zip giants [0..m-1], j <- maybeToList (M.lookup v table)] + where + m = integerSquareRoot (p - 2) + 1 -- simple way of ceiling (sqrt (p-1)) + babies = iterate (.* a) 1 + table = M.fromList (zip babies [0..m-1]) + aInv = recipModInteger (toInteger a) (toInteger p) + bigGiant = fromInteger $ powModInteger aInv (toInteger m) (toInteger p) + giants = iterate (.* bigGiant) b + x .* y = x * y `rem` p + +-- TODO: Use more advanced walks, in order to reduce divisions, cf +-- https://maths-people.anu.edu.au/~brent/pd/rpb231.pdf +-- This will slightly improve the expected time to collision, and can reduce the +-- number of divisions performed. +discreteLogarithmPrimePollard :: Integer -> Integer -> Integer -> Natural +discreteLogarithmPrimePollard p a b = + case concatMap runPollard [(x,y) | x <- [0..n], y <- [0..n]] of + (t:_) -> fromInteger t + [] -> error ("discreteLogarithm: pollard's rho failed, please report this as a bug. inputs " ++ show [p,a,b]) + where + n = p-1 -- order of the cyclic group + halfN = n `quot` 2 + mul2 m = if m < halfN then m * 2 else m * 2 - n + sqrtN = integerSquareRoot n + step (xi,!ai,!bi) = case xi `rem` 3 of + 0 -> (xi*xi `rem` p, mul2 ai, mul2 bi) + 1 -> ( a*xi `rem` p, ai+1, bi) + _ -> ( b*xi `rem` p, ai, bi+1) + initialise (x,y) = (powModInteger a x n * powModInteger b y n `rem` n, x, y) + begin t = go (step t) (step (step t)) + check t = powModInteger a t p == b + go tort@(xi,ai,bi) hare@(x2i,a2i,b2i) + | xi == x2i, gcd (bi - b2i) n < sqrtN = case someNatVal (fromInteger n) of + SomeNat (Proxy :: Proxy n) -> map getVal $ solveLinear (fromInteger (bi - b2i) :: Mod n) (fromInteger (ai - a2i)) + | xi == x2i = [] + | otherwise = go (step tort) (step (step hare)) + runPollard = filter check . begin . initialise diff --git a/Math/NumberTheory/Moduli/Equations.hs b/Math/NumberTheory/Moduli/Equations.hs new file mode 100644 --- /dev/null +++ b/Math/NumberTheory/Moduli/Equations.hs @@ -0,0 +1,137 @@ +-- | +-- Module: Math.NumberTheory.Moduli.Equations +-- Copyright: (c) 2018 Andrew Lelechenko +-- Licence: MIT +-- Maintainer: Andrew Lelechenko +-- Stability: Provisional +-- Portability: Non-portable (GHC extensions) +-- +-- Polynomial modular equations. +-- + +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} + +module Math.NumberTheory.Moduli.Equations + ( solveLinear + , solveQuadratic + ) where + +import GHC.Integer.GMP.Internals + +import Math.NumberTheory.Moduli.Chinese +import Math.NumberTheory.Moduli.Class +import Math.NumberTheory.Moduli.Sqrt +import Math.NumberTheory.UniqueFactorisation +import Math.NumberTheory.Utils (recipMod) + +------------------------------------------------------------------------------- +-- Linear equations + +-- | Find all solutions of ax + b ≡ 0 (mod m). +-- +-- >>> :set -XDataKinds +-- >>> solveLinear (6 :: Mod 10) 4 -- solving 6x + 4 ≡ 0 (mod 10) +-- [(1 `modulo` 10),(6 `modulo` 10)] +solveLinear + :: KnownNat m + => Mod m -- ^ a + -> Mod m -- ^ b + -> [Mod m] -- ^ list of x +solveLinear a b = map fromInteger $ solveLinear' (getMod a) (getVal a) (getVal b) + +solveLinear' :: Integer -> Integer -> Integer -> [Integer] +solveLinear' m a b = case solveLinearCoprime m' (a `quot` d) (b `quot` d) of + Nothing -> [] + Just x -> map (\i -> x + m' * i) [0 .. d - 1] + where + d = m `gcd` a `gcd` b + m' = m `quot` d + +solveLinearCoprime :: Integer -> Integer -> Integer -> Maybe Integer +solveLinearCoprime 1 _ _ = Just 0 +solveLinearCoprime m a b = (\a1 -> negate b * a1 `mod` m) <$> recipMod a m + +------------------------------------------------------------------------------- +-- Quadratic equations + +-- | Find all solutions of ax² + bx + c ≡ 0 (mod m). +-- +-- >>> :set -XDataKinds +-- >>> solveQuadratic (1 :: Mod 32) 0 (-17) -- solving x² - 17 ≡ 0 (mod 32) +-- [(9 `modulo` 32),(25 `modulo` 32),(7 `modulo` 32),(23 `modulo` 32)] +solveQuadratic + :: KnownNat m + => Mod m -- ^ a + -> Mod m -- ^ b + -> Mod m -- ^ c + -> [Mod m] -- ^ list of c +solveQuadratic a b c + = map fromInteger + $ fst + $ combine + $ map (\(p, n) -> (solveQuadraticPrimePower a' b' c' p n, unPrime p ^ n)) + $ factorise + $ getMod a + where + a' = getVal a + b' = getVal b + c' = getVal c + + combine :: [([Integer], Integer)] -> ([Integer], Integer) + combine = foldl + (\(xs, xm) (ys, ym) -> ([ chineseRemainder2 (x, xm) (y, ym) | x <- xs, y <- ys ], xm * ym)) + ([0], 1) + +solveQuadraticPrimePower + :: Integer + -> Integer + -> Integer + -> Prime Integer + -> Word + -> [Integer] +solveQuadraticPrimePower a b c p = go + where + go :: Word -> [Integer] + go 0 = [0] + go 1 = solveQuadraticPrime a b c p + go k = concatMap (liftRoot k) (go (k - 1)) + + -- Hensel lifting + -- https://en.wikipedia.org/wiki/Hensel%27s_lemma#Hensel_lifting + liftRoot :: Word -> Integer -> [Integer] + liftRoot k r = case recipMod (2 * a * r + b) pk of + Nothing -> case fr of + 0 -> map (\i -> r + pk `quot` p' * i) [0 .. p' - 1] + _ -> [] + Just invDeriv -> [(r - fr * invDeriv) `mod` pk] + where + pk = p' ^ k + fr = (a * r * r + b * r + c) `mod` pk + + p' :: Integer + p' = unPrime p + +solveQuadraticPrime + :: Integer + -> Integer + -> Integer + -> Prime Integer + -> [Integer] +solveQuadraticPrime a b c (unPrime -> 2 :: Integer) + = case (even c, even (a + b)) of + (True, True) -> [0, 1] + (True, _) -> [0] + (_, False) -> [1] + _ -> [] +solveQuadraticPrime a b c p + | a `mod` p' == 0 + = solveLinear' p' b c + | otherwise + = map (\n -> n * recipModInteger (2 * a) p' `mod` p') + $ map (subtract b) + $ sqrtsModPrime (b * b - 4 * a * c) p + where + p' :: Integer + p' = unPrime p + diff --git a/Math/NumberTheory/Moduli/Jacobi.hs b/Math/NumberTheory/Moduli/Jacobi.hs --- a/Math/NumberTheory/Moduli/Jacobi.hs +++ b/Math/NumberTheory/Moduli/Jacobi.hs @@ -1,36 +1,38 @@ -- | -- Module: Math.NumberTheory.Moduli.Jacobi --- Copyright: (c) 2011 Daniel Fischer, 2017 Andrew Lelechenko +-- Copyright: (c) 2011 Daniel Fischer, 2017-2018 Andrew Lelechenko -- Licence: MIT -- Maintainer: Andrew Lelechenko -- Stability: Provisional -- Portability: Non-portable (GHC extensions) -- --- Jacobi symbol. +-- +-- is a generalization of the Legendre symbol, useful for primality +-- testing and integer factorization. -- -{-# LANGUAGE CPP #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# OPTIONS_GHC -fno-warn-deprecations #-} + module Math.NumberTheory.Moduli.Jacobi ( JacobiSymbol(..) , jacobi , jacobi' ) where -import Data.Array.Unboxed import Data.Bits #if __GLASGOW_HASKELL__ < 803 import Data.Semigroup #endif -#if __GLASGOW_HASKELL__ < 709 -import Data.Word -#endif +import Numeric.Natural -import Math.NumberTheory.Unsafe import Math.NumberTheory.Utils --- | Type for result of 'jacobi'. +-- | Represents three possible values of +-- . data JacobiSymbol = MinusOne | Zero | One deriving (Eq, Ord, Show) @@ -50,103 +52,73 @@ Zero -> Zero One -> MinusOne --- | Jacobi symbol of two numbers. --- The \"denominator\" must be odd and positive, this condition is checked. +-- | of two arguments. +-- The lower argument (\"denominator\") must be odd and positive, +-- this condition is checked. -- --- If both numbers have a common prime factor, the result --- is @0@, otherwise it is ±1. +-- If arguments have a common factor, the result +-- is 'Zero', otherwise it is 'MinusOne' or 'One'. +-- +-- >>> jacobi 1001 9911 +-- Zero -- arguments have a common factor 11 +-- >>> jacobi 1001 9907 +-- MinusOne {-# SPECIALISE jacobi :: Integer -> Integer -> JacobiSymbol, + Natural -> Natural -> JacobiSymbol, Int -> Int -> JacobiSymbol, Word -> Word -> JacobiSymbol #-} jacobi :: (Integral a, Bits a) => a -> a -> JacobiSymbol +jacobi _ 1 = One jacobi a b - | b < 0 = error "Math.NumberTheory.Moduli.jacobi: negative denominator" - | evenI b = error "Math.NumberTheory.Moduli.jacobi: even denominator" - | b == 1 = One - | otherwise = jacobi' a b -- b odd, > 1 + | b < 0 = error "Math.NumberTheory.Moduli.jacobi: negative denominator" + | evenI b = error "Math.NumberTheory.Moduli.jacobi: even denominator" + | otherwise = jacobi' a b -- b odd, > 1 --- Invariant: b > 1 and odd --- | Jacobi symbol of two numbers without validity check of --- the \"denominator\". -{-# SPECIALISE jacobi' :: Integer -> Integer -> JacobiSymbol, - Int -> Int -> JacobiSymbol, - Word -> Word -> JacobiSymbol - #-} jacobi' :: (Integral a, Bits a) => a -> a -> JacobiSymbol +jacobi' 0 _ = Zero +jacobi' 1 _ = One jacobi' a b - | a == 0 = Zero - | a == 1 = One - | a < 0 = let n | rem4 b == 1 = One - | otherwise = MinusOne - -- Blech, minBound may pose problems - (z,o) = shiftToOddCount (abs $ toInteger a) - s | evenI z || unsafeAt jac2 (rem8 b) == 1 = n - | otherwise = negJS n - in s <> jacobi' (fromInteger o) b - | a >= b = case a `rem` b of - 0 -> Zero - r -> jacPS One r b - | evenI a = case shiftToOddCount a of - (z,o) -> let r | rem4 o .&. rem4 b == 1 = One - | otherwise = MinusOne - s | evenI z || unsafeAt jac2 (rem8 b) == 1 = r - | otherwise = negJS r - in jacOL s b o - | otherwise = case rem4 a .&. rem4 b of - 3 -> jacOL MinusOne b a - _ -> jacOL One b a + | a < 0 = let n = if rem4is3 b then MinusOne else One + (z, o) = shiftToOddCount (negate a) + s = if evenI z || rem8is1or7 b then n else negJS n + in s <> jacobi' o b + | a >= b = case a `rem` b of + 0 -> Zero + r -> jacPS One r b + | evenI a = case shiftToOddCount a of + (z, o) -> let r = if rem4is3 o && rem4is3 b then MinusOne else One + s = if evenI z || rem8is1or7 b then r else negJS r + in jacOL s b o + | otherwise = jacOL (if rem4is3 a && rem4is3 b then MinusOne else One) b a +{-# DEPRECATED jacobi' "Use 'jacobi' instead" #-} -- numerator positive and smaller than denominator -{-# SPECIALISE jacPS :: JacobiSymbol -> Integer -> Integer -> JacobiSymbol, - JacobiSymbol -> Int -> Int -> JacobiSymbol, - JacobiSymbol -> Word -> Word -> JacobiSymbol - #-} jacPS :: (Integral a, Bits a) => JacobiSymbol -> a -> a -> JacobiSymbol -jacPS j a b - | evenI a = case shiftToOddCount a of - (z,o) | evenI z || unsafeAt jac2 (rem8 b) == 1 -> - jacOL (if rem4 o .&. rem4 b == 3 then (negJS j) else j) b o - | otherwise -> - jacOL (if rem4 o .&. rem4 b == 3 then j else (negJS j)) b o - | otherwise = jacOL (if rem4 a .&. rem4 b == 3 then (negJS j) else j) b a +jacPS !acc a b + | evenI a = case shiftToOddCount a of + (z, o) + | evenI z || rem8is1or7 b -> jacOL (if rem4is3 o && rem4is3 b then negJS acc else acc) b o + | otherwise -> jacOL (if rem4is3 o && rem4is3 b then acc else negJS acc) b o + | otherwise = jacOL (if rem4is3 a && rem4is3 b then negJS acc else acc) b a -- numerator odd, positive and larger than denominator -{-# SPECIALISE jacOL :: JacobiSymbol -> Integer -> Integer -> JacobiSymbol, - JacobiSymbol -> Int -> Int -> JacobiSymbol, - JacobiSymbol -> Word -> Word -> JacobiSymbol - #-} jacOL :: (Integral a, Bits a) => JacobiSymbol -> a -> a -> JacobiSymbol -jacOL j a b - | b == 1 = j - | otherwise = case a `rem` b of - 0 -> Zero - r -> jacPS j r b +jacOL !acc _ 1 = acc +jacOL !acc a b = case a `rem` b of + 0 -> Zero + r -> jacPS acc r b -- Utilities --- For large Integers, going via Int is much faster than bit-fiddling --- on the Integer, so we do that. -{-# SPECIALISE evenI :: Integer -> Bool, - Int -> Bool, - Word -> Bool - #-} -evenI :: Integral a => a -> Bool -evenI n = fromIntegral n .&. 1 == (0 :: Int) - -{-# SPECIALISE rem4 :: Integer -> Int, - Int -> Int, - Word -> Int - #-} -rem4 :: Integral a => a -> Int -rem4 n = fromIntegral n .&. 3 +-- Sadly, GHC do not optimise `Prelude.even` to a bit test automatically. +evenI :: Bits a => a -> Bool +evenI n = not (n `testBit` 0) -{-# SPECIALISE rem8 :: Integer -> Int, - Int -> Int, - Word -> Int - #-} -rem8 :: Integral a => a -> Int -rem8 n = fromIntegral n .&. 7 +-- For an odd input @n@ test whether n `rem` 4 == 1 +rem4is3 :: Bits a => a -> Bool +rem4is3 n = n `testBit` 1 -jac2 :: UArray Int Int -jac2 = array (0,7) [(0,0),(1,1),(2,0),(3,-1),(4,0),(5,-1),(6,0),(7,1)] +-- For an odd input @n@ test whether (n `rem` 8) `elem` [1, 7] +rem8is1or7 :: Bits a => a -> Bool +rem8is1or7 n = n `testBit` 1 == n `testBit` 2 diff --git a/Math/NumberTheory/Moduli/PrimitiveRoot.hs b/Math/NumberTheory/Moduli/PrimitiveRoot.hs --- a/Math/NumberTheory/Moduli/PrimitiveRoot.hs +++ b/Math/NumberTheory/Moduli/PrimitiveRoot.hs @@ -10,6 +10,7 @@ -- {-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE StandaloneDeriving #-} @@ -17,27 +18,38 @@ {-# LANGUAGE UndecidableInstances #-} module Math.NumberTheory.Moduli.PrimitiveRoot - ( isPrimitiveRoot - -- * Cyclic groups - , CyclicGroup(..) + ( -- * Cyclic groups + CyclicGroup(..) , cyclicGroupFromModulo , cyclicGroupToModulo + , groupSize + -- * Primitive roots + , PrimitiveRoot + , unPrimitiveRoot + , getGroup + , isPrimitiveRoot , isPrimitiveRoot' ) where -#if !(MIN_VERSION_base(4,8,0)) -import Control.Applicative -import Data.Word +#if __GLASGOW_HASKELL__ < 803 +import Data.Semigroup #endif import Math.NumberTheory.ArithmeticFunctions (totient) -import Math.NumberTheory.Moduli (Mod, getNatMod, getNatVal, KnownNat) +import qualified Math.NumberTheory.Euclidean as E +import Math.NumberTheory.Euclidean.Coprimes as Coprimes (singleton) +import Math.NumberTheory.Moduli.Class (getNatMod, getNatVal, KnownNat, Mod, MultMod, isMultElement) import Math.NumberTheory.Powers.General (highestPower) import Math.NumberTheory.Powers.Modular import Math.NumberTheory.Prefactored import Math.NumberTheory.UniqueFactorisation import Math.NumberTheory.Utils.FromIntegral +import Control.DeepSeq +import Control.Monad (guard) +import GHC.Generics +import Numeric.Natural + -- | A multiplicative group of residues is called cyclic, -- if there is a primitive root @g@, -- whose powers generates all elements. @@ -50,18 +62,22 @@ -- ^ Residues modulo @p@^@k@ for __odd__ prime @p@. | CGDoubleOddPrimePower (Prime a) Word -- ^ Residues modulo 2@p@^@k@ for __odd__ prime @p@. + deriving (Generic) +instance NFData (Prime a) => NFData (CyclicGroup a) + +deriving instance Eq (Prime a) => Eq (CyclicGroup a) deriving instance Show (Prime a) => Show (CyclicGroup a) -- | Check whether a multiplicative group of residues, -- characterized by its modulo, is cyclic and, if yes, return its form. -- --- > > cyclicGroupFromModulo 4 --- > Just CG4 --- > > cyclicGroupFromModulo (2 * 13 ^ 3) --- > Just (CGDoubleOddPrimePower (PrimeNat 13) 3) --- > > cyclicGroupFromModulo (4 * 13) --- > Nothing +-- >>> cyclicGroupFromModulo 4 +-- Just CG4 +-- >>> cyclicGroupFromModulo (2 * 13 ^ 3) +-- Just (CGDoubleOddPrimePower (PrimeNat 13) 3) +-- >>> cyclicGroupFromModulo (4 * 13) +-- Nothing cyclicGroupFromModulo :: (Ord a, Integral a, UniqueFactorisation a) => a @@ -88,61 +104,86 @@ -- | Extract modulo and its factorisation from -- a cyclic multiplicative group of residues. -- --- > > cyclicGroupToModulo CG4 --- > Prefactored {prefValue = 4, prefFactors = [(2, 2)]} --- > > cyclicGroupToModulo (CGDoubleOddPrimePower (PrimeNat 13) 3) --- > Prefactored {prefValue = 4394, prefFactors = [(2, 1), (13, 3)]} +-- >>> cyclicGroupToModulo CG4 +-- Prefactored {prefValue = 4, prefFactors = Coprimes {unCoprimes = fromList [(2,2)]}} +-- +-- >>> :set -XTypeFamilies +-- >>> cyclicGroupToModulo (CGDoubleOddPrimePower (PrimeNat 13) 3) +-- Prefactored {prefValue = 4394, prefFactors = Coprimes {unCoprimes = fromList [(2,1),(13,3)]}} cyclicGroupToModulo - :: (Integral a, UniqueFactorisation a) + :: (E.Euclidean a, Ord a, UniqueFactorisation a) => CyclicGroup a -> Prefactored a cyclicGroupToModulo = fromFactors . \case - CG2 -> [(2, 1)] - CG4 -> [(2, 2)] - CGOddPrimePower p k -> [(unPrime p, k)] - CGDoubleOddPrimePower p k -> [(2, 1), (unPrime p, k)] + CG2 -> Coprimes.singleton 2 1 + CG4 -> Coprimes.singleton 2 2 + CGOddPrimePower p k -> Coprimes.singleton (unPrime p) k + CGDoubleOddPrimePower p k -> Coprimes.singleton 2 1 + <> Coprimes.singleton (unPrime p) k +-- | 'PrimitiveRoot m' is a type which is only inhabited by primitive roots of n. +data PrimitiveRoot m = PrimitiveRoot + { unPrimitiveRoot :: MultMod m -- ^ Extract primitive root value. + , getGroup :: CyclicGroup Natural -- ^ Get cyclic group structure. + } + deriving (Eq, Show) + -- | 'isPrimitiveRoot'' @cg@ @a@ checks whether @a@ is -- a -- of a given cyclic multiplicative group of residues @cg@. -- --- > > let Just cg = cyclicGroupFromModulo 13 --- > > isPrimitiveRoot cg 1 --- > False --- > > isPrimitiveRoot cg 2 --- > True +-- >>> let Just cg = cyclicGroupFromModulo 13 +-- >>> isPrimitiveRoot' cg 1 +-- False +-- >>> isPrimitiveRoot' cg 2 +-- True isPrimitiveRoot' :: (Integral a, UniqueFactorisation a) => CyclicGroup a -> a -> Bool -isPrimitiveRoot' cg r = r /= 0 && gcd r (prefValue m) == 1 && all (/= 1) exps +-- https://en.wikipedia.org/wiki/Primitive_root_modulo_n#Finding_primitive_roots +isPrimitiveRoot' cg r = + case cg of + CG2 -> r == 1 + CG4 -> r == 3 + CGOddPrimePower p k -> oddPrimePowerTest (unPrime p) k r + CGDoubleOddPrimePower p k -> doubleOddPrimePowerTest (unPrime p) k r where - -- https://en.wikipedia.org/wiki/Primitive_root_modulo_n#Finding_primitive_roots - m = cyclicGroupToModulo cg - phi = totient m - pows = map (\pk -> prefValue phi `quot` unPrime (fst pk)) (factorise phi) - exps = map (\p -> powMod r p (prefValue m)) pows + oddPrimeTest p g = let phi = totient p + pows = map (\pk -> phi `quot` unPrime (fst pk)) (factorise phi) + exps = map (\x -> powMod g x p) pows + in g /= 0 && gcd g p == 1 && all (/= 1) exps + oddPrimePowerTest p 1 g = oddPrimeTest p (g `mod` p) + oddPrimePowerTest p _ g = oddPrimeTest p (g `mod` p) && powMod g (p-1) (p*p) /= 1 + doubleOddPrimePowerTest p k g = odd g && oddPrimePowerTest p k g -- | Check whether a given modular residue is -- a . -- --- > > isPrimitiveRoot (1 :: Mod 13) --- > False --- > > isPrimitiveRoot (2 :: Mod 13) --- > True +-- >>> :set -XDataKinds +-- >>> isPrimitiveRoot (1 :: Mod 13) +-- False +-- >>> isPrimitiveRoot (2 :: Mod 13) +-- True -- -- Here is how to list all primitive roots: -- --- > > filter isPrimitiveRoot [minBound .. maxBound] :: [Mod 13] --- > [(2 `modulo` 13), (6 `modulo` 13), (7 `modulo` 13), (11 `modulo` 13)] +-- >>> mapMaybe isPrimitiveRoot [minBound .. maxBound] :: [Mod 13] +-- [(2 `modulo` 13), (6 `modulo` 13), (7 `modulo` 13), (11 `modulo` 13)] -- -- This function is a convenient wrapper around 'isPrimitiveRoot''. The latter -- provides better control and performance, if you need them. isPrimitiveRoot :: KnownNat n => Mod n - -> Bool -isPrimitiveRoot r = case cyclicGroupFromModulo (getNatMod r) of - Nothing -> False - Just cg -> isPrimitiveRoot' cg (getNatVal r) + -> Maybe (PrimitiveRoot n) +isPrimitiveRoot r = do + r' <- isMultElement r + cg <- cyclicGroupFromModulo (getNatMod r) + guard $ isPrimitiveRoot' cg (getNatVal r) + return $ PrimitiveRoot r' cg + +-- | Calculate the size of a given cyclic group. +groupSize :: (E.Euclidean a, Ord a, UniqueFactorisation a) => CyclicGroup a -> Prefactored a +groupSize = totient . cyclicGroupToModulo diff --git a/Math/NumberTheory/Moduli/Sqrt.hs b/Math/NumberTheory/Moduli/Sqrt.hs --- a/Math/NumberTheory/Moduli/Sqrt.hs +++ b/Math/NumberTheory/Moduli/Sqrt.hs @@ -10,86 +10,160 @@ -- {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE CPP #-} module Math.NumberTheory.Moduli.Sqrt - ( sqrtModP - , sqrtModPList - , sqrtModP' - , tonelliShanks - , sqrtModPP - , sqrtModPPList - , sqrtModF - , sqrtModFList + ( -- * New interface + sqrtsMod + , sqrtsModFactorisation + , sqrtsModPrimePower + , sqrtsModPrime + -- * Old interface + , Old.sqrtModP + , Old.sqrtModPList + , Old.sqrtModP' + , Old.tonelliShanks + , Old.sqrtModPP + , Old.sqrtModPPList + , Old.sqrtModF + , Old.sqrtModFList ) where +import Control.Arrow hiding (loop) import Control.Monad (liftM2) import Data.Bits -import Data.List (nub) -#if __GLASGOW_HASKELL__ < 709 -import Data.Word -#endif -import GHC.Integer.GMP.Internals import Math.NumberTheory.Moduli.Chinese +import Math.NumberTheory.Moduli.Class (Mod, getVal, getMod, KnownNat) import Math.NumberTheory.Moduli.Jacobi +import Math.NumberTheory.Powers.Modular (powMod) +import qualified Math.NumberTheory.Primes.Factorisation as F (factorise) +import Math.NumberTheory.Primes.Types import Math.NumberTheory.Primes.Sieve (sieveFrom) -import Math.NumberTheory.Utils (shiftToOddCount, splitOff) +import Math.NumberTheory.Utils (shiftToOddCount, splitOff, recipMod) +import Math.NumberTheory.Utils.FromIntegral --- | @sqrtModP n prime@ calculates a modular square root of @n@ modulo @prime@ --- if that exists. The second argument /must/ be a (positive) prime, otherwise --- the computation may not terminate and if it does, may yield a wrong result. --- The precondition is /not/ checked. +import qualified Math.NumberTheory.Moduli.SqrtOld as Old + +-- | List all modular square roots. -- --- If @prime@ is a prime and @n@ a quadratic residue modulo @prime@, the result --- is @Just r@ where @r^2 ≡ n (mod prime)@, if @n@ is a quadratic nonresidue, --- the result is @Nothing@. -sqrtModP :: Integer -> Integer -> Maybe Integer -sqrtModP n 2 = Just (n `mod` 2) -sqrtModP n prime = case jacobi' n prime of - MinusOne -> Nothing - Zero -> Just 0 - One -> Just (sqrtModP' (n `mod` prime) prime) +-- >>> :set -XDataKinds +-- >>> sqrtsMod (1 :: Mod 60) +-- > [(1 `modulo` 60),(49 `modulo` 60),(41 `modulo` 60),(29 `modulo` 60),(31 `modulo` 60),(19 `modulo` 60),(11 `modulo` 60),(59 `modulo` 60)] +sqrtsMod :: KnownNat m => Mod m -> [Mod m] +sqrtsMod a = map fromInteger $ sqrtsModFactorisation (getVal a) (factorise (getMod a)) + where + factorise = map (PrimeNat . integerToNatural *** intToWord) . F.factorise --- | @sqrtModPList n prime@ computes the list of all square roots of @n@ --- modulo @prime@. @prime@ /must/ be a (positive) prime. --- The precondition is /not/ checked. -sqrtModPList :: Integer -> Integer -> [Integer] -sqrtModPList n prime - | prime == 2 = [n `mod` 2] - | otherwise = case sqrtModP n prime of - Just 0 -> [0] - Just r -> [r,prime-r] -- The group of units in Z/(p) is cyclic - _ -> [] +-- | List all square roots modulo a number, which factorisation is passed as a second argument. +-- +-- >>> sqrtsModFactorisation 1 (factorise 60) +-- [1,49,41,29,31,19,11,59] +sqrtsModFactorisation :: Integer -> [(Prime Integer, Word)] -> [Integer] +sqrtsModFactorisation _ [] = [0] +sqrtsModFactorisation n pps = map fst $ foldl1 (liftM2 comb) cs + where + ms :: [Integer] + ms = map (\(PrimeNat p, pow) -> toInteger p ^ pow) pps + rs :: [[Integer]] + rs = map (\(p, pow) -> sqrtsModPrimePower n p pow) pps + + cs :: [[(Integer, Integer)]] + cs = zipWith (\l m -> map (\x -> (x, m)) l) rs ms + + comb t1@(_, m1) t2@(_, m2) = (chineseRemainder2 t1 t2, m1 * m2) + +-- | List all square roots modulo power of a prime. +-- +-- >>> sqrtsModPrimePower 7 (fromJust (isPrime 3)) 2 +-- [4,5] +-- >>> sqrtsModPrimePower 9 (fromJust (isPrime 3)) 3 +-- [3,12,21,24,6,15] +sqrtsModPrimePower :: Integer -> Prime Integer -> Word -> [Integer] +sqrtsModPrimePower nn p 1 = sqrtsModPrime nn p +sqrtsModPrimePower nn (PrimeNat (toInteger -> prime)) expo = let primeExpo = prime ^ expo in + case splitOff prime (nn `mod` primeExpo) of + (_, 0) -> [0, prime ^ ((expo + 1) `quot` 2) .. primeExpo - 1] + (kk, n) + | odd kk -> [] + | otherwise -> case (if prime == 2 then sqM2P n expo' else sqrtModPP' n prime expo') of + Nothing -> [] + Just r -> let rr = r * prime ^ k in + if prime == 2 && k + 1 == t + then go rr os + else go rr os ++ go (primeExpo - rr) os + where + k = intToWord kk `quot` 2 + t = (if prime == 2 then expo - k - 1 else expo - k) `max` ((expo + 1) `quot` 2) + expo' = expo - 2 * k + os = [0, prime ^ t .. primeExpo - 1] + + -- equivalent to map ((`mod` primeExpo) . (+ r)) rs, + -- but avoids division + go r rs = map (+ r) ps ++ map (+ (r - primeExpo)) qs + where + (ps, qs) = span (< primeExpo - r) rs + +-- | List all square roots by prime modulo. +-- +-- >>> sqrtsModPrime 1 (fromJust (isPrime 5)) +-- [1,4] +-- >>> sqrtsModPrime 0 (fromJust (isPrime 5)) +-- [0] +-- >>> sqrtsModPrime 2 (fromJust (isPrime 5)) +-- [] +sqrtsModPrime :: Integer -> Prime Integer -> [Integer] +sqrtsModPrime n (PrimeNat 2) = [n `mod` 2] +sqrtsModPrime n (PrimeNat (toInteger -> prime)) = case jacobi n prime of + MinusOne -> [] + Zero -> [0] + One -> let r = sqrtModP' (n `mod` prime) prime in [r, prime - r] + +------------------------------------------------------------------------------- +-- Internals + -- | @sqrtModP' square prime@ finds a square root of @square@ modulo -- prime. @prime@ /must/ be a (positive) prime, and @square@ /must/ be a positive -- quadratic residue modulo @prime@, i.e. @'jacobi square prime == 1@. --- The precondition is /not/ checked. sqrtModP' :: Integer -> Integer -> Integer sqrtModP' square prime | prime == 2 = square - | rem4 prime == 3 = powModInteger square ((prime + 1) `quot` 4) prime + | rem4 prime == 3 = powMod square ((prime + 1) `quot` 4) prime + | square `mod` prime == prime - 1 + = sqrtOfMinusOne prime | otherwise = tonelliShanks square prime +-- | p must be of form 4k + 1 +sqrtOfMinusOne :: Integer -> Integer +sqrtOfMinusOne p + = head + $ filter (\n -> n /= 1 && n /= p - 1) + $ map (\n -> powMod n k p) + [2..p-2] + where + k = (p - 1) `quot` 4 + -- | @tonelliShanks square prime@ calculates a square root of @square@ -- modulo @prime@, where @prime@ is a prime of the form @4*k + 1@ and -- @square@ is a positive quadratic residue modulo @prime@, using the -- Tonelli-Shanks algorithm. --- No checks on the input are performed. tonelliShanks :: Integer -> Integer -> Integer tonelliShanks square prime = loop rc t1 generator log2 where (log2,q) = shiftToOddCount (prime-1) nonSquare = findNonSquare prime - generator = powModInteger nonSquare q prime - rc = powModInteger square ((q+1) `quot` 2) prime - t1 = powModInteger square q prime + generator = powMod nonSquare q prime + rc = powMod square ((q+1) `quot` 2) prime + t1 = powMod square q prime msqr x = (x*x) `rem` prime msquare 0 x = x msquare k x = msquare (k-1) (msqr x) findPeriod per 1 = per findPeriod per x = findPeriod (per+1) (msqr x) + + loop :: Integer -> Integer -> Integer -> Int -> Integer loop !r t c m | t == 1 = r | otherwise = loop nextR nextT nextC nextM @@ -100,26 +174,22 @@ nextC = msqr b nextT = (t*nextC) `rem` prime --- | @sqrtModPP n (prime,expo)@ calculates a square root of @n@ --- modulo @prime^expo@ if one exists. @prime@ /must/ be a --- (positive) prime. @expo@ must be positive, @n@ must be coprime --- to @prime@ -sqrtModPP :: Integer -> (Integer,Int) -> Maybe Integer -sqrtModPP n (2,e) = sqM2P n e -sqrtModPP n (prime,expo) = case sqrtModP n prime of - Just r -> fixup r - _ -> Nothing +-- | prime must be odd, n must be coprime with prime +sqrtModPP' :: Integer -> Integer -> Word -> Maybe Integer +sqrtModPP' n prime expo = case sqrtsModPrime n (PrimeNat (fromInteger prime)) of + [] -> Nothing + r : _ -> fixup r where fixup r = let diff' = r*r-n in if diff' == 0 then Just r else case splitOff prime diff' of - (e,q) | expo <= e -> Just r + (e,q) | expo <= intToWord e -> Just r | otherwise -> fmap (\inv -> hoist inv r (q `mod` prime) (prime^e)) (recipMod (2*r) prime) hoist inv root elim pp | diff' == 0 = root' - | expo <= ex = root' + | expo <= intToWord ex = root' | otherwise = hoist inv root' (nelim `mod` prime) (prime^ex) where root' = (root + (inv*(prime-elim))*pp) `mod` (prime*pp) @@ -127,8 +197,8 @@ (ex, nelim) = splitOff prime diff' -- dirty, dirty -sqM2P :: Integer -> Int -> Maybe Integer -sqM2P n e +sqM2P :: Integer -> Word -> Maybe Integer +sqM2P n (wordToInt -> e) | e < 2 = Just (n `mod` 2) | n' == 0 = Just 0 | odd k = Nothing @@ -136,9 +206,9 @@ where mdl = 1 `shiftL` e n' = n `mod` mdl - (k,s) = shiftToOddCount n' + (k, s) = shiftToOddCount n' k2 = k `quot` 2 - e2 = e-k + e2 = e - k solve _ 1 = Just 1 solve 1 _ = Just 1 solve r _ @@ -154,60 +224,12 @@ d = x'*x' - r pw' = if d == 0 then e2 else fst (shiftToOddCount d) --- | @sqrtModF n primePowers@ calculates a square root of @n@ modulo --- @product [p^k | (p,k) <- primePowers]@ if one exists and all primes --- are distinct. --- The list must be non-empty, @n@ must be coprime with all primes. -sqrtModF :: Integer -> [(Integer,Int)] -> Maybe Integer -sqrtModF _ [] = Nothing -sqrtModF n pps = do roots <- mapM (sqrtModPP n) pps - chineseRemainder $ zip roots (map (uncurry (^)) pps) - --- | @sqrtModFList n primePowers@ calculates all square roots of @n@ modulo --- @product [p^k | (p,k) <- primePowers]@ if all primes are distinct. --- The list must be non-empty, @n@ must be coprime with all primes. -sqrtModFList :: Integer -> [(Integer,Int)] -> [Integer] -sqrtModFList _ [] = [] -sqrtModFList n pps = map fst $ foldl1 (liftM2 comb) cs - where - ms :: [Integer] - ms = map (uncurry (^)) pps - rs :: [[Integer]] - rs = map (sqrtModPPList n) pps - cs :: [[(Integer,Integer)]] - cs = zipWith (\l m -> map (\x -> (x,m)) l) rs ms - comb t1@(_,m1) t2@(_,m2) = (chineseRemainder2 t1 t2,m1*m2) - --- | @sqrtModPPList n (prime,expo)@ calculates the list of all --- square roots of @n@ modulo @prime^expo@. The same restriction --- as in 'sqrtModPP' applies to the arguments. -sqrtModPPList :: Integer -> (Integer,Int) -> [Integer] -sqrtModPPList n (2,1) = [n `mod` 2] -sqrtModPPList n (2,expo) - = case sqM2P n expo of - Just r -> let m = 1 `shiftL` (expo-1) - in nub [r, (r+m) `mod` (2*m), (m-r) `mod` (2*m), 2*m-r] - _ -> [] -sqrtModPPList n pe@(prime,expo) - = case sqrtModPP n pe of - Just 0 -> [0] - Just r -> [prime^expo - r, r] -- The group of units in Z/(p^e) is cyclic - _ -> [] - - +------------------------------------------------------------------------------- -- Utilities -{-# SPECIALISE rem4 :: Integer -> Int, - Int -> Int, - Word -> Int - #-} rem4 :: Integral a => a -> Int rem4 n = fromIntegral n .&. 3 -{-# SPECIALISE rem8 :: Integer -> Int, - Int -> Int, - Word -> Int - #-} rem8 :: Integral a => a -> Int rem8 n = fromIntegral n .&. 7 @@ -218,12 +240,7 @@ where primelist = [3,5,7,11,13,17,19,23,29,31,37,41,43,47,53,59,61,67] ++ sieveFrom (68 + n `rem` 4) -- prevent sharing - search (p:ps) = case jacobi' p n of + search (p:ps) = case jacobi p n of MinusOne -> p _ -> search ps search _ = error "Should never have happened, prime list exhausted." - -recipMod :: Integer -> Integer -> Maybe Integer -recipMod x m = case recipModInteger x m of - 0 -> Nothing - y -> Just y diff --git a/Math/NumberTheory/Moduli/SqrtOld.hs b/Math/NumberTheory/Moduli/SqrtOld.hs new file mode 100644 --- /dev/null +++ b/Math/NumberTheory/Moduli/SqrtOld.hs @@ -0,0 +1,234 @@ +-- | +-- Module: Math.NumberTheory.Moduli.Sqrt +-- Copyright: (c) 2011 Daniel Fischer +-- Licence: MIT +-- Maintainer: Andrew Lelechenko +-- Stability: Provisional +-- Portability: Non-portable (GHC extensions) +-- +-- Modular square roots. +-- + +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} + +module Math.NumberTheory.Moduli.SqrtOld + ( sqrtModP + , sqrtModPList + , sqrtModP' + , tonelliShanks + , sqrtModPP + , sqrtModPPList + , sqrtModF + , sqrtModFList + ) where + +import Control.Monad (liftM2) +import Data.Bits +import Data.List (nub) +#if __GLASGOW_HASKELL__ < 709 +import Data.Word +#endif +import GHC.Integer.GMP.Internals + +import Math.NumberTheory.Moduli.Chinese +import Math.NumberTheory.Moduli.Jacobi +import Math.NumberTheory.Primes.Sieve (sieveFrom) +import Math.NumberTheory.Utils (shiftToOddCount, splitOff) + +{-# DEPRECATED sqrtModP, sqrtModP', sqrtModPList, tonelliShanks "Use 'Math.NumberTheory.Moduli.Sqrt.sqrtsModPrime' instead" #-} +{-# DEPRECATED sqrtModPP, sqrtModPPList "Use 'Math.NumberTheory.Moduli.Sqrt.sqrtsModPrimePower' instead" #-} +{-# DEPRECATED sqrtModF, sqrtModFList "Use 'Math.NumberTheory.Moduli.Sqrt.sqrtsModFactorisation' or 'Math.NumberTheory.Moduli.Sqrt.sqrtsMod' instead" #-} + + +-- | @sqrtModP n prime@ calculates a modular square root of @n@ modulo @prime@ +-- if that exists. The second argument /must/ be a (positive) prime, otherwise +-- the computation may not terminate and if it does, may yield a wrong result. +-- The precondition is /not/ checked. +-- +-- If @prime@ is a prime and @n@ a quadratic residue modulo @prime@, the result +-- is @Just r@ where @r^2 ≡ n (mod prime)@, if @n@ is a quadratic nonresidue, +-- the result is @Nothing@. +sqrtModP :: Integer -> Integer -> Maybe Integer +sqrtModP n 2 = Just (n `mod` 2) +sqrtModP n prime = case jacobi n prime of + MinusOne -> Nothing + Zero -> Just 0 + One -> Just (sqrtModP' (n `mod` prime) prime) + +-- | @sqrtModPList n prime@ computes the list of all square roots of @n@ +-- modulo @prime@. @prime@ /must/ be a (positive) prime. +-- The precondition is /not/ checked. +sqrtModPList :: Integer -> Integer -> [Integer] +sqrtModPList n prime + | prime == 2 = [n `mod` 2] + | otherwise = case sqrtModP n prime of + Just 0 -> [0] + Just r -> [r,prime-r] -- The group of units in Z/(p) is cyclic + _ -> [] + +-- | @sqrtModP' square prime@ finds a square root of @square@ modulo +-- prime. @prime@ /must/ be a (positive) prime, and @square@ /must/ be a positive +-- quadratic residue modulo @prime@, i.e. @'jacobi square prime == 1@. +-- The precondition is /not/ checked. +sqrtModP' :: Integer -> Integer -> Integer +sqrtModP' square prime + | prime == 2 = square + | rem4 prime == 3 = powModInteger square ((prime + 1) `quot` 4) prime + | otherwise = tonelliShanks square prime + +-- | @tonelliShanks square prime@ calculates a square root of @square@ +-- modulo @prime@, where @prime@ is a prime of the form @4*k + 1@ and +-- @square@ is a positive quadratic residue modulo @prime@, using the +-- Tonelli-Shanks algorithm. +-- No checks on the input are performed. +tonelliShanks :: Integer -> Integer -> Integer +tonelliShanks square prime = loop rc t1 generator log2 + where + (log2,q) = shiftToOddCount (prime-1) + nonSquare = findNonSquare prime + generator = powModInteger nonSquare q prime + rc = powModInteger square ((q+1) `quot` 2) prime + t1 = powModInteger square q prime + msqr x = (x*x) `rem` prime + msquare 0 x = x + msquare k x = msquare (k-1) (msqr x) + findPeriod per 1 = per + findPeriod per x = findPeriod (per+1) (msqr x) + loop !r t c m + | t == 1 = r + | otherwise = loop nextR nextT nextC nextM + where + nextM = findPeriod 0 t + b = msquare (m - 1 - nextM) c + nextR = (r*b) `rem` prime + nextC = msqr b + nextT = (t*nextC) `rem` prime + +-- | @sqrtModPP n (prime,expo)@ calculates a square root of @n@ +-- modulo @prime^expo@ if one exists. @prime@ /must/ be a +-- (positive) prime. @expo@ must be positive, @n@ must be coprime +-- to @prime@ +sqrtModPP :: Integer -> (Integer,Int) -> Maybe Integer +sqrtModPP n (2,e) = sqM2P n e +sqrtModPP n (prime,expo) = case sqrtModP n prime of + Just r -> fixup r + _ -> Nothing + where + fixup r = let diff' = r*r-n + in if diff' == 0 + then Just r + else case splitOff prime diff' of + (e,q) | expo <= e -> Just r + | otherwise -> fmap (\inv -> hoist inv r (q `mod` prime) (prime^e)) (recipMod (2*r) prime) + + hoist inv root elim pp + | diff' == 0 = root' + | expo <= ex = root' + | otherwise = hoist inv root' (nelim `mod` prime) (prime^ex) + where + root' = (root + (inv*(prime-elim))*pp) `mod` (prime*pp) + diff' = root'*root' - n + (ex, nelim) = splitOff prime diff' + +-- dirty, dirty +sqM2P :: Integer -> Int -> Maybe Integer +sqM2P n e + | e < 2 = Just (n `mod` 2) + | n' == 0 = Just 0 + | odd k = Nothing + | otherwise = fmap ((`mod` mdl) . (`shiftL` k2)) $ solve s e2 + where + mdl = 1 `shiftL` e + n' = n `mod` mdl + (k,s) = shiftToOddCount n' + k2 = k `quot` 2 + e2 = e-k + solve _ 1 = Just 1 + solve 1 _ = Just 1 + solve r _ + | rem4 r == 3 = Nothing -- otherwise r ≡ 1 (mod 4) + | rem8 r == 5 = Nothing -- otherwise r ≡ 1 (mod 8) + | otherwise = fixup r (fst $ shiftToOddCount (r-1)) + where + fixup x pw + | pw >= e2 = Just x + | otherwise = fixup x' pw' + where + x' = x + (1 `shiftL` (pw-1)) + d = x'*x' - r + pw' = if d == 0 then e2 else fst (shiftToOddCount d) + +-- | @sqrtModF n primePowers@ calculates a square root of @n@ modulo +-- @product [p^k | (p,k) <- primePowers]@ if one exists and all primes +-- are distinct. +-- The list must be non-empty, @n@ must be coprime with all primes. +sqrtModF :: Integer -> [(Integer,Int)] -> Maybe Integer +sqrtModF _ [] = Nothing +sqrtModF n pps = do roots <- mapM (sqrtModPP n) pps + chineseRemainder $ zip roots (map (uncurry (^)) pps) + +-- | @sqrtModFList n primePowers@ calculates all square roots of @n@ modulo +-- @product [p^k | (p,k) <- primePowers]@ if all primes are distinct. +-- The list must be non-empty, @n@ must be coprime with all primes. +sqrtModFList :: Integer -> [(Integer,Int)] -> [Integer] +sqrtModFList _ [] = [] +sqrtModFList n pps = map fst $ foldl1 (liftM2 comb) cs + where + ms :: [Integer] + ms = map (uncurry (^)) pps + rs :: [[Integer]] + rs = map (sqrtModPPList n) pps + cs :: [[(Integer,Integer)]] + cs = zipWith (\l m -> map (\x -> (x,m)) l) rs ms + comb t1@(_,m1) t2@(_,m2) = (chineseRemainder2 t1 t2,m1*m2) + +-- | @sqrtModPPList n (prime,expo)@ calculates the list of all +-- square roots of @n@ modulo @prime^expo@. The same restriction +-- as in 'sqrtModPP' applies to the arguments. +sqrtModPPList :: Integer -> (Integer,Int) -> [Integer] +sqrtModPPList n (2,1) = [n `mod` 2] +sqrtModPPList n (2,expo) + = case sqM2P n expo of + Just r -> let m = 1 `shiftL` (expo-1) + in nub [r, (r+m) `mod` (2*m), (m-r) `mod` (2*m), 2*m-r] + _ -> [] +sqrtModPPList n pe@(prime,expo) + = case sqrtModPP n pe of + Just 0 -> [0] + Just r -> [prime^expo - r, r] -- The group of units in Z/(p^e) is cyclic + _ -> [] + + +-- Utilities + +{-# SPECIALISE rem4 :: Integer -> Int, + Int -> Int, + Word -> Int + #-} +rem4 :: Integral a => a -> Int +rem4 n = fromIntegral n .&. 3 + +{-# SPECIALISE rem8 :: Integer -> Int, + Int -> Int, + Word -> Int + #-} +rem8 :: Integral a => a -> Int +rem8 n = fromIntegral n .&. 7 + +findNonSquare :: Integer -> Integer +findNonSquare n + | rem8 n == 5 || rem8 n == 3 = 2 + | otherwise = search primelist + where + primelist = [3,5,7,11,13,17,19,23,29,31,37,41,43,47,53,59,61,67] + ++ sieveFrom (68 + n `rem` 4) -- prevent sharing + search (p:ps) = case jacobi p n of + MinusOne -> p + _ -> search ps + search _ = error "Should never have happened, prime list exhausted." + +recipMod :: Integer -> Integer -> Maybe Integer +recipMod x m = case recipModInteger x m of + 0 -> Nothing + y -> Just y diff --git a/Math/NumberTheory/Powers/Cubes.hs b/Math/NumberTheory/Powers/Cubes.hs --- a/Math/NumberTheory/Powers/Cubes.hs +++ b/Math/NumberTheory/Powers/Cubes.hs @@ -197,24 +197,17 @@ appCuRt :: Integer -> Integer appCuRt (S# i#) = case double2Int# (int2Double# i# **## (1.0## /## 3.0##)) of r# -> S# r# -#if __GLASGOW_HASKELL__ < 709 -appCuRt n@(J# s# _) - | isTrue# (s# <# THRESH#) = floor (fromInteger n ** (1.0/3.0) :: Double) -#else appCuRt n@(Jp# bn#) | isTrue# ((sizeofBigNat# bn#) <# THRESH#) = floor (fromInteger n ** (1.0/3.0) :: Double) -#endif | otherwise = case integerLog2# n of l# -> case (l# `quotInt#` 3#) -# 51# of h# -> case shiftRInteger n (3# *# h#) of m -> case floor (fromInteger m ** (1.0/3.0) :: Double) of r -> shiftLInteger r h# -#if __GLASGOW_HASKELL__ >= 709 -- There's already handling for negative in integerCubeRoot, -- but integerCubeRoot' is exported directly too. appCuRt _ = error "integerCubeRoot': negative argument" -#endif -- not very discriminating, but cheap, so it's an overall gain cr512 :: UArray Int Bool diff --git a/Math/NumberTheory/Powers/Fourth.hs b/Math/NumberTheory/Powers/Fourth.hs --- a/Math/NumberTheory/Powers/Fourth.hs +++ b/Math/NumberTheory/Powers/Fourth.hs @@ -138,24 +138,17 @@ -- About 48 bits should be correct for large Integers. appBiSqrt :: Integer -> Integer appBiSqrt (S# i#) = S# (double2Int# (sqrtDouble# (sqrtDouble# (int2Double# i#)))) -#if __GLASGOW_HASKELL__ < 709 -appBiSqrt n@(J# s# _) - | isTrue# (s# <# THRESH#) = floor (sqrt . sqrt $ fromInteger n :: Double) -#else appBiSqrt n@(Jp# bn#) | isTrue# ((sizeofBigNat# bn#) <# THRESH#) = floor (sqrt . sqrt $ fromInteger n :: Double) -#endif | otherwise = case integerLog2# n of l# -> case uncheckedIShiftRA# l# 2# -# 47# of h# -> case shiftRInteger n (4# *# h#) of m -> case floor (sqrt $ sqrt $ fromInteger m :: Double) of r -> shiftLInteger r h# -#if __GLASGOW_HASKELL__ >= 709 -- There's already a check for negative in integerFourthRoot, -- but integerFourthRoot' is exported directly too. appBiSqrt _ = error "integerFourthRoot': negative argument" -#endif biSqRes256 :: UArray Int Bool diff --git a/Math/NumberTheory/Powers/Modular.hs b/Math/NumberTheory/Powers/Modular.hs --- a/Math/NumberTheory/Powers/Modular.hs +++ b/Math/NumberTheory/Powers/Modular.hs @@ -14,29 +14,25 @@ module Math.NumberTheory.Powers.Modular ( powMod -#if __GLASGOW_HASKELL__ > 709 , powModWord , powModInt -#endif ) where import qualified GHC.Integer.GMP.Internals as GMP (powModInteger) -#if __GLASGOW_HASKELL__ > 709 import GHC.Exts (Word(..)) import GHC.Natural (powModNatural) import qualified GHC.Integer.GMP.Internals as GMP (powModWord) import Math.NumberTheory.Utils.FromIntegral -#endif -- | @powMod@ @b@ @e@ @m@ computes (@b^e@) \`mod\` @m@ in effective way. -- An exponent @e@ must be non-negative, a modulo @m@ must be positive. -- Otherwise the behaviour of @powMod@ is undefined. -- --- > > powMod 2 3 5 --- > 3 --- > > powMod 3 12345678901234567890 1001 --- > 1 +-- >>> powMod 2 3 5 +-- 3 +-- >>> powMod 3 12345678901234567890 1001 +-- 1 -- -- See also 'Math.NumberTheory.Moduli.Class.powMod' and 'Math.NumberTheory.Moduli.Class.powSomeMod'. -- @@ -46,12 +42,12 @@ -- need both to fit into machine word and to handle large moduli, -- take a look at 'powModInt' and 'powModWord'. -- --- > > powMod 3 101 (2^60-1 :: Integer) --- > 1018105167100379328 -- correct --- > > powMod 3 101 (2^60-1 :: Int64) --- > 1115647832265427613 -- incorrect due to overflow --- > > powModInt 3 101 (2^60-1 :: Int) --- > 1018105167100379328 -- correct +-- >>> powMod 3 101 (2^60-1 :: Integer) +-- 1018105167100379328 -- correct +-- >>> powMod 3 101 (2^60-1 :: Int64) +-- 1115647832265427613 -- incorrect due to overflow +-- >>> powModInt 3 101 (2^60-1 :: Int) +-- 1018105167100379328 -- correct powMod :: (Integral a, Integral b) => a -> b -> a -> a powMod x y m | m <= 0 = error "powModInt: non-positive modulo" @@ -71,7 +67,6 @@ powModInteger :: Integer -> Integer -> Integer -> Integer powModInteger b e m = GMP.powModInteger (b `mod` m) e m -#if __GLASGOW_HASKELL__ > 709 {-# RULES "powMod/Natural" powMod = powModNatural "powMod/Word" powMod = powModWord @@ -80,18 +75,17 @@ -- | Specialised version of 'powMod', able to handle large moduli correctly. -- --- > > powModWord 3 101 (2^60-1) --- > 1018105167100379328 +-- >>> powModWord 3 101 (2^60-1) +-- 1018105167100379328 powModWord :: Word -> Word -> Word -> Word powModWord (W# x) (W# y) (W# m) = W# (GMP.powModWord x y m) -- | Specialised version of 'powMod', able to handle large moduli correctly. -- --- > > powModInt 3 101 (2^60-1) --- > 1018105167100379328 +-- >> powModInt 3 101 (2^60-1) +-- 1018105167100379328 powModInt :: Int -> Int -> Int -> Int powModInt x y m | m <= 0 = error "powModInt: non-positive modulo" | y < 0 = error "powModInt: negative exponent" | otherwise = wordToInt $ powModWord (intToWord (x `mod` m)) (intToWord y) (intToWord m) -#endif diff --git a/Math/NumberTheory/Powers/Squares.hs b/Math/NumberTheory/Powers/Squares.hs --- a/Math/NumberTheory/Powers/Squares.hs +++ b/Math/NumberTheory/Powers/Squares.hs @@ -29,9 +29,6 @@ import Data.Array.ST import Data.Bits -#if __GLASGOW_HASKELL__ < 709 -import Data.Word -- Moved to GHC.Types -#endif import Math.NumberTheory.Unsafe diff --git a/Math/NumberTheory/Powers/Squares/Internal.hs b/Math/NumberTheory/Powers/Squares/Internal.hs --- a/Math/NumberTheory/Powers/Squares/Internal.hs +++ b/Math/NumberTheory/Powers/Squares/Internal.hs @@ -14,6 +14,8 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} +{-# OPTIONS_HADDOCK hide #-} + module Math.NumberTheory.Powers.Squares.Internal ( karatsubaSqrt , isqrtA @@ -66,24 +68,17 @@ -- for large Integers. appSqrt :: Integer -> Integer appSqrt (S# i#) = S# (double2Int# (sqrtDouble# (int2Double# i#))) -#if __GLASGOW_HASKELL__ < 709 -appSqrt n@(J# s# _) - | isTrue# (s# <# THRESH#) = floor (sqrt $ fromInteger n :: Double) -#else appSqrt n@(Jp# bn#) | isTrue# ((sizeofBigNat# bn#) <# THRESH#) = floor (sqrt $ fromInteger n :: Double) -#endif | otherwise = case integerLog2# n of l# -> case uncheckedIShiftRA# l# 1# -# 47# of h# -> case shiftRInteger n (2# *# h#) of m -> case floor (sqrt $ fromInteger m :: Double) of r -> shiftLInteger r h# -#if __GLASGOW_HASKELL__ >= 709 -- There's already a check for negative in integerSquareRoot, -- but integerSquareRoot' is exported directly too. appSqrt _ = error "integerSquareRoot': negative argument" -#endif -- Integer square root with remainder, using the Karatsuba Square Root diff --git a/Math/NumberTheory/Prefactored.hs b/Math/NumberTheory/Prefactored.hs --- a/Math/NumberTheory/Prefactored.hs +++ b/Math/NumberTheory/Prefactored.hs @@ -9,9 +9,11 @@ -- Type for numbers, accompanied by their factorisation. -- -{-# LANGUAGE CPP #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} + module Math.NumberTheory.Prefactored ( Prefactored(prefValue, prefFactors) , fromValue @@ -20,13 +22,11 @@ import Control.Arrow -import Math.NumberTheory.GCD (splitIntoCoprimes) -import Math.NumberTheory.UniqueFactorisation +import Data.Semigroup -#if MIN_VERSION_base(4,8,0) -#else -import Data.Word -#endif +import Math.NumberTheory.Euclidean +import Math.NumberTheory.Euclidean.Coprimes +import Math.NumberTheory.UniqueFactorisation -- | A container for a number and its pairwise coprime (but not neccessarily prime) -- factorisation. @@ -36,43 +36,44 @@ -- -- For instance, let @p@ and @q@ be big primes: -- --- > > let p, q :: Integer --- > > p = 1000000000000000000000000000057 --- > > q = 2000000000000000000000000000071 +-- >>> let p, q :: Integer +-- >>> p = 1000000000000000000000000000057 +-- >>> q = 2000000000000000000000000000071 -- -- It would be difficult to compute prime factorisation of their product -- as is: -- 'factorise' would take ages. Things become different if we simply -- change types of @p@ and @q@ to prefactored ones: -- --- > > let p, q :: Prefactored Integer --- > > p = 1000000000000000000000000000057 --- > > q = 2000000000000000000000000000071 +-- >>> let p, q :: Prefactored Integer +-- >>> p = 1000000000000000000000000000057 +-- >>> q = 2000000000000000000000000000071 -- -- Now prime factorisation is done instantly: -- --- > > factorise (p * q) --- > [(PrimeNat 1000000000000000000000000000057, 1), (PrimeNat 2000000000000000000000000000071, 1)] --- > > factorise (p^2 * q^3) --- > [(PrimeNat 1000000000000000000000000000057, 2), (PrimeNat 2000000000000000000000000000071, 3)] +-- >>> factorise (p * q) +-- [(PrimeNat 1000000000000000000000000000057, 1), (PrimeNat 2000000000000000000000000000071, 1)] +-- >>> factorise (p^2 * q^3) +-- [(PrimeNat 1000000000000000000000000000057, 2), (PrimeNat 2000000000000000000000000000071, 3)] -- -- Moreover, we can instantly compute 'totient' and its iterations. -- It works fine, because output of 'totient' is also prefactored. -- --- > > prefValue $ totient (p^2 * q^3) --- > 8000000000000000000000000001752000000000000000000000000151322000000000000000000000006445392000000000000000000000135513014000000000000000000001126361040 --- > > prefValue $ totient $ totient (p^2 * q^3) --- > 2133305798262843681544648472180210822742702690942899511234131900112583590230336435053688694839034890779375223070157301188739881477320529552945446912000 +-- >>> prefValue $ totient (p^2 * q^3) +-- 8000000000000000000000000001752000000000000000000000000151322000000000000000000000006445392000000000000000000000135513014000000000000000000001126361040 +-- >>> prefValue $ totient $ totient (p^2 * q^3) +-- 2133305798262843681544648472180210822742702690942899511234131900112583590230336435053688694839034890779375223070157301188739881477320529552945446912000 -- -- Let us look under the hood: -- --- > > prefFactors $ totient (p^2 * q^3) --- > [(2, 4), (41666666666666666666666666669, 1), (3, 3), (111111111111111111111111111115, 1), --- > (1000000000000000000000000000057, 1), (2000000000000000000000000000071, 2)] --- > > prefFactors $ totient $ totient (p^2 * q^3) --- > [(2, 22), (39521, 1), (5, 3), (199937, 1), (3, 8), (6046667, 1), (227098769, 1), --- > (85331809838489, 1), (361696272343, 1), (22222222222222222222222222223, 1), --- > (41666666666666666666666666669, 1), (2000000000000000000000000000071, 1)] +-- >>> prefFactors $ totient (p^2 * q^3) +-- Coprimes {unCoprimes = fromList [(2,4),(3,3), +-- (41666666666666666666666666669,1),(111111111111111111111111111115,1), +-- (1000000000000000000000000000057,1),(2000000000000000000000000000071,2)]} +-- >>> prefFactors $ totient $ totient (p^2 * q^3) +-- Coprimes {unCoprimes = fromList [(2,22),(3,8),(5,3),(39521,1),(199937,1),(6046667,1), +-- (227098769,1),(361696272343,1),(85331809838489,1),(22222222222222222222222222223,1), +-- (41666666666666666666666666669,1),(2000000000000000000000000000071,1)]} -- -- Pairwise coprimality of factors is crucial, because it allows -- us to process them independently, possibly even @@ -84,47 +85,46 @@ data Prefactored a = Prefactored { prefValue :: a -- ^ Number itself. - , prefFactors :: [(a, Word)] + , prefFactors :: Coprimes a Word -- ^ List of pairwise coprime (but not neccesarily prime) factors, -- accompanied by their multiplicities. } deriving (Show) -- | Create 'Prefactored' from a given number. -- --- > > fromValue 123 --- > Prefactored {prefValue = 123, prefFactors = [(123, 1)]} -fromValue :: a -> Prefactored a -fromValue a = Prefactored a [(a, 1)] +-- >>> fromValue 123 +-- Prefactored {prefValue = 123, prefFactors = Coprimes {unCoprimes = fromList [(123,1)]}} +fromValue :: (Eq a, Num a) => a -> Prefactored a +fromValue a = Prefactored a (singleton a 1) -- | Create 'Prefactored' from a given list of pairwise coprime -- (but not neccesarily prime) factors with multiplicities. --- If you cannot ensure coprimality, use 'splitIntoCoprimes'. -- --- > > fromFactors (splitIntoCoprimes [(140, 1), (165, 1)]) --- > Prefactored {prefValue = 23100, prefFactors = [(5, 2), (28, 1), (33, 1)]} --- > > fromFactors (splitIntoCoprimes [(140, 2), (165, 3)]) --- > Prefactored {prefValue = 88045650000, prefFactors = [(5, 5), (28, 2), (33, 3)]} -fromFactors :: Integral a => [(a, Word)] -> Prefactored a -fromFactors as = Prefactored (product (map (uncurry (^)) as)) (splitIntoCoprimes as) +-- >>> fromFactors (splitIntoCoprimes [(140, 1), (165, 1)]) +-- Prefactored {prefValue = 23100, prefFactors = Coprimes {unCoprimes = fromList [(5,2),(28,1),(33,1)]}} +-- >>> fromFactors (splitIntoCoprimes [(140, 2), (165, 3)]) +-- Prefactored {prefValue = 88045650000, prefFactors = Coprimes {unCoprimes = fromList [(5,5),(28,2),(33,3)]}} +fromFactors :: Num a => Coprimes a Word -> Prefactored a +fromFactors as = Prefactored (product (map (uncurry (^)) (unCoprimes as))) as -instance (Integral a, UniqueFactorisation a) => Num (Prefactored a) where +instance (Euclidean a, Ord a) => Num (Prefactored a) where Prefactored v1 _ + Prefactored v2 _ = fromValue (v1 + v2) Prefactored v1 _ - Prefactored v2 _ = fromValue (v1 - v2) Prefactored v1 f1 * Prefactored v2 f2 - = Prefactored (v1 * v2) (splitIntoCoprimes (f1 ++ f2)) + = Prefactored (v1 * v2) (f1 <> f2) negate (Prefactored v f) = Prefactored (negate v) f abs (Prefactored v f) = Prefactored (abs v) f - signum (Prefactored v _) = Prefactored (signum v) [] + signum (Prefactored v _) = Prefactored (signum v) mempty fromInteger n = fromValue (fromInteger n) type instance Prime (Prefactored a) = Prime a -instance UniqueFactorisation a => UniqueFactorisation (Prefactored a) where +instance (Eq a, Num a, UniqueFactorisation a) => UniqueFactorisation (Prefactored a) where unPrime p = fromValue (unPrime p) factorise (Prefactored _ f) - = concatMap (\(x, xm) -> map (second (* xm)) (factorise x)) f - isPrime (Prefactored _ f) = case f of + = concatMap (\(x, xm) -> map (second (* xm)) (factorise x)) (unCoprimes f) + isPrime (Prefactored _ f) = case unCoprimes f of [(n, 1)] -> isPrime n _ -> Nothing diff --git a/Math/NumberTheory/Primes.hs b/Math/NumberTheory/Primes.hs --- a/Math/NumberTheory/Primes.hs +++ b/Math/NumberTheory/Primes.hs @@ -15,5 +15,5 @@ import Math.NumberTheory.Primes.Sieve import Math.NumberTheory.Primes.Counting -import Math.NumberTheory.Primes.Testing hiding (FactorSieve) +import Math.NumberTheory.Primes.Testing import Math.NumberTheory.Primes.Factorisation diff --git a/Math/NumberTheory/Primes/Counting/Impl.hs b/Math/NumberTheory/Primes/Counting/Impl.hs --- a/Math/NumberTheory/Primes/Counting/Impl.hs +++ b/Math/NumberTheory/Primes/Counting/Impl.hs @@ -8,7 +8,11 @@ -- -- Number of primes not exceeding @n@, @π(n)@, and @n@-th prime. -- -{-# LANGUAGE CPP, BangPatterns, FlexibleContexts #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} + {-# OPTIONS_GHC -fspec-constr-count=24 #-} {-# OPTIONS_HADDOCK hide #-} module Math.NumberTheory.Primes.Counting.Impl @@ -140,14 +144,18 @@ -- highSieve a surp gap = error "Oh shit" sieveCount :: COUNT_T -> COUNT_T -> COUNT_T -> Integer -sieveCount ub cr sr = runST $ do +sieveCount ub cr sr = runST (sieveCountST ub cr sr) + +sieveCountST :: forall s. COUNT_T -> COUNT_T -> COUNT_T -> ST s Integer +sieveCountST ub cr sr = do let psieves = psieveFrom (fromIntegral cr) pisr = approxPrimeCount sr picr = approxPrimeCount cr diff = pisr - picr size = fromIntegral (diff + diff `quot` 50) + 30 store <- unsafeNewArray_ (0,size-1) :: ST s (STUArray s Int COUNT_T) - let feed voff !wi !ri uar sves + let feed :: COUNT_T -> Int -> Int -> UArray Int Bool -> [PrimeSieve] -> ST s Integer + feed voff !wi !ri uar sves | ri == sieveBits = case sves of (PS vO ba : more) -> feed (fromInteger vO) wi 0 ba more _ -> error "prime stream ended prematurely" @@ -160,6 +168,7 @@ | otherwise = feed voff wi (ri+1) uar sves where pval = voff + toPrim ri + eat :: Integer -> Integer -> COUNT_T -> Int -> Int -> STUArray s Int Bool -> [PrimeSieve] -> ST s Integer eat !acc !btw voff !wi !si stu sves | si == sieveBits = case sves of @@ -198,7 +207,10 @@ _ -> error "No primes sieved" calc :: COUNT_T -> COUNT_T -> Integer -calc lim plim = runST $ do +calc lim plim = runST (calcST lim plim) + +calcST :: forall s. COUNT_T -> COUNT_T -> ST s Integer +calcST lim plim = do !parr <- sieveTo (fromIntegral plim) (plo,phi) <- getBounds parr !pct <- countFromTo plo phi parr @@ -206,7 +218,8 @@ unsafeWrite ar1 0 lim unsafeWrite ar1 1 1 !ar2 <- unsafeNewArray_ (0,end-1) - let go cap pix old new + let go :: Int -> Int -> STUArray s Int COUNT_T -> STUArray s Int COUNT_T -> ST s Integer + go cap pix old new | pix == 2 = coll cap old | otherwise = do isp <- unsafeRead parr pix @@ -216,6 +229,7 @@ !ncap <- treat cap n old new go ncap (pix-1) new old else go cap (pix-1) old new + coll :: Int -> STUArray s Int COUNT_T -> ST s Integer coll stop ar = let cgo !acc i | i < stop = do diff --git a/Math/NumberTheory/Primes/Factorisation.hs b/Math/NumberTheory/Primes/Factorisation.hs --- a/Math/NumberTheory/Primes/Factorisation.hs +++ b/Math/NumberTheory/Primes/Factorisation.hs @@ -23,10 +23,6 @@ , stepFactorisation , factorise' , defaultStdGenFactorisation' - -- *** Factor sieves - , FactorSieve - , factorSieve - , sieveFactor -- *** Trial division , trialDivisionTo -- ** Partial factorisation @@ -35,19 +31,10 @@ , curveFactorisation -- *** Single curve worker , montgomeryFactorisation - -- * Totients - , TotientSieve - , totientSieve - , sieveTotient - -- * Carmichael function - , CarmichaelSieve - , carmichaelSieve - , sieveCarmichael ) where import Math.NumberTheory.Primes.Factorisation.Montgomery import Math.NumberTheory.Primes.Factorisation.TrialDivision -import Math.NumberTheory.Primes.Sieve.Misc -- $algorithm -- diff --git a/Math/NumberTheory/Primes/Factorisation/Certified.hs b/Math/NumberTheory/Primes/Factorisation/Certified.hs --- a/Math/NumberTheory/Primes/Factorisation/Certified.hs +++ b/Math/NumberTheory/Primes/Factorisation/Certified.hs @@ -18,12 +18,10 @@ ) where import System.Random -import Control.Monad.State.Strict -#if __GLASGOW_HASKELL__ < 709 -import Control.Applicative -#endif +import Control.Monad.Trans.State.Strict import Data.Maybe import Data.Bits +import Data.Traversable import Math.NumberTheory.Moduli.Class import Math.NumberTheory.Primes.Factorisation.Montgomery diff --git a/Math/NumberTheory/Primes/Factorisation/Montgomery.hs b/Math/NumberTheory/Primes/Factorisation/Montgomery.hs --- a/Math/NumberTheory/Primes/Factorisation/Montgomery.hs +++ b/Math/NumberTheory/Primes/Factorisation/Montgomery.hs @@ -50,12 +50,8 @@ ) where import Control.Arrow +import Control.Monad.Trans.State.Lazy import System.Random -import Control.Monad.State.Lazy -#if __GLASGOW_HASKELL__ < 709 -import Control.Applicative -import Data.Word -#endif import Data.Bits import Data.IntMap (IntMap) import qualified Data.IntMap as IM @@ -64,11 +60,12 @@ #if __GLASGOW_HASKELL__ < 803 import Data.Semigroup #endif +import Data.Traversable import GHC.TypeNats.Compat import Math.NumberTheory.Curves.Montgomery -import Math.NumberTheory.GCD (splitIntoCoprimes) +import Math.NumberTheory.Euclidean.Coprimes (splitIntoCoprimes, unCoprimes) import Math.NumberTheory.Moduli.Class import Math.NumberTheory.Powers.General (highestPower, largePFPower) import Math.NumberTheory.Powers.Squares (integerSquareRoot') @@ -78,16 +75,15 @@ import Math.NumberTheory.Unsafe import Math.NumberTheory.Utils --- | @'factorise' n@ produces the prime factorisation of @n@, including --- a factor of @(-1)@ if @n < 0@. @'factorise' 0@ is an error and the --- factorisation of @1@ is empty. Uses a 'StdGen' produced in an arbitrary --- manner from the bit-pattern of @n@. +-- | @'factorise' n@ produces the prime factorisation of @n@. @'factorise' 0@ is +-- an error and the factorisation of @1@ is empty. Uses a 'StdGen' produced in +-- an arbitrary manner from the bit-pattern of @n@. factorise :: Integer -> [(Integer,Int)] factorise n - | n < 0 = (-1,1):factorise (-n) - | n == 0 = error "0 has no prime factorisation" - | n == 1 = [] - | otherwise = factorise' n + | abs n == 1 = [] + | n < 0 = factorise (-n) + | n == 0 = error "0 has no prime factorisation" + | otherwise = factorise' n -- | Like 'factorise', but without input checking, hence @n > 1@ is required. factorise' :: Integer -> [(Integer,Int)] @@ -221,7 +217,7 @@ SomeMod sm -> case montgomeryFactorisation b1 b2 sm of Nothing -> workFact m b1 b2 (count - 1) Just d -> do - let cs = splitIntoCoprimes [(d, 1), (m `quot` d, 1)] + let cs = unCoprimes $ splitIntoCoprimes [(d, 1), (m `quot` d, 1)] -- Since all @cs@ are coprime, we can factor each of -- them and just concat results, without summing up -- powers of the same primes in different elements. diff --git a/Math/NumberTheory/Primes/Heap.hs b/Math/NumberTheory/Primes/Heap.hs deleted file mode 100644 --- a/Math/NumberTheory/Primes/Heap.hs +++ /dev/null @@ -1,366 +0,0 @@ --- | --- Module: Math.NumberTheory.Primes.Heap --- Copyright: (c) 2011 Daniel Fischer --- Licence: MIT --- Maintainer: Daniel Fischer --- Stability: Provisional --- Portability: Non-portable (GHC extensions) --- --- Prime generation using a priority queue for the composites. --- The algorithm is basically the one described in --- , but --- it uses a more efficient heap for the priority queue and a --- larger wheel, thus it is faster (in particular, the speed --- penalty for @'Integer'@ is much smaller) and uses less memory. --- It is nevertheless very slow compared to a bit sieve. --- This module is mainly intended for comparison and verification. -{-# LANGUAGE BangPatterns, CPP, MonoLocalBinds #-} -{-# OPTIONS_GHC -funbox-strict-fields #-} -{-# OPTIONS_GHC -fno-float-in -fno-spec-constr -fno-full-laziness #-} -module Math.NumberTheory.Primes.Heap {-# DEPRECATED "Use Math.NumberTheory.Primes.Sieve instead" #-} (primes, sieveFrom) where - -import Data.Array.Unboxed -import Data.Array.ST -import Control.Monad.ST -import Data.List (foldl') -#if __GLASGOW_HASKELL__ < 709 -import Data.Word -#endif - -import Math.NumberTheory.Unsafe - -#ifndef SH_SIZE -#define SH_SIZE 31 -#endif - --- Composites to eliminate, components are --- composite, multiple of prime --- prime --- index of step to find next multiple of prime -data Del a = D !a !a {-# UNPACK #-} !Int - -step :: Integral a => Int -> a --- {-# INLINE step #-} -step i = fromIntegral (steps `unsafeAt` i) - --- Priority queue as baby heap --- Invariant: left subheap one larger than right or both --- have the same size (and of course, heap property) -data Hipp a - = E - | H !a !a {-# UNPACK #-} !Int !(Hipp a) !(Hipp a) - - --- push composite-data down the heap -{-# SPECIALISE push :: Int -> Int -> Int -> Hipp Int -> Hipp Int #-} -{-# SPECIALISE push :: Word -> Word -> Int -> Hipp Word -> Hipp Word #-} -{-# SPECIALISE push :: Integer -> Integer -> Int -> Hipp Integer -> Hipp Integer #-} -push :: Integral a => a -> a -> Int -> Hipp a -> Hipp a -push !c !p !w = go - where - less = (< c) - go (H hc hp hw l r) - | less hc = H hc hp hw (go r) l - | otherwise = H c p w (push hc hp hw r) l - go _ = H c p w E E - --- bubble down increased top to regain heap invariant -{-# SPECIALISE bubble :: Hipp Int -> Hipp Int #-} -{-# SPECIALISE bubble :: Hipp Word -> Hipp Word #-} -{-# SPECIALISE bubble :: Hipp Integer -> Hipp Integer #-} -bubble :: Integral a => Hipp a -> Hipp a -bubble h@(H c p w l r) = - case r of - E -> case l of - E -> h - H lc lp lw ll lr - | lc < c -> H lc lp lw (H c p w ll lr) r - | otherwise -> h - H rc rp rw rl rr -> - case l of - H lc lp lw ll lr - | lc < c -> if lc < rc - then H lc lp lw (mkHipp c p w ll lr) r - else H rc rp rw l (mkHipp c p w rl rr) - | rc < c -> H rc rp rw l (mkHipp c p w rl rr) - | otherwise -> h - _ -> error "Heap invariant violated, left smaller than right!" -bubble h = h - --- join two heaps and composite-data -{-# SPECIALISE - mkHipp :: Int -> Int -> Int -> Hipp Int -> Hipp Int -> Hipp Int, - Integer -> Integer -> Int -> Hipp Integer -> Hipp Integer -> Hipp Integer, - Word -> Word -> Int -> Hipp Word -> Hipp Word -> Hipp Word - #-} -mkHipp :: Integral a => a -> a -> Int -> Hipp a -> Hipp a -> Hipp a -mkHipp !c !p !w = go - where - less = (< c) - go l r = - case r of - E -> case l of - E -> H c p w l r - H lc lp lw _ _ - | less lc -> H lc lp lw (H c p w E E) E - | otherwise -> H c p w l r - H rc rp rw rl rr -> - case l of - H lc lp lw ll lr - | less lc -> if lc < rc - then H lc lp lw (go ll lr) r - else H rc rp rw l (go rl rr) - | less rc -> H rc rp rw l (go rl rr) - | otherwise -> H c p w l r - _ -> error "Heap invariant violated, left smaller than right!" - --- increase the top of the heap and re-heap -{-# SPECIALISE inc :: Hipp Int -> Hipp Int #-} -{-# SPECIALISE inc :: Hipp Word -> Hipp Word #-} -{-# SPECIALISE inc :: Hipp Integer -> Hipp Integer #-} -inc :: Integral a => Hipp a -> Hipp a -inc (H c p i l r) - = {-# SCC "incBubble" #-} bubble (H (c+p*step i) p (nextIndex i) l r) -inc h = h - --- while top of heap equals composite, increase and re-heap -{-# SPECIALISE adjust :: Int -> Hipp Int -> Hipp Int #-} -{-# SPECIALISE adjust :: Word -> Hipp Word -> Hipp Word #-} -{-# SPECIALISE adjust :: Integer -> Hipp Integer -> Hipp Integer #-} -adjust :: Integral a => a -> Hipp a -> Hipp a -adjust cm h@(H v _ _ _ _) - | cm == v = adjust cm (inc h) -adjust _ h = h - --- build a heap from a sorted list of Del's -{-# SPECIALISE buildH :: [Del Int] -> Hipp Int #-} -{-# SPECIALISE buildH :: [Del Word] -> Hipp Word #-} -{-# SPECIALISE buildH :: [Del Integer] -> Hipp Integer #-} -buildH :: Integral a => [Del a] -> Hipp a -buildH [] = E -buildH (D s p w : tl) = H s p w l r - where - (ll,rl) = goSplit [] [] tl - goSplit xs ys [] = (reverse ys, reverse xs) - goSplit xs ys (d:ds) = goSplit ys (d:xs) ds - l = buildH ll - r = buildH rl - --- Simple sieve pushing each prime immediately onto the heap, --- feeds the feeder, runs at about fourth root of the main sieve. -{-# SPECIALISE simpleSieve :: Hipp Int -> Int -> Int -> [Del Int] #-} -{-# SPECIALISE simpleSieve :: Hipp Word -> Word -> Int -> [Del Word] #-} -{-# SPECIALISE simpleSieve :: Hipp Integer -> Integer -> Int -> [Del Integer] #-} -simpleSieve :: Integral a => Hipp a -> a -> Int -> [Del a] -simpleSieve h@(H nc _ _ _ _) cd !i - | cd < nc = D s cd i : simpleSieve ({-# SCC "simplePush" #-} push s cd i h) (cd + step i) (nextIndex i) - | otherwise = simpleSieve (adjust cd h) (cd + step i) (nextIndex i) - where - s = cd*cd -simpleSieve _ _ _ = [] -- would violate an invariant - --- Feeder sieve, produces composites at the rate of the progress of the main sieve, --- hence primes at about the square root of it, thus needs about fourth root heap --- space. The two-step feeding makes the feeder produce faster and hence the main --- sieve (since we have only one O(n^0.5) heap and not two. --- Using two heaps, one small for multiples of small primes which change often --- and one for multiples of larger primes which are less frequently updated --- speeds things up. -{-# SPECIALISE feederSieve :: [Del Int] -> Hipp Int -> Hipp Int -> Int -> Int -> [Del Int] #-} -{-# SPECIALISE feederSieve :: [Del Word] -> Hipp Word -> Hipp Word -> Word -> Int -> [Del Word] #-} -{-# SPECIALISE feederSieve :: [Del Integer] -> Hipp Integer -> Hipp Integer -> Integer -> Int -> [Del Integer] #-} -feederSieve :: Integral a => [Del a] -> Hipp a -> Hipp a -> a -> Int -> [Del a] -feederSieve dls@((D s p u):ds) sh@(H sc _ _ _ _) lh@(H lc _ _ _ _) cd i - | cd == sc = feederSieve dls (adjust cd (inc sh)) (adjust cd lh) cd' j - | cd == lc = feederSieve dls sh (adjust cd (inc lh)) cd' j - | cd == s = feederSieve ds sh (push (s + p*step u) p (nextIndex u) lh) cd' j - | otherwise = D (cd*cd) cd i : feederSieve dls sh lh cd' j - where - !cd' = cd + step i - !j = nextIndex i -feederSieve _ _ _ _ _ = [] -- invariant violated - --- Build the feeder sieve, arguments are --- first prime whose multiples have to be eliminated --- index of step for this prime. -{-# SPECIALISE feeder :: Int -> Int -> [Del Int] #-} -{-# SPECIALISE feeder :: Word -> Int -> [Del Word] #-} -{-# SPECIALISE feeder :: Integer -> Int -> [Del Integer] #-} -feeder :: Integral a => a -> Int -> [Del a] -feeder p i = feederSieve lrg sh lh p i - where - (sml,D s lp w : lrg) = splitAt SH_SIZE (D q p i : {-# SCC "simple" #-} simpleSieve (H q p i E E) (p+step i) (nextIndex i)) - sh = buildH sml - lh = H s lp w E E - q = p*p - --- The main sieve. Code almost identical to feederSieve, but we don't construct the Del, --- which gains some performance. -{-# SPECIALISE primeSieve :: [Del Int] -> Hipp Int -> Hipp Int -> Int -> Int -> [Int] #-} -{-# SPECIALISE primeSieve :: [Del Word] -> Hipp Word -> Hipp Word -> Word -> Int -> [Word] #-} -{-# SPECIALISE primeSieve :: [Del Integer] -> Hipp Integer -> Hipp Integer -> Integer -> Int -> [Integer] #-} -primeSieve :: Integral a => [Del a] -> Hipp a -> Hipp a -> a -> Int -> [a] -primeSieve dls@((D s p u):ds) sh@(H sc _ _ _ _) lh@(H lc _ _ _ _) cd i - | cd == sc = primeSieve dls ({-# SCC "adjSmall" #-} adjust cd (inc sh)) ({-# SCC "adjLarge" #-}adjust cd lh) cd' j - | cd == lc = primeSieve dls sh (adjust cd (inc lh)) cd' j - | cd == s = primeSieve ds sh (push (s + p*step u) p (nextIndex u) lh) cd' j - | otherwise = cd : primeSieve dls sh lh cd' j - where - !cd' = cd + step i - !j = nextIndex i -primeSieve _ _ _ _ _ = [] -- invariant violated - --- | A list of primes. The sieve does not handle overflow, hence for --- bounded types, garbage occurs near @'maxBound'@. If primes that --- large are requested, use --- --- @ --- 'map' 'fromInteger' $ 'takeWhile' (<= 'fromIntegral' 'maxBound') 'primes' --- @ --- --- instead. Checking for overflow would be slower. The sieve is specialised --- for @'Int'@, @'Word'@ and @'Integer'@, since these are the most commonly --- used. For the fixed-width @Int@ or @Word@ types, sieving at one of the --- specialised types and converting is faster. --- To ensure sharing of the list of primes, bind it to a monomorphic variable, --- to make sure that it is not shared, use @'sieveFrom'@ with different --- arguments. -{-# SPECIALISE primes :: [Int] #-} -{-# SPECIALISE primes :: [Word] #-} -{-# SPECIALISE primes :: [Integer] #-} -primes :: Integral a => [a] -primes = 2:3:5:7:11:13:sieve 17 0 - --- | @'sieveFrom' n@ generates the list of primes @>= n@. --- The remarks about overflow and performance in the documentation --- of @'primes'@ apply here too. -{-# SPECIALISE sieveFrom :: Int -> [Int] #-} -{-# SPECIALISE sieveFrom :: Word -> [Word] #-} -{-# SPECIALISE sieveFrom :: Integer -> [Integer] #-} -sieveFrom :: Integral a => a -> [a] -sieveFrom from - | fromIntegral from < (32768 :: Integer) - = dropWhile (< from) (foldr ((:) . fromIntegral) (sieve sp si) wheelPrimes) - | otherwise - = primeSieve dls sh lh start (nextIndex i0) - where - -- trick the compiler into not CAFing feeder 17 0 - sp | odd from = 17 - | otherwise = fromIntegral (remainders `unsafeAt` 0) - si | even from = 0 - | otherwise = (steps `unsafeAt` 0)-2 - (q, r) = (from - 18) `quotRem` 30030 - i0 = findIx (fromIntegral r + 17) - -- last number coprime to all wheel primes < from - before = 30030*q + fromIntegral (remainders `unsafeAt` i0) - -- first candidate - !start = before + step i0 - (sml, lrg) = splitAt SH_SIZE (feeder sp si) - !sh = foldl' pushD E [findMulIx p | D _ p _ <- sml] - (lh, dls) = {-# SCC "munch" #-} munch E lrg - pushD h (c, p, i) = push c p i h - findMulIx p = ((p*mp), p, (nextIndex ip)) - where - fpq = before `quot` p - (qq, qr) = (fpq-17) `quotRem` 30030 - !ip = findIx (fromIntegral qr + 17) - !mp = 30030*qq + fromIntegral (remainders `unsafeAt` ip) + step ip - munch !h dels@(D s p _ : ds) - | before < s = (h,dels) - | otherwise = munch h' ds - where - !(!c, pr, i) = findMulIx p - h' = push c pr i h - munch h [] = (h,[]) - --- Build main sieve. -{-# SPECIALISE sieve :: Int -> Int -> [Int] #-} -{-# SPECIALISE sieve :: Word -> Int -> [Word] #-} -{-# SPECIALISE sieve :: Integer -> Int -> [Integer] #-} -sieve :: Integral a => a -> Int -> [a] -sieve p i = primeSieve lrg sh lh p i - where - (sml,D s lp j : lrg) = splitAt SH_SIZE (feeder p i) - !sh = buildH sml - lh = H s lp j E E - --- next step index, we have 5760 numbers coprime to all wheel --- primes in [1 .. product wheelPrimes] -{-# INLINE nextIndex #-} -nextIndex :: Int -> Int -nextIndex 5759 = 0 -nextIndex i = i+1 - --- The six smallest primes, that makes the supporting arrays small enough --- and avoids enough composites to get acceptable speed (for sufficiently --- generous values of acceptable). -wheelPrimes :: [Int] -wheelPrimes = 2:3:5:7:11:13:[] - --- index of largest coprime <= r -findIx :: Int -> Int -findIx r - | 30030 < r = 5759 - | r == m = a - | r < m = down (a-1) - | otherwise = up a - where - a = max 0 (min 5758 ((192*r) `quot` 1001 - 1)) - m = remainders `unsafeAt` a - down k - | k < 0 = 0 - | r < (remainders `unsafeAt` k) = down (k-1) - | otherwise = k - up k - | k+1 > 5759 = 5759 - | r < (remainders `unsafeAt` (k+1)) = k - | otherwise = up (k+1) - --- array of numbers coprime to all wheel primes in wheel range -remainders :: UArray Int Int -remainders = runSTUArray $ do - sar <- newArray (0,30029) True :: ST s (STUArray s Int Bool) - let n2 30030 = return () - n2 i = unsafeWrite sar i False >> n2 (i+2) - n3 30033 = return () - n3 i = unsafeWrite sar i False >> n3 (i+6) - n5 30035 = return () - n5 i = unsafeWrite sar i False - >> unsafeWrite sar (i+20) False >> n5 (i+30) - n7 30037 = return () - n7 i = unsafeWrite sar i False >> n7 (i+14) - n11 30041 = return () - n11 i = unsafeWrite sar i False >> n11 (i+22) - n13 30043 = return () - n13 i = unsafeWrite sar i False >> n13 (i+26) - n2 0 - n3 3 - n5 5 - n7 7 - n11 11 - n13 13 - rar <- newArray_ (0,5759) :: ST s (STUArray s Int Int) - let loop 30031 _ = unsafeWrite rar 5759 30031 >> return rar - loop i !r = do - c <- unsafeRead sar i - if c - then do - unsafeWrite rar r i - loop (i+2) (r+1) - else loop (i+2) r - loop 17 0 - --- distance from one coprime remainder to the next -steps :: UArray Int Int -steps = runSTUArray $ do - sar <- newArray_ (0,5759) :: ST s (STUArray s Int Int) - let loop 5759 p = do - unsafeWrite sar 5759 (30047-p) - return sar - loop i p = do - let !j = i+1 - !n = remainders `unsafeAt` j - unsafeWrite sar i (n-p) - loop j n - loop 0 17 - diff --git a/Math/NumberTheory/Primes/Sieve/Eratosthenes.hs b/Math/NumberTheory/Primes/Sieve/Eratosthenes.hs --- a/Math/NumberTheory/Primes/Sieve/Eratosthenes.hs +++ b/Math/NumberTheory/Primes/Sieve/Eratosthenes.hs @@ -8,7 +8,12 @@ -- -- Sieve -- -{-# LANGUAGE CPP, BangPatterns, FlexibleContexts #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} + {-# OPTIONS_GHC -fspec-constr-count=8 #-} {-# OPTIONS_HADDOCK hide #-} module Math.NumberTheory.Primes.Sieve.Eratosthenes @@ -23,9 +28,7 @@ , countFromTo , countAll , countToNth - , sieveBytes , sieveBits - , sieveWords , sieveRange , sieveTo ) where @@ -34,15 +37,18 @@ import Control.Monad.ST import Data.Array.ST +import Data.Array.Unboxed +import Data.Proxy import Control.Monad (when) import Data.Bits -#if __GLASGOW_HASKELL__ < 709 || WORD_SIZE_IN_BITS == 32 +#if WORD_SIZE_IN_BITS == 32 import Data.Word #endif import Math.NumberTheory.Powers.Squares (integerSquareRoot) import Math.NumberTheory.Unsafe import Math.NumberTheory.Utils +import Math.NumberTheory.Utils.FromIntegral import Math.NumberTheory.Primes.Counting.Approximate import Math.NumberTheory.Primes.Sieve.Indexing @@ -106,25 +112,62 @@ -- | Generate a list of primes for consumption from a -- 'PrimeSieve'. -primeList :: PrimeSieve -> [Integer] -primeList (PS 0 bs) = 2:3:5:[toPrim i | let (lo,hi) = bounds bs - , i <- [lo .. hi] - , unsafeAt bs i - ] -primeList (PS vO bs) = [vO + toPrim i - | let (lo,hi) = bounds bs - , i <- [lo .. hi] - , unsafeAt bs i - ] +primeList :: forall a. Integral a => PrimeSieve -> [a] +primeList ps@(PS v _) + | doesNotFit (Proxy :: Proxy a) v + = [] -- has an overflow already happened? + | v == 0 = takeWhileIncreasing $ 2 : 3 : 5 : primeListInternal ps + | otherwise = takeWhileIncreasing $ primeListInternal ps --- | List of primes. --- Since the sieve uses unboxed arrays, overflow occurs at some point. --- On 64-bit systems, that point is beyond the memory limits, on --- 32-bit systems, it is at about @1.7*10^18@. -primes :: [Integer] -primes = 2:3:5:concat [[vO + toPrim i | i <- [0 .. li], unsafeAt bs i] - | PS vO bs <- psieveList, let (_,li) = bounds bs] +primeListInternal :: Num a => PrimeSieve -> [a] +primeListInternal (PS v0 bs) + = map ((+ fromInteger v0) . toPrim) + $ filter (unsafeAt bs) [lo..hi] + where + (lo, hi) = bounds bs +-- | Returns true if integer is beyond representation range of type a. +doesNotFit :: forall a. Integral a => Proxy a -> Integer -> Bool +doesNotFit _ v = toInteger (fromInteger v :: a) /= v + +-- | Extracts the longest strictly increasing prefix of the list +-- (possibly infinite). +takeWhileIncreasing :: Ord a => [a] -> [a] +takeWhileIncreasing = \case + [] -> [] + x : xs -> x : foldr go (const []) xs x + where + go :: Ord a => a -> (a -> [a]) -> a -> [a] + go y f z = if z < y then y : f y else [] + +-- | Ascending list of primes. +-- +-- >>> take 10 primes +-- [2, 3, 5, 7, 11, 13, 17, 19, 23, 29] +-- +-- 'primes' is a polymorphic list, so the results of computations are not retained in memory. +-- Make it monomorphic to take advantages of memoization. Compare +-- +-- >>> :set +s +-- >>> primes !! 1000000 :: Int +-- 15485867 +-- (5.32 secs, 6,945,267,496 bytes) +-- >>> primes !! 1000000 :: Int +-- 15485867 +-- (5.19 secs, 6,945,267,496 bytes) +-- +-- against +-- +-- >>> let primes' = primes :: [Int] +-- >>> primes' !! 1000000 :: Int +-- 15485867 +-- (5.29 secs, 6,945,269,856 bytes) +-- >>> primes' !! 1000000 :: Int +-- 15485867 +-- (0.02 secs, 336,232 bytes) +primes :: (Ord a, Num a) => [a] +primes = takeWhileIncreasing $ 2 : 3 : 5 : concatMap primeListInternal psieveList + -- | List of primes in the form of a list of 'PrimeSieve's, more compact than -- 'primes', thus it may be better to use @'psieveList' >>= 'primeList'@ -- than keeping the list of primes alive during the entire run. @@ -134,7 +177,7 @@ plim = 4801 -- prime #647, 644 of them to use sqlim = plim*plim cache = runSTUArray $ do - sieve <- sieveTo 4801 + sieve <- sieveTo (4801 :: Integer) new <- unsafeNewArray_ (0,1287) :: ST s (STUArray s Int CacheWord) let fill j indx | 1279 < indx = return new -- index of 4801 = 159*30 + 31 ~> 159*8+7 @@ -335,7 +378,7 @@ psieveFrom :: Integer -> [PrimeSieve] psieveFrom n = makeSieves plim sqlim bitOff valOff cache where - k0 = max 0 (n-7) `quot` 30 + k0 = ((n `max` 7) - 7) `quot` 30 -- beware arithmetic underflow valOff = 30*k0 bitOff = 8*k0 start = valOff+7 @@ -403,7 +446,7 @@ bnd = bd0 + bd0 `quot` 32 + 37 !sv = primeSieve bnd in countToNth (n-3) [sv] - | otherwise = countToNth (n-3) (psieveFrom (fromIntegral $ fromInteger n .&. (7 :: Int))) + | otherwise = countToNth (n-3) (psieveFrom (intToInteger $ fromInteger n .&. (7 :: Int))) -- find the n-th set bit in a list of PrimeSieves, -- aka find the (n+3)-rd prime @@ -456,3 +499,72 @@ | otherwise -> let !na = a `shiftR` 1 in go bs na (msk `uncheckedShiftR` na) ix wd + +{-# INLINE delta #-} +delta :: Int -> Int +delta i = unsafeAt deltas i + +deltas :: UArray Int Int +deltas = listArray (0,7) [4,2,4,2,4,6,2,6] + +{-# INLINE tau #-} +tau :: Int -> Int +tau i = unsafeAt taus i + +taus :: UArray Int Int +taus = listArray (0,63) + [ 7, 4, 7, 4, 7, 12, 3, 12 + , 12, 6, 11, 6, 12, 18, 5, 18 + , 14, 7, 13, 7, 14, 21, 7, 21 + , 18, 9, 19, 9, 18, 27, 9, 27 + , 20, 10, 21, 10, 20, 30, 11, 30 + , 25, 12, 25, 12, 25, 36, 13, 36 + , 31, 15, 31, 15, 31, 47, 15, 47 + , 33, 17, 33, 17, 33, 49, 17, 49 + ] + +{-# INLINE byte #-} +byte :: Int -> Int +byte i = unsafeAt startByte i + +startByte :: UArray Int Int +startByte = listArray (0,7) [1,3,5,9,11,17,27,31] + +{-# INLINE idx #-} +idx :: Int -> Int +idx i = unsafeAt startIdx i + +startIdx :: UArray Int Int +startIdx = listArray (0,7) [4,7,4,4,7,4,7,7] + +{-# INLINE mu #-} +mu :: Int -> Int +mu i = unsafeAt mArr i + +{-# INLINE nu #-} +nu :: Int -> Int +nu i = unsafeAt nArr i + +mArr :: UArray Int Int +mArr = listArray (0,63) + [ 1, 2, 2, 3, 4, 5, 6, 7 + , 2, 3, 4, 6, 6, 8, 10, 11 + , 2, 4, 5, 7, 8, 9, 12, 13 + , 3, 6, 7, 9, 10, 12, 16, 17 + , 4, 6, 8, 10, 11, 14, 18, 19 + , 5, 8, 9, 12, 14, 17, 22, 23 + , 6, 10, 12, 16, 18, 22, 27, 29 + , 7, 11, 13, 17, 19, 23, 29, 31 + ] + +nArr :: UArray Int Int +nArr = listArray (0,63) + [ 4, 3, 7, 6, 2, 1, 5, 0 + , 3, 7, 5, 0, 6, 2, 4, 1 + , 7, 5, 4, 1, 0, 6, 3, 2 + , 6, 0, 1, 4, 5, 7, 2, 3 + , 2, 6, 0, 5, 7, 3, 1, 4 + , 1, 2, 6, 7, 3, 4, 0, 5 + , 5, 4, 3, 2, 1, 0, 7, 6 + , 0, 1, 2, 3, 4, 5, 6, 7 + ] diff --git a/Math/NumberTheory/Primes/Sieve/Indexing.hs b/Math/NumberTheory/Primes/Sieve/Indexing.hs --- a/Math/NumberTheory/Primes/Sieve/Indexing.hs +++ b/Math/NumberTheory/Primes/Sieve/Indexing.hs @@ -6,18 +6,13 @@ -- Stability: Provisional -- Portability: Non-portable (GHC extensions) -- +-- Auxiliary stuff, conversion between number and index, +-- remainders modulo 30 and related things. {-# OPTIONS_HADDOCK hide #-} module Math.NumberTheory.Primes.Sieve.Indexing ( idxPr , toPrim - , toIdx , rho - , delta - , tau - , byte - , idx - , mu - , nu ) where import Data.Array.Unboxed @@ -25,13 +20,6 @@ import Math.NumberTheory.Unsafe --- Auxiliary stuff, conversion between number and index, --- remainders modulo 30 and related things. - --- {-# SPECIALISE idxPr :: Integer -> (Int,Int), --- Int -> (Int,Int), --- Word -> (Int,Int) --- #-} {-# INLINE idxPr #-} idxPr :: Integral a => a -> (Int,Int) idxPr n0 @@ -45,99 +33,16 @@ rm2 = rm1 `quot` 3 rm3 = min 7 (if rm2 > 5 then rm2-1 else rm2) --- {-# SPECIALISE toPrim :: Int -> Integer, --- Int -> Int, --- Int -> Word, --- Int -> Word16 --- #-} {-# INLINE toPrim #-} -toPrim :: Integral a => Int -> a +toPrim :: Num a => Int -> a toPrim ix = 30*fromIntegral k + fromIntegral (rho i) where i = ix .&. 7 k = ix `shiftR` 3 --- Assumes n >= 7, gcd n 30 == 1 -{-# INLINE toIdx #-} -toIdx :: Integral a => a -> Int -toIdx n = 8*fromIntegral q+r2 - where - (q,r) = (n-7) `quotRem` 30 - r1 = fromIntegral r `quot` 3 - r2 = min 7 (if r1 > 5 then r1-1 else r1) - {-# INLINE rho #-} rho :: Int -> Int rho i = unsafeAt residues i residues :: UArray Int Int residues = listArray (0,7) [7,11,13,17,19,23,29,31] - -{-# INLINE delta #-} -delta :: Int -> Int -delta i = unsafeAt deltas i - -deltas :: UArray Int Int -deltas = listArray (0,7) [4,2,4,2,4,6,2,6] - -{-# INLINE tau #-} -tau :: Int -> Int -tau i = unsafeAt taus i - -taus :: UArray Int Int -taus = listArray (0,63) - [ 7, 4, 7, 4, 7, 12, 3, 12 - , 12, 6, 11, 6, 12, 18, 5, 18 - , 14, 7, 13, 7, 14, 21, 7, 21 - , 18, 9, 19, 9, 18, 27, 9, 27 - , 20, 10, 21, 10, 20, 30, 11, 30 - , 25, 12, 25, 12, 25, 36, 13, 36 - , 31, 15, 31, 15, 31, 47, 15, 47 - , 33, 17, 33, 17, 33, 49, 17, 49 - ] - -{-# INLINE byte #-} -byte :: Int -> Int -byte i = unsafeAt startByte i - -startByte :: UArray Int Int -startByte = listArray (0,7) [1,3,5,9,11,17,27,31] - -{-# INLINE idx #-} -idx :: Int -> Int -idx i = unsafeAt startIdx i - -startIdx :: UArray Int Int -startIdx = listArray (0,7) [4,7,4,4,7,4,7,7] - -{-# INLINE mu #-} -mu :: Int -> Int -mu i = unsafeAt mArr i - -{-# INLINE nu #-} -nu :: Int -> Int -nu i = unsafeAt nArr i - -mArr :: UArray Int Int -mArr = listArray (0,63) - [ 1, 2, 2, 3, 4, 5, 6, 7 - , 2, 3, 4, 6, 6, 8, 10, 11 - , 2, 4, 5, 7, 8, 9, 12, 13 - , 3, 6, 7, 9, 10, 12, 16, 17 - , 4, 6, 8, 10, 11, 14, 18, 19 - , 5, 8, 9, 12, 14, 17, 22, 23 - , 6, 10, 12, 16, 18, 22, 27, 29 - , 7, 11, 13, 17, 19, 23, 29, 31 - ] - -nArr :: UArray Int Int -nArr = listArray (0,63) - [ 4, 3, 7, 6, 2, 1, 5, 0 - , 3, 7, 5, 0, 6, 2, 4, 1 - , 7, 5, 4, 1, 0, 6, 3, 2 - , 6, 0, 1, 4, 5, 7, 2, 3 - , 2, 6, 0, 5, 7, 3, 1, 4 - , 1, 2, 6, 7, 3, 4, 0, 5 - , 5, 4, 3, 2, 1, 0, 7, 6 - , 0, 1, 2, 3, 4, 5, 6, 7 - ] diff --git a/Math/NumberTheory/Primes/Sieve/Misc.hs b/Math/NumberTheory/Primes/Sieve/Misc.hs deleted file mode 100644 --- a/Math/NumberTheory/Primes/Sieve/Misc.hs +++ /dev/null @@ -1,407 +0,0 @@ --- | --- Module: Math.NumberTheory.Primes.Sieve.Misc --- Copyright: (c) 2011 Daniel Fischer --- Licence: MIT --- Maintainer: Daniel Fischer --- Stability: Provisional --- Portability: Non-portable (GHC extensions) --- -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MonoLocalBinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -fspec-constr-count=8 #-} -{-# OPTIONS_HADDOCK hide #-} -module Math.NumberTheory.Primes.Sieve.Misc - ( -- * Types - FactorSieve - , TotientSieve - , CarmichaelSieve - -- * Functions - -- ** Smallest prime factors - , factorSieve - , sieveFactor - , fsBound - , fsPrimeTest - -- ** Totients - , totientSieve - , sieveTotient - -- ** Carmichael - , carmichaelSieve - , sieveCarmichael - ) where - -import Control.Monad.ST -import Data.Array.ST -import Data.Array.Unboxed -import Control.Monad (when) -import Data.Bits -import GHC.Word - -import System.Random - -import Math.NumberTheory.Powers.Squares (integerSquareRoot') -import Math.NumberTheory.Primes.Sieve.Indexing -import Math.NumberTheory.Primes.Factorisation.Montgomery -import Math.NumberTheory.Unsafe -import Math.NumberTheory.Utils - -{-# DEPRECATED FactorSieve, TotientSieve, CarmichaelSieve, factorSieve, sieveFactor, fsBound, fsPrimeTest, totientSieve, sieveTotient, carmichaelSieve, sieveCarmichael "Use new interface for sieves, provided by \"Math.NumberTheory.ArithmeticFunctions.SieveBlock\"" #-} - -{- -IMPORTANT NOTICE: Not all sieves use the same layout! - -FactorSieve: - - To remain as efficient as possible, FactorSieve omits only even numbers. - To relate an odd number x to its index i: - - i = (x `div` 2) - 1 - x = i * 2 + 3 - -TotientSieve, CarmichaelSieve: - - These sieves use a (2,3,5) wheel optimization, sacrificing performance to save - more memory. The only indices stored are those coprime to 2, 3, and 5. - To relate such an integer x to its index i: - - i = toIdx x - x = toPrim i --} - --- | A compact store of smallest prime factors. -data FactorSieve = FS {-# UNPACK #-} !Word {-# UNPACK #-} !(UArray Int Word16) - --- | A compact store of totients. -data TotientSieve = TS {-# UNPACK #-} !Word {-# UNPACK #-} !(UArray Int Word) - --- | A compact store of values of the Carmichael function. -data CarmichaelSieve = CS {-# UNPACK #-} !Word {-# UNPACK #-} !(UArray Int Word) - --- | @'factorSieve' n@ creates a store of smallest prime factors of the numbers not exceeding @n@. --- If you need to factorise many smallish numbers, this can give a big speedup since it avoids --- many superfluous divisions. However, a too large sieve leads to a slowdown due to cache misses. --- The prime factors are stored as 'Word16' for compactness, so @n@ must be --- smaller than @2^32@. -factorSieve :: Integer -> FactorSieve -factorSieve bound - | 4294967295 < bound = error "factorSieve: overflow" - | bound < 8 = FS 7 (array (0,2) [(0,0),(1,0),(2,0)]) - | otherwise = FS bnd fSieve - where - bnd = fromInteger bound - ibnd = fromInteger ((bound - 3) `quot` 2) - svbd = (fromInteger (integerSquareRoot' bound) - 1) `quot` 2 - fSieve = runSTUArray $ do - sieve <- newArray (0,ibnd) 0 :: ST s (STUArray s Int Word16) - let sift i - | i < svbd = do - sp <- unsafeRead sieve i - when (sp == 0) (mark (2*i+3) (2*i*(i+3)+3)) - sift (i+1) - | otherwise = return sieve - mark p j - | j > ibnd = return () - | otherwise = do - sp <- unsafeRead sieve j - when (sp == 0) (unsafeWrite sieve j $ fromIntegral p) - mark p (j+p) - sift 0 - --- | @'fsBound' sieve@ tells the limit to which the sieve stores the smallest prime factors. -fsBound :: FactorSieve -> Word -fsBound (FS b _) = b - --- | @'fsPrimeTest' sieve n@ checks in the sieve whether @n@ is prime. If @n@ is larger --- than the sieve can handle, an error is raised. -fsPrimeTest :: FactorSieve -> Integer -> Bool -fsPrimeTest fs@(FS bnd sve) n - | n < 0 = fsPrimeTest fs (-n) - | n < 2 = False - | fromInteger n .&. (1 :: Int) == 0 = n == 2 - | n <= fromIntegral bnd = sve `unsafeAt` (fromInteger (n `shiftR` 1) - 1) == 0 - | otherwise = error "Out of bounds" - --- | @'sieveFactor' fs n@ finds the prime factorisation of @n@ using the 'FactorSieve' @fs@. --- For negative @n@, a factor of @-1@ is included with multiplicity @1@. --- After stripping any present factors @2@, the remaining cofactor @c@ (if larger --- than @1@) is factorised with @fs@. This is most efficient of course if @c@ does not --- exceed the bound with which @fs@ was constructed. If it does, trial division is performed --- until either the cofactor falls below the bound or the sieve is exhausted. In the latter --- case, the elliptic curve method is used to finish the factorisation. -sieveFactor :: FactorSieve -> Integer -> [(Integer,Int)] -sieveFactor (FS bnd sve) = check - where - bound = fromIntegral bnd - check 0 = error "0 has no prime factorisation" - check 1 = [] - check n - | n < 0 = (-1,1) : check (-n) - | n <= bound = go2w (fromIntegral n) -- avoid expensive Integer ops if possible - | fromInteger n .&. (1 :: Int) == 1 = sieveLoop n - | otherwise = go2 n - go2w n - | n .&. 1 == 1 = intLoop ((n-3) `shiftR` 1) - | otherwise = case shiftToOddCount n of - (k,m) -> (2,k) : if m == 1 then [] else intLoop ((m-3) `shiftR` 1) - go2 n = case shiftToOddCount n of - (k,m) -> (2,k) : if m == 1 then [] else sieveLoop m - sieveLoop n - | bound < n = tdLoop n (integerSquareRoot' n) 0 - | otherwise = intLoop (fromIntegral (n `shiftR` 1)-1) - intLoop :: Word -> [(Integer,Int)] - intLoop !n = case unsafeAt sve (fromIntegral n) of - 0 -> [(2*fromIntegral n+3,1)] - p -> let p' = fromIntegral p in countLoop p' (n `quot` p' - 1) 1 - countLoop !p !i !c - = case unsafeAt sve (fromIntegral i) of - 0 | p-3 == 2*i -> [(fromIntegral p,c+1)] - | otherwise -> (fromIntegral p,c) : (2*fromIntegral i+3,1) : [] - q | fromIntegral q == p -> countLoop p (i `quot` p - 1) (c+1) - | otherwise -> (fromIntegral p, c) : intLoop i - lstIdx = snd (bounds sve) - tdLoop n sr ix - | lstIdx < ix = curve n - | sr < p = [(n,1)] - | pix /= 0 = tdLoop n sr (ix+1) -- not a prime - | otherwise = case splitOff p n of - (0,_) -> tdLoop n sr (ix+1) - (k,m) -> (p,k) : case m of - 1 -> [] - j | j <= bound -> intLoop (fromIntegral (j `shiftR` 1) - 1) - | otherwise -> tdLoop j (integerSquareRoot' j) (ix+1) - where - p = fromIntegral $ 2 * ix + 3 - pix = unsafeAt sve ix - curve n = stdGenFactorisation (Just (bound*(bound+2))) (mkStdGen $ fromIntegral n `xor` 0xdecaf00d) Nothing n - --- | @'totientSieve' n@ creates a store of the totients of the numbers not exceeding @n@. --- A 'TotientSieve' only stores values for numbers coprime to @30@ to reduce space usage. --- The maximal admissible value for @n@ is @'fromIntegral' ('maxBound' :: 'Word')@. -totientSieve :: Integer -> TotientSieve -totientSieve bound - | fromIntegral (maxBound :: Word) < bound = error "totientSieve: overflow" - | bound < 8 = TS 7 (array (0,0) [(0,6)]) - | otherwise = TS bnd (totSieve bnd) - where - bnd = fromInteger bound - --- | @'sieveTotient' ts n@ finds the totient @π(n)@, i.e. the number of integers @k@ with --- @1 <= k <= n@ and @'gcd' n k == 1@, in other words, the order of the group of units --- in @ℤ/(n)@, using the 'TotientSieve' @ts@. --- First, factors of @2, 3@ and @5@ are handled individually, if the remaining --- cofactor of @n@ is within the sieve range, its totient is looked up, otherwise --- the calculation falls back on factorisation, first by trial division and --- if necessary, elliptic curves. -sieveTotient :: TotientSieve -> Integer -> Integer -sieveTotient (TS bnd sve) = check - where - bound = fromIntegral bnd - check n - | n < 1 = error "Totient only defined for positive numbers" - | n == 1 = 1 - | otherwise = go2 n - go2 n = case shiftToOddCount n of - (0,_) -> go3 1 n - (k,m) -> let tt = (shiftL 1 (k-1)) in if m == 1 then tt else go3 tt m - go3 !tt n = case splitOff 3 n of - (0,_) -> go5 tt n - (k,m) -> let nt = tt*(2*3^(k-1)) in if m == 1 then nt else go5 nt m - go5 !tt n = case splitOff 5 n of - (0,_) -> sieveLoop tt n - (k,m) -> let nt = tt*(4*5^(k-1)) in if m == 1 then nt else sieveLoop nt m - sieveLoop !tt n - | bound < n = tdLoop tt n (integerSquareRoot' n) 0 - | otherwise = case unsafeAt sve (toIdx n) of - nt -> tt*fromIntegral nt - lstIdx = snd (bounds sve) - tdLoop !tt n sr ix - | lstIdx < ix = curve tt n - | sr < p' = tt*(n-1) -- n is a prime - | pix /= p-1 = tdLoop tt n sr (ix+1) -- not a prime, next - | otherwise = case splitOff p' n of - (0,_) -> tdLoop tt n sr (ix+1) - (k,m) -> let nt = tt*ppTotient (p',k) - in case m of - 1 -> nt - j | j <= bound -> nt*fromIntegral (unsafeAt sve (toIdx j)) - | otherwise -> tdLoop nt j (integerSquareRoot' j) (ix+1) - where - p = toPrim ix - p' = fromIntegral p - pix = unsafeAt sve ix - curve tt n = tt * totientFromCanonical (stdGenFactorisation (Just (bound*(bound+2))) (mkStdGen $ fromIntegral n `xor` 0xdecaf00d) Nothing n) - --- | Calculate the totient from the canonical factorisation. -totientFromCanonical :: [(Integer,Int)] -> Integer -totientFromCanonical = product . map ppTotient - --- | Totient of a prime power. -ppTotient :: (Integer, Int) -> Integer -ppTotient (p, 1) = p - 1 -ppTotient (p, k) = (p - 1) * p ^ (k - 1) - --- | @'carmichaelSieve' n@ creates a store of values of the Carmichael function --- for numbers not exceeding @n@. --- Like a 'TotientSieve', a 'CarmichaelSieve' only stores values for numbers coprime to @30@ --- to reduce space usage. The maximal admissible value for @n@ is @'fromIntegral' ('maxBound' :: 'Word')@. -carmichaelSieve :: Integer -> CarmichaelSieve -carmichaelSieve bound - | fromIntegral (maxBound :: Word) < bound = error "carmichaelSieve: overflow" - | bound < 8 = CS 7 (array (0,0) [(0,6)]) - | otherwise = CS bnd (carSieve bnd) - where - bnd = fromInteger bound - --- | @'sieveCarmichael' cs n@ finds the value of @λ(n)@ (or @ψ(n)@), the smallest positive --- integer @e@ such that for all @a@ with @gcd a n == 1@ the congruence @a^e ≡ 1 (mod n)@ holds, --- in other words, the (smallest) exponent of the group of units in @ℤ/(n)@. --- The strategy is analogous to 'sieveTotient'. -sieveCarmichael :: CarmichaelSieve -> Integer -> Integer -sieveCarmichael (CS bnd sve) = check - where - bound = fromIntegral bnd - check n - | n < 1 = error "Carmichael function only defined for positive numbers" - | n == 1 = 1 - | otherwise = go2 n - go2 n = case shiftToOddCount n of - (0,_) -> go3 1 n - (k,m) -> let tt = case k of - 1 -> 1 - 2 -> 2 - _ -> (shiftL 1 (k-2)) - in if m == 1 then tt else go3 tt m - go3 !tt n = case splitOff 3 n of - (0,_) -> go5 tt n - (k,1) | tt == 1 -> 2*3^(k-1) - | otherwise -> tt*3^(k-1) - (k,m) | tt == 1 -> go5 (2*3^(k-1)) m - | otherwise -> go5 (tt*3^(k-1)) m - go5 !tt n = case splitOff 5 n of - (0,_) -> sieveLoop tt n - (k,m) -> let tt' = case fromInteger tt .&. (3 :: Int) of - 0 -> tt - 2 -> 2*tt - _ -> 4*tt - nt = tt'*5^(k-1) - in if m == 1 then nt else sieveLoop nt m - sieveLoop !tt n - | bound < n = tdLoop tt n (integerSquareRoot' n) 0 - | otherwise = case unsafeAt sve (toIdx n) of - nt -> tt `lcm` fromIntegral nt - lstIdx = snd (bounds sve) - tdLoop !tt n sr ix - | lstIdx < ix = curve tt n - | sr < p' = tt `lcm` (n-1) -- n is a prime - | pix /= p-1 = tdLoop tt n sr (ix+1) -- not a prime, next - | otherwise = case splitOff p' n of - (0,_) -> tdLoop tt n sr (ix+1) - (k,m) -> let nt = (lcm tt (p'-1))*p'^(k-1) - in case m of - 1 -> nt - j | j <= bound -> nt `lcm` fromIntegral (unsafeAt sve (toIdx j)) - | otherwise -> tdLoop nt j (integerSquareRoot' j) (ix+1) - where - p = toPrim ix - p' = fromIntegral p - pix = unsafeAt sve ix - curve tt n = tt `lcm` carmichaelFromCanonical (stdGenFactorisation (Just (bound*(bound+2))) (mkStdGen $ fromIntegral n `xor` 0xdecaf00d) Nothing n) - --- | Calculate the Carmichael function from the factorisation. --- Requires that the list of prime factors is strictly ascending. -carmichaelFromCanonical :: [(Integer, Int)] -> Integer -carmichaelFromCanonical = go2 - where - go2 ((2, k) : ps) = let acc = case k of - 1 -> 1 - 2 -> 2 - _ -> 1 `shiftL` (k-2) - in go acc ps - go2 ps = go 1 ps - go !acc ((p, 1) : pps) = go (lcm acc (p - 1)) pps - go acc ((p, k) : pps) = go ((lcm acc (p - 1)) * p ^ (k - 1)) pps - go acc [] = acc - --- NOTE: This is a legacy implementation of FactorSieve which uses the --- same (2,3,5) wheel optimization as the other sieves. --- It is still used to generate the other sieves. -spfSieve :: Word -> ST s (STUArray s Int Word) -spfSieve bound = do - let (octs,lidx) = idxPr bound - !mxidx = 8*octs+lidx - mxval :: Word - mxval = 30*fromIntegral octs + fromIntegral (rho lidx) - !mxsve = integerSquareRoot' mxval - (kr,r) = idxPr mxsve - !svbd = 8*kr+r - ar <- newArray (0,mxidx) 0 - let start k i = 8*(k*(30*k+2*rho i) + byte i) + idx i - tick p stp off j ix - | mxidx < ix = return () - | otherwise = do - s <- unsafeRead ar ix - when (s == 0) (unsafeWrite ar ix p) - tick p stp off ((j+1) .&. 7) (ix + stp*delta j + tau (off+j)) - sift ix - | svbd < ix = return ar - | otherwise = do - e <- unsafeRead ar ix - when (e == 0) (do let i = ix .&. 7 - k = ix `shiftR` 3 - !off = i `shiftL` 3 - !stp = ix - i - !p = toPrim ix - tick p stp off i (start k i)) - sift (ix+1) - sift 0 - -totSieve :: Word -> UArray Int Word -totSieve bound = runSTUArray $ do - ar <- spfSieve bound - (_,lst) <- getBounds ar - let tot ix - | lst < ix = return ar - | otherwise = do - p <- unsafeRead ar ix - if p == 0 - then unsafeWrite ar ix (toPrim ix - 1) - else do let !n = toPrim ix - (tp,m) = unFact p (n `quot` p) - case m of - 1 -> unsafeWrite ar ix tp - _ -> do - tm <- unsafeRead ar (toIdx m) - unsafeWrite ar ix (tp*tm) - tot (ix+1) - tot 0 - -carSieve :: Word -> UArray Int Word -carSieve bound = runSTUArray $ do - ar <- spfSieve bound - (_,lst) <- getBounds ar - let car ix - | lst < ix = return ar - | otherwise = do - p <- unsafeRead ar ix - if p == 0 - then unsafeWrite ar ix (toPrim ix - 1) - else do let !n = toPrim ix - (tp,m) = unFact p (n `quot` p) - case m of - 1 -> unsafeWrite ar ix tp - _ -> do - tm <- unsafeRead ar (toIdx m) - unsafeWrite ar ix (lcm tp tm) - car (ix+1) - car 0 - --- Find the p-part of the totient of (p*m) and the cofactor --- of the p-power in m. -{-# INLINE unFact #-} -unFact :: Word -> Word -> (Word,Word) -unFact p m = go (p-1) m - where - go !tt k = case k `quotRem` p of - (q,0) -> go (p*tt) q - _ -> (tt,k) diff --git a/Math/NumberTheory/Primes/Testing.hs b/Math/NumberTheory/Primes/Testing.hs --- a/Math/NumberTheory/Primes/Testing.hs +++ b/Math/NumberTheory/Primes/Testing.hs @@ -19,9 +19,6 @@ , millerRabinV , isStrongFermatPP , isFermatPP - -- * Using a sieve - , FactorSieve - , fsIsPrime -- * Trial division , trialDivisionPrimeTo ) where @@ -29,15 +26,3 @@ import Math.NumberTheory.Primes.Testing.Probabilistic import Math.NumberTheory.Primes.Testing.Certified import Math.NumberTheory.Primes.Factorisation.TrialDivision -import Math.NumberTheory.Primes.Sieve.Misc - -{-# DEPRECATED fsIsPrime "Use new interface for sieves, provided by Math.NumberTheory.ArithmeticFunctions.SieveBlock" #-} - --- | Test primality using a 'FactorSieve'. If @n@ is out of bounds --- of the sieve, fall back to 'isPrime'. -fsIsPrime :: FactorSieve -> Integer -> Bool -fsIsPrime fs n - | n < 0 = fsIsPrime fs (-n) - | n <= fromIntegral (fsBound fs) = fsPrimeTest fs n - | otherwise = isPrime n - diff --git a/Math/NumberTheory/Primes/Testing/Certificates/Internal.hs b/Math/NumberTheory/Primes/Testing/Certificates/Internal.hs --- a/Math/NumberTheory/Primes/Testing/Certificates/Internal.hs +++ b/Math/NumberTheory/Primes/Testing/Certificates/Internal.hs @@ -30,9 +30,6 @@ ) where import Data.List -#if __GLASGOW_HASKELL__ < 709 -import Data.Word -#endif import Data.Bits import Data.Maybe import GHC.Integer.GMP.Internals diff --git a/Math/NumberTheory/Primes/Testing/Probabilistic.hs b/Math/NumberTheory/Primes/Testing/Probabilistic.hs --- a/Math/NumberTheory/Primes/Testing/Probabilistic.hs +++ b/Math/NumberTheory/Primes/Testing/Probabilistic.hs @@ -156,7 +156,7 @@ square = isPossibleSquare2 n && r*r == n r = integerSquareRoot n d = find True 5 - find !pos cd = case jacobi' (n `rem` cd) cd of + find !pos cd = case jacobi (n `rem` cd) cd of MinusOne -> if pos then cd else (-cd) Zero -> if cd == n then 1 else 0 One -> find (not pos) (cd+2) @@ -187,16 +187,10 @@ v2n1 = ((un1 - (2*q)*un)*vn-qn) `rem` n q2n = (qn*qn) `rem` n q2n1 = (qn*qn*q) `rem` n -#if __GLASGOW_HASKELL__ < 709 -testLucas n q (J# s# ba#) = test (s# -# 1#) - where - test j# = case indexWordArray# ba# j# of -#else testLucas n q (Jp# bn#) = test (s# -# 1#) where s# = sizeofBigNat# bn# test j# = case indexBigNat# bn# j# of -#endif 0## -> test (j# -# 1#) w# -> look (j# -# 1#) (W# w#) (WORD_SIZE_IN_BITS - 1) look j# w i @@ -205,11 +199,7 @@ go k# w i un un1 vn qn | i < 0 = if isTrue# (k# <# 0#) then (un,vn,qn) -#if __GLASGOW_HASKELL__ < 709 - else go (k# -# 1#) (W# (indexWordArray# ba# k#)) (WORD_SIZE_IN_BITS - 1) un un1 vn qn -#else else go (k# -# 1#) (W# (indexBigNat# bn# k#)) (WORD_SIZE_IN_BITS - 1) un un1 vn qn -#endif | testBit w i = go k# w (i-1) u2n1 u2n2 v2n1 q2n1 | otherwise = go k# w (i-1) u2n u2n1 v2n q2n where @@ -220,7 +210,5 @@ v2n1 = ((un1 - (2*q)*un)*vn-qn) `rem` n q2n = (qn*qn) `rem` n q2n1 = (qn*qn*q) `rem` n -#if __GLASGOW_HASKELL__ >= 709 -- Listed as a precondition of lucasTest testLucas _ _ _ = error "lucasTest: negative argument" -#endif diff --git a/Math/NumberTheory/Primes/Types.hs b/Math/NumberTheory/Primes/Types.hs --- a/Math/NumberTheory/Primes/Types.hs +++ b/Math/NumberTheory/Primes/Types.hs @@ -10,8 +10,9 @@ -- Should not be exposed to users. -- -{-# LANGUAGE CPP #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveGeneric #-} module Math.NumberTheory.Primes.Types ( Prime @@ -19,23 +20,24 @@ , PrimeNat(..) ) where -#if MIN_VERSION_base(4,8,0) -#else -import Data.Word -#endif - import Numeric.Natural +import GHC.Generics +import Control.DeepSeq newtype Prm = Prm { unPrm :: Word } - deriving (Eq, Ord) + deriving (Eq, Ord, Generic) +instance NFData Prm + instance Show Prm where showsPrec d (Prm p) r = (if d > 10 then "(" ++ s ++ ")" else s) ++ r where s = "Prm " ++ show p newtype PrimeNat = PrimeNat { unPrimeNat :: Natural } - deriving (Eq, Ord) + deriving (Eq, Ord, Generic) + +instance NFData PrimeNat instance Show PrimeNat where showsPrec d (PrimeNat p) r = (if d > 10 then "(" ++ s ++ ")" else s) ++ r diff --git a/Math/NumberTheory/Quadratic/EisensteinIntegers.hs b/Math/NumberTheory/Quadratic/EisensteinIntegers.hs new file mode 100644 --- /dev/null +++ b/Math/NumberTheory/Quadratic/EisensteinIntegers.hs @@ -0,0 +1,315 @@ +-- | +-- Module: Math.NumberTheory.EisensteinIntegers +-- Copyright: (c) 2018 Alexandre Rodrigues Baldé +-- Licence: MIT +-- Maintainer: Alexandre Rodrigues Baldé +-- Stability: Provisional +-- Portability: Non-portable (GHC extensions) +-- +-- This module exports functions for manipulating Eisenstein integers, including +-- computing their prime factorisations. +-- + +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE RankNTypes #-} + +module Math.NumberTheory.Quadratic.EisensteinIntegers + ( EisensteinInteger(..) + , ω + , conjugate + , norm + , associates + , ids + + , divideByThree + + -- * Primality functions + , factorise + , findPrime + , isPrime + , primes + ) where + +import Data.List (mapAccumL, partition) +import Data.Maybe (fromMaybe) +import Data.Ord (comparing) +import GHC.Generics (Generic) + +import qualified Math.NumberTheory.Euclidean as ED +import Math.NumberTheory.Moduli.Sqrt +import qualified Math.NumberTheory.Primes.Factorisation as Factorisation +import Math.NumberTheory.Primes.Types (PrimeNat(..)) +import qualified Math.NumberTheory.Primes.Sieve as Sieve +import qualified Math.NumberTheory.Primes.Testing as Testing +import Math.NumberTheory.Utils (mergeBy) +import Math.NumberTheory.Utils.FromIntegral (integerToNatural) + +infix 6 :+ + +-- | An Eisenstein integer is a + bω, where a and b are both integers. +data EisensteinInteger = (:+) { real :: !Integer, imag :: !Integer } + deriving (Eq, Ord, Generic) + +-- | The imaginary unit for Eisenstein integers, where +-- +-- > ω == (-1/2) + ((sqrt 3)/2)ι == exp(2*pi*ι/3) +-- and ι is the usual imaginary unit with ι² == -1. +ω :: EisensteinInteger +ω = 0 :+ 1 + +instance Show EisensteinInteger where + show (a :+ b) + | b == 0 = show a + | a == 0 = s ++ b' + | otherwise = show a ++ op ++ b' + where + b' = if abs b == 1 then "ω" else show (abs b) ++ "*ω" + op = if b > 0 then "+" else "-" + s = if b > 0 then "" else "-" + +instance Num EisensteinInteger where + (+) (a :+ b) (c :+ d) = (a + c) :+ (b + d) + (*) (a :+ b) (c :+ d) = (a * c - b * d) :+ (b * (c - d) + a * d) + abs = fst . absSignum + negate (a :+ b) = (-a) :+ (-b) + fromInteger n = n :+ 0 + signum = snd . absSignum + +-- | Returns an @EisensteinInteger@'s sign, and its associate in the first +-- sextant. +absSignum :: EisensteinInteger -> (EisensteinInteger, EisensteinInteger) +absSignum z@(a :+ b) + | a == 0 && b == 0 = (z, 0) -- origin + | a > b && b >= 0 = (z, 1) -- first sextant: 0 ≤ Arg(η) < π/3 + | b >= a && a > 0 = ((-ω) * z, 1 + ω) -- second sextant: π/3 ≤ Arg(η) < 2π/3 + | b > 0 && 0 >= a = ((-1 - ω) * z, ω) -- third sextant: 2π/3 ≤ Arg(η) < π + | a < b && b <= 0 = (- z, -1) -- fourth sextant: -π < Arg(η) < -2π/3 or Arg(η) = π + | b <= a && a < 0 = (ω * z, -1 - ω) -- fifth sextant: -2π/3 ≤ Arg(η) < -π/3 + | otherwise = ((1 + ω) * z, -ω) -- sixth sextant: -π/3 ≤ Arg(η) < 0 + +-- | List of all Eisenstein units, counterclockwise across all sextants, +-- starting with @1@. +ids :: [EisensteinInteger] +ids = take 6 (iterate ((1 + ω) *) 1) + +-- | Produce a list of an @EisensteinInteger@'s associates. +associates :: EisensteinInteger -> [EisensteinInteger] +associates e = map (e *) ids + +-- | Takes an Eisenstein prime whose norm is of the form @3k + 1@ with @k@ +-- a nonnegative integer, and return its primary associate. +-- * Does *not* check for this precondition. +-- * @head@ will fail when supplied a number unsatisfying it. +primary :: EisensteinInteger -> EisensteinInteger +primary = head . filter (\p -> p `ED.mod` 3 == 2) . associates + +instance ED.Euclidean EisensteinInteger where + quotRem = divHelper quot + divMod = divHelper div + +-- | Function that does most of the underlying work for @divMod@ and +-- @quotRem@, apart from choosing the specific integer division algorithm. +-- This is instead done by the calling function (either @divMod@ which uses +-- @div@, or @quotRem@, which uses @quot@.) +divHelper + :: (Integer -> Integer -> Integer) + -> EisensteinInteger + -> EisensteinInteger + -> (EisensteinInteger, EisensteinInteger) +divHelper divide g h = + let nr :+ ni = g * conjugate h + denom = norm h + q = divide nr denom :+ divide ni denom + p = h * q + in (q, g - p) + +-- | Conjugate a Eisenstein integer. +conjugate :: EisensteinInteger -> EisensteinInteger +conjugate (a :+ b) = (a - b) :+ (-b) + +-- | The square of the magnitude of a Eisenstein integer. +norm :: EisensteinInteger -> Integer +norm (a :+ b) = a*a - a * b + b*b + +-- | Checks if a given @EisensteinInteger@ is prime. @EisensteinInteger@s +-- whose norm is a prime congruent to @0@ or @1@ modulo 3 are prime. +-- See , +-- page 12. +isPrime :: EisensteinInteger -> Bool +isPrime e | e == 0 = False + -- Special case, @1 - ω@ is the only Eisenstein prime with norm @3@, + -- and @abs (1 - ω) = 2 + ω@. + | a' == 2 && b' == 1 = True + | b' == 0 && a' `mod` 3 == 2 = Testing.isPrime a' + | nE `mod` 3 == 1 = Testing.isPrime nE + | otherwise = False + where nE = norm e + a' :+ b' = abs e + +-- | Remove @1 - ω@ factors from an @EisensteinInteger@, and calculate that +-- prime's multiplicity in the number's factorisation. +divideByThree :: EisensteinInteger -> (Int, EisensteinInteger) +divideByThree = go 0 + where + go :: Int -> EisensteinInteger -> (Int, EisensteinInteger) + go !n z@(a :+ b) | r1 == 0 && r2 == 0 = go (n + 1) (q1 :+ q2) + | otherwise = (n, abs z) + where + -- @(a + a - b) :+ (a + b)@ is @z * (2 :+ 1)@, and @z * (2 :+ 1)/3@ + -- is the same as @z / (1 :+ (-1))@. + (q1, r1) = divMod (a + a - b) 3 + (q2, r2) = divMod (a + b) 3 + +-- | Find an Eisenstein integer whose norm is the given prime number +-- in the form @3k + 1@ using a modification of the +-- . +-- +-- The maintainer +-- derived the following: +-- * Each prime of form @3n+1@ is actually of form @6k+1@. +-- * One has @(z+3k)^2 ≡ z^2 + 6kz + 9k^2 ≡ z^2 + (6k+1)z - z + 9k^2 ≡ z^2 - z + 9k^2 (mod 6k+1)@. +-- +-- * The goal is to solve @z^2 - z + 1 ≡ 0 (mod 6k+1)@. One has: +-- @z^2 - z + 9k^2 ≡ 9k^2 - 1 (mod 6k+1)@ +-- @(z+3k)^2 ≡ 9k^2-1 (mod 6k+1)@ +-- @z+3k = sqrtMod(9k^2-1)@ +-- @z = sqrtMod(9k^2-1) - 3k@ +-- +-- * For example, let @p = 7@, then @k = 1@. Square root of @9*1^2-1 modulo 7@ is @1@. +-- * And @z = 1 - 3*1 = -2 ≡ 5 (mod 7)@. +-- * Truly, @norm (5 :+ 1) = 25 - 5 + 1 = 21 ≡ 0 (mod 7)@. +findPrime :: Integer -> EisensteinInteger +findPrime p = case sqrtsModPrime (9*k*k - 1) (PrimeNat . integerToNatural $ p) of + [] -> error "findPrime: argument must be prime p = 6k + 1" + z : _ -> ED.gcd (p :+ 0) ((z - 3 * k) :+ 1) + where + k :: Integer + k = p `div` 6 + +-- | An infinite list of Eisenstein primes. Uses primes in Z to exhaustively +-- generate all Eisenstein primes in order of ascending magnitude. +-- * Every prime is in the first sextant, so the list contains no associates. +-- * Eisenstein primes from the whole complex plane can be generated by +-- applying @associates@ to each prime in this list. +primes :: [EisensteinInteger] +primes = (2 :+ 1) : mergeBy (comparing norm) l r + where (leftPrimes, rightPrimes) = partition (\p -> p `mod` 3 == 2) Sieve.primes + rightPrimes' = filter (\prime -> prime `mod` 3 == 1) $ tail rightPrimes + l = [p :+ 0 | p <- leftPrimes] + r = [g | p <- rightPrimes', let x :+ y = findPrime p, g <- [x :+ y, x :+ (x - y)]] + +-- | Compute the prime factorisation of a Eisenstein integer. This is unique +-- up to units (+/- 1, +/- ω, +/- ω²). +-- * Unit factors are not included in the result. +-- * All prime factors are primary i.e. @e ≡ 2 (modE 3)@, for an Eisenstein +-- prime factor @e@. +-- +-- * This function works by factorising the norm of an Eisenstein integer +-- and then, for each prime factor, finding the Eisenstein prime whose norm +-- is said prime factor with @findPrime@. +-- +-- * This is only possible because the norm function of the Euclidean Domain of +-- Eisenstein integers is multiplicative: @norm (e1 * e2) == norm e1 * norm e2@ +-- for any two @EisensteinInteger@s @e1, e2@. +-- +-- * In the previously mentioned work , +-- in Theorem 8.4 in Chapter 8, a way is given to express any Eisenstein +-- integer @μ@ as @(-1)^a * ω^b * (1 - ω)^c * product [π_i^a_i | i <- [1..N]]@ +-- where @a, b, c, a_i@ are nonnegative integers, @N > 1@ is an integer and +-- @π_i@ are primary primes (for a primary Eisenstein prime @p@, +-- @p ≡ 2 (modE 3)@, see @primary@ above). +-- +-- * Aplying @norm@ to both sides of Theorem 8.4: +-- @norm μ = norm ((-1)^a * ω^b * (1 - ω)^c * product [ π_i^a_i | i <- [1..N]])@ +-- == @norm μ = norm ((-1)^a) * norm (ω^b) * norm ((1 - ω)^c) * norm (product [ π_i^a_i | i <- [1..N]])@ +-- == @norm μ = (norm (-1))^a * (norm ω)^b * (norm (1 - ω))^c * product [ norm (π_i^a_i) | i <- [1..N]]@ +-- == @norm μ = (norm (-1))^a * (norm ω)^b * (norm (1 - ω))^c * product [ (norm π_i)^a_i) | i <- [1..N]]@ +-- == @norm μ = 1^a * 1^b * 3^c * product [ (norm π_i)^a_i) | i <- [1..N]]@ +-- == @norm μ = 3^c * product [ (norm π_i)^a_i) | i <- [1..N]]@ +-- where @a, b, c, a_i@ are nonnegative integers, and @N > 1@ is an integer. +-- +-- * The remainder of the Eisenstein integer factorisation problem is about +-- finding appropriate @[e_i | i <- [1..M]@ such that +-- @(nub . map norm) [e_i | i <- [1..N]] == [π_i | i <- [1..N]]@ +-- where @ 1 < N <= M@ are integers, @nub@ removes duplicates and @==@ +-- is equality on sets. +-- +-- * The reason @M >= N@ is because the prime factors of an Eisenstein integer +-- may include a prime factor and its conjugate, meaning the number may have +-- more Eisenstein prime factors than its norm has integer prime factors. +factorise :: EisensteinInteger -> [(EisensteinInteger, Int)] +factorise g = concat $ + snd $ + mapAccumL go (abs g) (Factorisation.factorise $ norm g) + where + go :: EisensteinInteger -> (Integer, Int) -> (EisensteinInteger, [(EisensteinInteger, Int)]) + go z (3, e) | e == n = (q, [(2 :+ 1, e)]) + | otherwise = error $ "3 is a prime factor of the norm of z\ + \ == " ++ show z ++ " with multiplicity\ + \ " ++ show e ++ " but (1 - ω) only\ + \ divides z " ++ show n ++ "times." + where + -- Remove all @1 :+ (-1)@ (which is associated to @2 :+ 1@) factors + -- from the argument. + (n, q) = divideByThree z + go z (p, e) | p `mod` 3 == 2 = + let e' = e `quot` 2 in (z `quotI` (p ^ e'), [(p :+ 0, e')]) + + -- The @`mod` 3 == 0@ case need not be verified because the + -- only Eisenstein primes whose norm are a multiple of 3 + -- are @1 - ω@ and its associates, which have already been + -- removed by the above @go z (3, e)@ pattern match. + -- This @otherwise@ is mandatorily @`mod` 3 == 1@. + | otherwise = (z', filter ((> 0) . snd) [(gp, k), (gp', k')]) + where + gp@(x :+ y) = primary $ findPrime p + -- @gp'@ is @gp@'s conjugate. + gp' = primary $ abs $ x :+ (x - y) + (k, k', z') = divideByPrime gp gp' p e z + + quotI (a :+ b) n = (a `quot` n :+ b `quot` n) + +-- | Remove @p@ and @conjugate p@ factors from the argument, where +-- @p@ is an Eisenstein prime. +divideByPrime + :: EisensteinInteger -- ^ Eisenstein prime @p@ + -> EisensteinInteger -- ^ Conjugate of @p@ + -> Integer -- ^ Precomputed norm of @p@, of form @4k + 1@ + -> Int -- ^ Expected number of factors (either @p@ or @conjugate p@) + -- in Eisenstein integer @z@ + -> EisensteinInteger -- ^ Eisenstein integer @z@ + -> ( Int -- Multiplicity of factor @p@ in @z@ + , Int -- Multiplicity of factor @conjigate p@ in @z@ + , EisensteinInteger -- Remaining Eisenstein integer + ) +divideByPrime p p' np k = go k 0 + where + go :: Int -> Int -> EisensteinInteger -> (Int, Int, EisensteinInteger) + go 0 d z = (d, d, z) + go c d z | c >= 2, Just z' <- z `quotEvenI` np = go (c - 2) (d + 1) z' + go c d z = (d + d1, d + d2, z'') + where + (d1, z') = go1 c 0 z + d2 = c - d1 + z'' = head $ drop d2 + $ iterate (\g -> fromMaybe err $ (g * p) `quotEvenI` np) z' + + go1 :: Int -> Int -> EisensteinInteger -> (Int, EisensteinInteger) + go1 0 d z = (d, z) + go1 c d z + | Just z' <- (z * p') `quotEvenI` np + = go1 (c - 1) (d + 1) z' + | otherwise + = (d, z) + + err = error $ "divideByPrime: malformed arguments" ++ show (p, np, k) + +-- | Divide an Eisenstein integer by an even integer. +quotEvenI :: EisensteinInteger -> Integer -> Maybe EisensteinInteger +quotEvenI (x :+ y) n + | xr == 0 , yr == 0 = Just (xq :+ yq) + | otherwise = Nothing + where + (xq, xr) = x `quotRem` n + (yq, yr) = y `quotRem` n diff --git a/Math/NumberTheory/Quadratic/GaussianIntegers.hs b/Math/NumberTheory/Quadratic/GaussianIntegers.hs new file mode 100644 --- /dev/null +++ b/Math/NumberTheory/Quadratic/GaussianIntegers.hs @@ -0,0 +1,254 @@ +-- | +-- Module: Math.NumberTheory.GaussianIntegers +-- Copyright: (c) 2016 Chris Fredrickson, Google Inc. +-- Licence: MIT +-- Maintainer: Chris Fredrickson +-- Stability: Provisional +-- Portability: Non-portable (GHC extensions) +-- +-- This module exports functions for manipulating Gaussian integers, including +-- computing their prime factorisations. +-- + +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveGeneric #-} + +module Math.NumberTheory.Quadratic.GaussianIntegers ( + GaussianInteger(..), + ι, + conjugate, + norm, + (.^), + isPrime, + primes, + gcdG, + gcdG', + findPrime, + findPrime', + factorise, +) where + +import Control.DeepSeq (NFData) +import Data.List (mapAccumL, partition) +import Data.Maybe (fromMaybe) +import Data.Ord (comparing) +import GHC.Generics + + +import qualified Math.NumberTheory.Euclidean as ED +import Math.NumberTheory.Moduli.Sqrt +import Math.NumberTheory.Powers (integerSquareRoot) +import Math.NumberTheory.Primes.Types (PrimeNat(..)) +import qualified Math.NumberTheory.Primes.Factorisation as Factorisation +import qualified Math.NumberTheory.Primes.Sieve as Sieve +import qualified Math.NumberTheory.Primes.Testing as Testing +import Math.NumberTheory.Utils (mergeBy) +import Math.NumberTheory.Utils.FromIntegral (integerToNatural) + +infix 6 :+ +infixr 8 .^ +-- |A Gaussian integer is a+bi, where a and b are both integers. +data GaussianInteger = (:+) { real :: !Integer, imag :: !Integer } + deriving (Eq, Ord, Generic) + +instance NFData GaussianInteger + +-- |The imaginary unit, where +-- +-- > ι .^ 2 == -1 +ι :: GaussianInteger +ι = 0 :+ 1 + +instance Show GaussianInteger where + show (a :+ b) + | b == 0 = show a + | a == 0 = s ++ b' + | otherwise = show a ++ op ++ b' + where + b' = if abs b == 1 then "ι" else show (abs b) ++ "*ι" + op = if b > 0 then "+" else "-" + s = if b > 0 then "" else "-" + +instance Num GaussianInteger where + (+) (a :+ b) (c :+ d) = (a + c) :+ (b + d) + (*) (a :+ b) (c :+ d) = (a * c - b * d) :+ (a * d + b * c) + abs = fst . absSignum + negate (a :+ b) = (-a) :+ (-b) + fromInteger n = n :+ 0 + signum = snd . absSignum + +absSignum :: GaussianInteger -> (GaussianInteger, GaussianInteger) +absSignum z@(a :+ b) + | a == 0 && b == 0 = (z, 0) -- origin + | a > 0 && b >= 0 = (z, 1) -- first quadrant: (0, inf) x [0, inf)i + | a <= 0 && b > 0 = (b :+ (-a), ι) -- second quadrant: (-inf, 0] x (0, inf)i + | a < 0 && b <= 0 = ((-a) :+ (-b), -1) -- third quadrant: (-inf, 0) x (-inf, 0]i + | otherwise = ((-b) :+ a, -ι) -- fourth quadrant: [0, inf) x (-inf, 0)i + +instance ED.Euclidean GaussianInteger where + quotRem = divHelper quot + divMod = divHelper div + +divHelper + :: (Integer -> Integer -> Integer) + -> GaussianInteger + -> GaussianInteger + -> (GaussianInteger, GaussianInteger) +divHelper divide g h = + let nr :+ ni = g * conjugate h + denom = norm h + q = divide nr denom :+ divide ni denom + p = h * q + in (q, g - p) + +-- |Conjugate a Gaussian integer. +conjugate :: GaussianInteger -> GaussianInteger +conjugate (r :+ i) = r :+ (-i) + +-- |The square of the magnitude of a Gaussian integer. +norm :: GaussianInteger -> Integer +norm (x :+ y) = x * x + y * y + +-- |Compute whether a given Gaussian integer is prime. +isPrime :: GaussianInteger -> Bool +isPrime g@(x :+ y) + | x == 0 && y /= 0 = abs y `mod` 4 == 3 && Testing.isPrime y + | y == 0 && x /= 0 = abs x `mod` 4 == 3 && Testing.isPrime x + | otherwise = Testing.isPrime $ norm g + +-- |An infinite list of the Gaussian primes. Uses primes in Z to exhaustively +-- generate all Gaussian primes (up to associates), in order of ascending +-- magnitude. +primes :: [GaussianInteger] +primes = (1 :+ 1): mergeBy (comparing norm) l r + where (leftPrimes, rightPrimes) = partition (\p -> p `mod` 4 == 3) (tail Sieve.primes) + l = [p :+ 0 | p <- leftPrimes] + r = [g | p <- rightPrimes, let x :+ y = findPrime p, g <- [x :+ y, y :+ x]] + + +-- | Compute the GCD of two Gaussian integers. Result is always +-- in the first quadrant. +gcdG :: GaussianInteger -> GaussianInteger -> GaussianInteger +gcdG = ED.gcd +{-# DEPRECATED gcdG "Use 'Math.NumberTheory.Euclidean.gcd' instead." #-} + +gcdG' :: GaussianInteger -> GaussianInteger -> GaussianInteger +gcdG' = ED.gcd +{-# DEPRECATED gcdG' "Use 'Math.NumberTheory.Euclidean.gcd' instead." #-} + +-- |Find a Gaussian integer whose norm is the given prime number +-- of form 4k + 1 using +-- . +findPrime :: Integer -> GaussianInteger +findPrime p = case sqrtsModPrime (-1) (PrimeNat . integerToNatural $ p) of + [] -> error "findPrime: an argument must be prime p = 4k + 1" + z : _ -> go p z -- Effectively we calculate gcdG' (p :+ 0) (z :+ 1) + where + sqrtp :: Integer + sqrtp = integerSquareRoot p + + go :: Integer -> Integer -> GaussianInteger + go g h + | g <= sqrtp = g :+ h + | otherwise = go h (g `mod` h) + +findPrime' :: Integer -> GaussianInteger +findPrime' = findPrime +{-# DEPRECATED findPrime' "Use 'findPrime' instead." #-} + +-- |Raise a Gaussian integer to a given power. +(.^) :: (Integral a) => GaussianInteger -> a -> GaussianInteger +a .^ e + | e < 0 && norm a == 1 = + case a of + 1 :+ 0 -> 1 + (-1) :+ 0 -> if even e then 1 else (-1) + 0 :+ 1 -> (0 :+ (-1)) .^ (abs e `mod` 4) + _ -> (0 :+ 1) .^ (abs e `mod` 4) + | e < 0 = error "Cannot exponentiate non-unit Gaussian Int to negative power" + | a == 0 = 0 + | e == 0 = 1 + | even e = s * s + | otherwise = a * a .^ (e - 1) + where + s = a .^ div e 2 +{-# DEPRECATED (.^) "Use (^) instead." #-} + +-- |Compute the prime factorisation of a Gaussian integer. This is unique up to units (+/- 1, +/- i). +-- Unit factors are not included in the result. +factorise :: GaussianInteger -> [(GaussianInteger, Int)] +factorise g = concat $ snd $ mapAccumL go g (Factorisation.factorise $ norm g) + where + go :: GaussianInteger -> (Integer, Int) -> (GaussianInteger, [(GaussianInteger, Int)]) + go z (2, e) = (divideByTwo z, [(1 :+ 1, e)]) + go z (p, e) + | p `mod` 4 == 3 + = let e' = e `quot` 2 in (z `quotI` (p ^ e'), [(p :+ 0, e')]) + | otherwise + = (z', filter ((> 0) . snd) [(gp, k), (gp', k')]) + where + gp = findPrime p + (k, k', z') = divideByPrime gp p e z + gp' = abs (conjugate gp) + +-- | Remove all (1:+1) factors from the argument, +-- avoiding complex division. +divideByTwo :: GaussianInteger -> GaussianInteger +divideByTwo z@(x :+ y) + | even x, even y + = divideByTwo $ z `quotI` 2 + | odd x, odd y + = (x - y) `quot` 2 :+ (x + y) `quot` 2 + | otherwise + = z + +-- | Remove p and conj p factors from the argument, +-- avoiding complex division. +divideByPrime + :: GaussianInteger -- ^ Gaussian prime p + -> Integer -- ^ Precomputed norm of p, of form 4k + 1 + -> Int -- ^ Expected number of factors (either p or conj p) + -- in Gaussian integer z + -> GaussianInteger -- ^ Gaussian integer z + -> ( Int -- Multiplicity of factor p in z + , Int -- Multiplicity of factor conj p in z + , GaussianInteger -- Remaining Gaussian integer + ) +divideByPrime p np k = go k 0 + where + go :: Int -> Int -> GaussianInteger -> (Int, Int, GaussianInteger) + go 0 d z = (d, d, z) + go c d z + | c >= 2 + , Just z' <- z `quotEvenI` np + = go (c - 2) (d + 1) z' + go c d z = (d + d1, d + d2, z'') + where + (d1, z') = go1 c 0 z + d2 = c - d1 + z'' = head $ drop d2 + $ iterate (\g -> fromMaybe err $ (g * p) `quotEvenI` np) z' + + go1 :: Int -> Int -> GaussianInteger -> (Int, GaussianInteger) + go1 0 d z = (d, z) + go1 c d z + | Just z' <- (z * conjugate p) `quotEvenI` np + = go1 (c - 1) (d + 1) z' + | otherwise + = (d, z) + + err = error $ "divideByPrime: malformed arguments" ++ show (p, np, k) + +quotI :: GaussianInteger -> Integer -> GaussianInteger +quotI (x :+ y) n = (x `quot` n :+ y `quot` n) + +quotEvenI :: GaussianInteger -> Integer -> Maybe GaussianInteger +quotEvenI (x :+ y) n + | xr == 0 + , yr == 0 + = Just (xq :+ yq) + | otherwise + = Nothing + where + (xq, xr) = x `quotRem` n + (yq, yr) = y `quotRem` n diff --git a/Math/NumberTheory/Recurrencies.hs b/Math/NumberTheory/Recurrencies.hs new file mode 100644 --- /dev/null +++ b/Math/NumberTheory/Recurrencies.hs @@ -0,0 +1,18 @@ +-- | +-- Module: Math.NumberTheory.Recurrencies +-- Copyright: (c) 2018 Alexandre Rodrigues Baldé +-- Licence: MIT +-- Maintainer: Alexandre Rodrigues Baldé +-- Stability: Provisional +-- Portability: Non-portable (GHC extensions) +-- + +module Math.NumberTheory.Recurrencies + ( module Math.NumberTheory.Recurrencies.Linear + , module Math.NumberTheory.Recurrencies.Bilinear + , module Math.NumberTheory.Recurrencies.Pentagonal + ) where + +import Math.NumberTheory.Recurrencies.Bilinear +import Math.NumberTheory.Recurrencies.Linear +import Math.NumberTheory.Recurrencies.Pentagonal (partition) diff --git a/Math/NumberTheory/Recurrencies/Bilinear.hs b/Math/NumberTheory/Recurrencies/Bilinear.hs --- a/Math/NumberTheory/Recurrencies/Bilinear.hs +++ b/Math/NumberTheory/Recurrencies/Bilinear.hs @@ -14,25 +14,26 @@ -- Top-level definitions in this module are polymorphic, so the results of computations are not retained in memory. -- Make them monomorphic to take advantages of memoization. Compare -- --- > > :set +s --- > > binomial !! 1000 !! 1000 :: Integer --- > 1 --- > (0.01 secs, 1,385,512 bytes) --- > > binomial !! 1000 !! 1000 :: Integer --- > 1 --- > (0.01 secs, 1,381,616 bytes) +-- >>> :set +s +-- >>> binomial !! 1000 !! 1000 :: Integer +-- 1 +-- (0.01 secs, 1,385,512 bytes) +-- >>> binomial !! 1000 !! 1000 :: Integer +-- 1 +-- (0.01 secs, 1,381,616 bytes) -- -- against -- --- > > let binomial' = binomial :: [[Integer]] --- > > binomial' !! 1000 !! 1000 :: Integer --- > 1 --- > (0.01 secs, 1,381,696 bytes) --- > > binomial' !! 1000 !! 1000 :: Integer --- > 1 --- > (0.01 secs, 391,152 bytes) +-- >>> let binomial' = binomial :: [[Integer]] +-- >>> binomial' !! 1000 !! 1000 :: Integer +-- 1 +-- (0.01 secs, 1,381,696 bytes) +-- >>> binomial' !! 1000 !! 1000 :: Integer +-- 1 +-- (0.01 secs, 391,152 bytes) -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} module Math.NumberTheory.Recurrencies.Bilinear ( binomial @@ -42,24 +43,21 @@ , eulerian1 , eulerian2 , bernoulli + , euler + , eulerPolyAt1 ) where import Data.List import Data.Ratio import Numeric.Natural -#if MIN_VERSION_base(4,8,0) -#else -import Data.Word -#endif - import Math.NumberTheory.Recurrencies.Linear (factorial) -- | Infinite zero-based table of binomial coefficients (also known as Pascal triangle): -- @binomial !! n !! k == n! \/ k! \/ (n - k)!@. -- --- > > take 5 (map (take 5) binomial) --- > [[1],[1,1],[1,2,1],[1,3,3,1],[1,4,6,4,1]] +-- >>> take 5 (map (take 5) binomial) +-- [[1],[1,1],[1,2,1],[1,3,3,1],[1,4,6,4,1]] -- -- Complexity: @binomial !! n !! k@ is O(n) bits long, its computation -- takes O(k n) time and forces thunks @binomial !! n !! i@ for @0 <= i <= k@. @@ -77,8 +75,8 @@ -- | Infinite zero-based table of . -- --- > > take 5 (map (take 5) stirling1) --- > [[1],[0,1],[0,1,1],[0,2,3,1],[0,6,11,6,1]] +-- >>> take 5 (map (take 5) stirling1) +-- [[1],[0,1],[0,1,1],[0,2,3,1],[0,6,11,6,1]] -- -- Complexity: @stirling1 !! n !! k@ is O(n ln n) bits long, its computation -- takes O(k n^2 ln n) time and forces thunks @stirling1 !! i !! j@ for @0 <= i <= n@ and @max(0, k - n + i) <= j <= k@. @@ -95,8 +93,8 @@ -- | Infinite zero-based table of . -- --- > > take 5 (map (take 5) stirling2) --- > [[1],[0,1],[0,1,1],[0,1,3,1],[0,1,7,6,1]] +-- >>> take 5 (map (take 5) stirling2) +-- [[1],[0,1],[0,1,1],[0,1,3,1],[0,1,7,6,1]] -- -- Complexity: @stirling2 !! n !! k@ is O(n ln n) bits long, its computation -- takes O(k n^2 ln n) time and forces thunks @stirling2 !! i !! j@ for @0 <= i <= n@ and @max(0, k - n + i) <= j <= k@. @@ -114,8 +112,8 @@ -- | Infinite one-based table of . -- @lah !! n !! k@ equals to lah(n + 1, k + 1). -- --- > > take 5 (map (take 5) lah) --- > [[1],[2,1],[6,6,1],[24,36,12,1],[120,240,120,20,1]] +-- >>> take 5 (map (take 5) lah) +-- [[1],[2,1],[6,6,1],[24,36,12,1],[120,240,120,20,1]] -- -- Complexity: @lah !! n !! k@ is O(n ln n) bits long, its computation -- takes O(k n ln n) time and forces thunks @lah !! n !! i@ for @0 <= i <= k@. @@ -131,8 +129,8 @@ -- | Infinite zero-based table of . -- --- > > take 5 (map (take 5) eulerian1) --- > [[],[1],[1,1],[1,4,1],[1,11,11,1]] +-- >>> take 5 (map (take 5) eulerian1) +-- [[],[1],[1,1],[1,4,1],[1,11,11,1]] -- -- Complexity: @eulerian1 !! n !! k@ is O(n ln n) bits long, its computation -- takes O(k n^2 ln n) time and forces thunks @eulerian1 !! i !! j@ for @0 <= i <= n@ and @max(0, k - n + i) <= j <= k@. @@ -148,8 +146,8 @@ -- | Infinite zero-based table of . -- --- > > take 5 (map (take 5) eulerian2) --- > [[],[1],[1,2],[1,8,6],[1,22,58,24]] +-- >>> take 5 (map (take 5) eulerian2) +-- [[],[1],[1,2],[1,8,6],[1,22,58,24]] -- -- Complexity: @eulerian2 !! n !! k@ is O(n ln n) bits long, its computation -- takes O(k n^2 ln n) time and forces thunks @eulerian2 !! i !! j@ for @0 <= i <= n@ and @max(0, k - n + i) <= j <= k@. @@ -167,20 +165,61 @@ -- computed via -- with 'stirling2'. -- --- > > take 5 bernoulli --- > [1 % 1,(-1) % 2,1 % 6,0 % 1,(-1) % 30] +-- >>> take 5 bernoulli +-- [1 % 1,(-1) % 2,1 % 6,0 % 1,(-1) % 30] -- -- Complexity: @bernoulli !! n@ is O(n ln n) bits long, its computation -- takes O(n^3 ln n) time and forces thunks @stirling2 !! i !! j@ for @0 <= i <= n@ and @0 <= j <= i@. -- -- One could also consider 'Math.Combinat.Numbers.bernoulli' to compute stand-alone values. bernoulli :: Integral a => [Ratio a] -bernoulli = map f stirling2 - where - f = sum . zipWith4 (\sgn denom fact stir -> sgn * fact * stir % denom) (cycle [1, -1]) [1..] factorial +bernoulli = helperForB_E_EP id (map recip [1..]) {-# SPECIALIZE bernoulli :: [Ratio Int] #-} {-# SPECIALIZE bernoulli :: [Rational] #-} +-- | Infinite zero-based list of . +-- The algorithm used was derived from +-- by Kwang-Wu Chen, second formula of the Corollary in page 7. +-- Sequence in OEIS. +-- +-- >>> take 10 euler' :: [Rational] +-- [1 % 1,0 % 1,(-1) % 1,0 % 1,5 % 1,0 % 1,(-61) % 1,0 % 1,1385 % 1,0 % 1] +euler' :: forall a . Integral a => [Ratio a] +euler' = tail $ helperForB_E_EP tail as + where + as :: [Ratio a] + as = zipWith3 + (\sgn frac ones -> (sgn * ones) % frac) + (cycle [1, 1, 1, 1, -1, -1, -1, -1]) + (dups (iterate (2 *) 1)) + (cycle [1, 1, 1, 0]) + + dups :: forall x . [x] -> [x] + dups = foldr (\n list -> n : n : list) [] +{-# SPECIALIZE euler' :: [Ratio Int] #-} +{-# SPECIALIZE euler' :: [Rational] #-} + +-- | The same sequence as @euler'@, but with type @[a]@ instead of @[Ratio a]@ +-- as the denominators in @euler'@ are always @1@. +-- +-- >>> take 10 euler :: [Integer] +-- [1, 0, -1, 0, 5, 0, -61, 0, 1385, 0] +euler :: forall a . Integral a => [a] +euler = map numerator euler' + +-- | Infinite zero-based list of the @n@-th order Euler polynomials evaluated at @1@. +-- The algorithm used was derived from +-- by Kwang-Wu Chen, third formula of the Corollary in page 7. +-- Element-by-element division of sequences +-- and in OEIS. +-- +-- >>> take 10 eulerPolyAt1 :: [Rational] +-- [1 % 1,1 % 2,0 % 1,(-1) % 4,0 % 1,1 % 2,0 % 1,(-17) % 8,0 % 1,31 % 2] +eulerPolyAt1 :: forall a . Integral a => [Ratio a] +eulerPolyAt1 = tail $ helperForB_E_EP tail (map recip (iterate (2 *) 1)) +{-# SPECIALIZE eulerPolyAt1 :: [Ratio Int] #-} +{-# SPECIALIZE eulerPolyAt1 :: [Rational] #-} + ------------------------------------------------------------------------------- -- Utils @@ -195,3 +234,22 @@ [] -> let v = f m y a in [v] (z : zs) -> let v = f m y z in (v : go (succ m) z zs) {-# INLINE zipIndexedListWithTail #-} + +-- | Helper for common code in @bernoulli, euler, eulerPolyAt1. All three +-- sequences rely on @stirling2@ and have the same general structure of +-- zipping four lists together with multiplication, with one of those lists +-- being the sublists in @stirling2@, and two of them being the factorial +-- sequence and @cycle [1, -1]@. The remaining list is passed to +-- @helperForB_E_EP@ as an argument. +-- +-- Note: This function has a @([Ratio a] -> [Ratio a])@ argument because +-- @bernoulli !! n@ will use, for all nonnegative @n@, every element in +-- @stirling2 !! n@, while @euler, eulerPolyAt1@ only use +-- @tail $ stirling2 !! n@. As such, this argument serves to pass @id@ +-- in the former case, and @tail@ in the latter. +helperForB_E_EP :: Integral a => ([Ratio a] -> [Ratio a]) -> [Ratio a] -> [Ratio a] +helperForB_E_EP g xs = map (f . g) stirling2 + where + f = sum . zipWith4 (\sgn fact x stir -> sgn * fact * x * stir) (cycle [1, -1]) factorial xs +{-# SPECIALIZE helperForB_E_EP :: ([Ratio Int] -> [Ratio Int]) -> [Ratio Int] -> [Ratio Int] #-} +{-# SPECIALIZE helperForB_E_EP :: ([Rational] -> [Rational]) -> [Rational] -> [Rational] #-} diff --git a/Math/NumberTheory/Recurrencies/Linear.hs b/Math/NumberTheory/Recurrencies/Linear.hs --- a/Math/NumberTheory/Recurrencies/Linear.hs +++ b/Math/NumberTheory/Recurrencies/Linear.hs @@ -23,15 +23,10 @@ import Data.Bits import Numeric.Natural -#if MIN_VERSION_base(4,8,0) -#else -import Data.Word -#endif - -- | Infinite zero-based table of factorials. -- --- > > take 5 factorial --- > [1,1,2,6,24] +-- >>> take 5 factorial +-- [1,1,2,6,24] -- -- The time-and-space behaviour of 'factorial' is similar to described in -- "Math.NumberTheory.Recurrencies.Bilinear#memory". diff --git a/Math/NumberTheory/Recurrencies/Pentagonal.hs b/Math/NumberTheory/Recurrencies/Pentagonal.hs new file mode 100644 --- /dev/null +++ b/Math/NumberTheory/Recurrencies/Pentagonal.hs @@ -0,0 +1,96 @@ +-- | +-- Module: Math.NumberTheory.Recurrencies.Pentagonal +-- Copyright: (c) 2018 Alexandre Rodrigues Baldé +-- Licence: MIT +-- Maintainer: Alexandre Rodrigues Baldé +-- Stability: Provisional +-- Portability: Non-portable (GHC extensions) +-- +-- Values of . +-- + +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE RankNTypes #-} + +module Math.NumberTheory.Recurrencies.Pentagonal + ( partition + , pentagonalSigns + , pents + ) where + +import qualified Data.IntMap as IM +import Numeric.Natural (Natural) + +-- | Infinite list of generalized pentagonal numbers. +-- Example: +-- +-- >>> take 10 pents +-- [0, 1, 2, 5, 7, 12 ,15, 22, 26, 35] +pents :: (Enum a, Num a) => [a] +pents = interleave (scanl (\acc n -> acc + 3 * n - 1) 0 [1..]) + (scanl (\acc n -> acc + 3 * n - 2) 1 [2..]) + where + interleave :: [a] -> [a] -> [a] + interleave (n : ns) (m : ms) = n : m : interleave ns ms + interleave _ _ = [] + +-- | When calculating the @n@-th partition number @p(n)@ using the sum +-- @p(n) = p(n-1) + p(n-2) - p(n-5) - p(n-7) + p(n-11) + ...@, the signs of each +-- term alternate every two terms, starting with a positive sign. +-- @pentagonalSigns@ takes a list of numbers and produces such an alternated +-- sequence. +-- Examples: +-- +-- >>> pentagonalSigns [1..5] +-- [1, 2, -3, -4, 5] +-- +-- >>> pentagonalSigns [1..6] +-- [1, 2, -3, -4, 5, 6] +pentagonalSigns :: Num a => [a] -> [a] +pentagonalSigns = zipWith (*) (cycle [1, 1, -1, -1]) + +-- [Implementation notes for partition function] +-- +-- @p(n) = p(n-1) + p(n-2) - p(n-5) - p(n-7) + p(n-11) + ...@, where @p(0) = 1@ +-- and @p(k) = 0@ for a negative integer @k@. Uses a @Map@ from the +-- @containers@ package to memoize previous results. +-- +-- Example: calculating @partition !! 10@, assuming the memoization map is +-- filled and called @dict :: Integral a => Map a a@. +-- +-- * @tail [0, 1, 2, 5, 7, 12 ,15, 22, 26, 35, ..] == [1, 2, 5, 7, 12 ,15, 22, 26, 35, 40, ..]@. +-- * @takeWhile (\m -> 10 - m >= 0) [1, 2, 5, 7, 12 ,15, 22, 26, 35, 40, ..] == [1, 2, 5, 7]@. +-- * @map (\m -> dict ! fromIntegral (10 - m)) [1, 2, 5, 7] == [dict ! 9, dict ! 8, dict ! 5, dict ! 3] == [30, 22, 7, 3]@ +-- * @pentagonalSigns [30, 22, 7, 3] == [30, 22, 7, 3] == [30, 22, -7, -3]@ +-- * @sum [30, 22, -7, -3] == 42@ +-- +-- Notes: +-- 1. @tail@ is applied to @pents@ because otherwise the calculation of +-- @p(n)@ would involve a duplicated @p(n-1)@ term (see the above example). +-- 2. Calculating @partition !! k@, where @k@ is any index equal or higher +-- than @maxBound :: Int@ results in undefined behavior. + +-- | Infinite zero-based table of . +-- +-- >>> take 10 partition +-- [1, 1, 2, 3, 5, 7, 11, 15, 22, 30] +-- +-- >>> :set -XDataKinds +-- >>> partition !! 1000 :: Mod 1000 +-- (991 `modulo` 1000) +partition :: Num a => [a] +partition = 1 : go (IM.singleton 0 1) 1 + where + go :: Num a => IM.IntMap a -> Int -> [a] + go dict !n = + let n' = (sum . + pentagonalSigns . + map (\m -> dict IM.! (n - m)) . + takeWhile (\m -> n >= m) . + tail) (pents :: [Int]) + dict' = IM.insert n n' dict + in n' : go dict' (n + 1) +{-# SPECIALIZE partition :: [Int] #-} +{-# SPECIALIZE partition :: [Word] #-} +{-# SPECIALIZE partition :: [Integer] #-} +{-# SPECIALIZE partition :: [Natural] #-} diff --git a/Math/NumberTheory/SmoothNumbers.hs b/Math/NumberTheory/SmoothNumbers.hs --- a/Math/NumberTheory/SmoothNumbers.hs +++ b/Math/NumberTheory/SmoothNumbers.hs @@ -12,6 +12,8 @@ -- over a set {3, 4}, and 24 is not. -- +{-# LANGUAGE ScopedTypeVariables #-} + module Math.NumberTheory.SmoothNumbers ( -- * Create a smooth basis SmoothBasis @@ -24,68 +26,77 @@ , smoothOverInRangeBF ) where -import Data.List (sort, nub) +import Prelude hiding (div, mod, gcd) +import Data.Coerce +import Data.List (nub) import qualified Data.Set as S +import Math.NumberTheory.Euclidean import Math.NumberTheory.Primes.Sieve (primes) -- | An abstract representation of a smooth basis. -- It consists of a set of coprime numbers ≥2. -newtype SmoothBasis a = SmoothBasis { unSmoothBasis :: [a] } deriving Show +newtype SmoothBasis a = SmoothBasis { unSmoothBasis :: [a] } deriving (Eq, Show) -- | Build a 'SmoothBasis' from a set of coprime numbers ≥2. -- --- > > fromSet (Set.fromList [2, 3]) --- > Just (SmoothBasis [2, 3]) --- > > fromSet (Set.fromList [2, 4]) -- should be coprime --- > Nothing --- > > fromSet (Set.fromList [1, 3]) -- should be >= 2 --- > Nothing -fromSet :: Integral a => S.Set a -> Maybe (SmoothBasis a) +-- >>> import qualified Data.Set as Set +-- >>> fromSet (Set.fromList [2, 3]) +-- Just (SmoothBasis [2, 3]) +-- >>> fromSet (Set.fromList [2, 4]) -- should be coprime +-- Nothing +-- >>> fromSet (Set.fromList [1, 3]) -- should be >= 2 +-- Nothing +fromSet :: Euclidean a => S.Set a -> Maybe (SmoothBasis a) fromSet s = if isValid l then Just (SmoothBasis l) else Nothing where l = S.elems s -- | Build a 'SmoothBasis' from a list of coprime numbers ≥2. -- --- > > fromList [2, 3] --- > Just (SmoothBasis [2, 3]) --- > > fromList [2, 2] --- > Just (SmoothBasis [2]) --- > > fromList [2, 4] -- should be coprime --- > Nothing --- > > fromList [1, 3] -- should be >= 2 --- > Nothing -fromList :: Integral a => [a] -> Maybe (SmoothBasis a) -fromList l = if isValid l' then Just (SmoothBasis l') else Nothing where l' = nub $ sort l +-- >>> fromList [2, 3] +-- Just (SmoothBasis [2, 3]) +-- >>> fromList [2, 2] +-- Just (SmoothBasis [2]) +-- >>> fromList [2, 4] -- should be coprime +-- Nothing +-- >>> fromList [1, 3] -- should be >= 2 +-- Nothing +fromList :: Euclidean a => [a] -> Maybe (SmoothBasis a) +fromList l = if isValid l' then Just (SmoothBasis l') else Nothing + where + l' = nub l -- | Build a 'SmoothBasis' from a list of primes below given bound. -- --- > > fromSmoothUpperBound 10 --- > Just (SmoothBasis [2, 3, 5, 7]) --- > > fromSmoothUpperBound 1 --- > Nothing +-- >>> fromSmoothUpperBound 10 +-- Just (SmoothBasis [2, 3, 5, 7]) +-- >>> fromSmoothUpperBound 1 +-- Nothing fromSmoothUpperBound :: Integral a => a -> Maybe (SmoothBasis a) fromSmoothUpperBound n = if (n < 2) then Nothing - else Just $ SmoothBasis $ map fromInteger $ takeWhile (<= nI) primes - where nI = toInteger n + else Just $ SmoothBasis $ takeWhile (<= n) primes -- | Generate an infinite ascending list of -- -- over a given smooth basis. -- --- > > take 10 (smoothOver (fromJust (fromList [2, 5]))) --- > [1, 2, 4, 5, 8, 10, 16, 20, 25, 32] +-- >>> import Data.Maybe +-- >>> take 10 (smoothOver (fromJust (fromList [2, 5]))) +-- [1, 2, 4, 5, 8, 10, 16, 20, 25, 32] smoothOver :: Integral a => SmoothBasis a -> [a] smoothOver pl = foldr (\p l -> mergeListLists $ iterate (map (p*)) l) [1] (unSmoothBasis pl) - where - {-# INLINE mergeListLists #-} - mergeListLists = foldr go1 [] - where go1 (h:t) b = h:(go2 t b) - go1 _ b = b + where + {-# INLINE mergeListLists #-} + mergeListLists = foldr go1 [] + where + go1 :: Ord a => [a] -> [a] -> [a] + go1 (h:t) b = h:(go2 t b) + go1 _ b = b - go2 a@(ah:at) b@(bh:bt) - | bh < ah = bh : (go2 a bt) - | otherwise = ah : (go2 at b) -- no possibility of duplicates - go2 a b = if null a then b else a + go2 :: Ord a => [a] -> [a] -> [a] + go2 a@(ah:at) b@(bh:bt) + | bh < ah = bh : (go2 a bt) + | otherwise = ah : (go2 at b) -- no possibility of duplicates + go2 a b = if null a then b else a -- | Generate an ascending list of -- @@ -95,10 +106,15 @@ -- for short, but distant ranges; -- consider using 'smoothOverInRangeBF' in such cases. -- --- > > smoothOverInRange (fromJust (fromList [2, 5])) 100 200 --- > [100, 125, 128, 160, 200] -smoothOverInRange :: Integral a => SmoothBasis a -> a -> a -> [a] -smoothOverInRange s lo hi = takeWhile (<= hi) $ dropWhile (< lo) (smoothOver s) +-- >>> import Data.Maybe +-- >>> smoothOverInRange (fromJust (fromList [2, 5])) 100 200 +-- [100, 125, 128, 160, 200] +smoothOverInRange :: forall a. Integral a => SmoothBasis a -> a -> a -> [a] +smoothOverInRange s lo hi + = takeWhile (<= hi) + $ dropWhile (< lo) + $ coerce + $ smoothOver (coerce s :: SmoothBasis (WrappedIntegral a)) -- | Generate an ascending list of -- @@ -110,21 +126,27 @@ -- -- Suffix BF stands for the brute force algorithm, involving a lot of divisions. -- --- > > smoothOverInRangeBF (fromJust (fromList [2, 5])) 100 200 --- > [100, 125, 128, 160, 200] -smoothOverInRangeBF :: Integral a => SmoothBasis a -> a -> a -> [a] -smoothOverInRangeBF prs lo hi = filter (mf prs') [lo..hi] - where mf [] n = (n == 1) -- mf means manually factor - mf pl@(p:ps) n = if (mod n p == 0) - then mf pl (div n p) - else mf ps n - prs' = unSmoothBasis prs +-- >>> import Data.Maybe +-- >>> smoothOverInRangeBF (fromJust (fromList [2, 5])) 100 200 +-- [100, 125, 128, 160, 200] +smoothOverInRangeBF :: forall a. Integral a => SmoothBasis a -> a -> a -> [a] +smoothOverInRangeBF prs lo hi + = coerce + $ filter (mf prs') + $ coerce [lo..hi] + where + mf :: [WrappedIntegral a] -> WrappedIntegral a -> Bool + mf _ 0 = False + mf [] n = n == 1 -- mf means manually factor + mf pl@(p:ps) n = if mod n p == 0 + then mf pl (div n p) + else mf ps n + prs' = coerce $ unSmoothBasis prs -- | isValid assumes that the list is sorted and unique and then checks if the list is suitable to be a SmoothBasis. -isValid :: (Integral a) => [a] -> Bool -isValid pl = if (length pl == 0) then False else v' pl - where v' [] = True - v' (x:xs) = if (x < 2 || (not $ rpl x xs)) then False else v' xs - rpl _ [] = True -- rpl means relatively prime to the rest of the list - rpl n (x:xs) = if (gcd n x > 1) then False else rpl n xs - +isValid :: Euclidean a => [a] -> Bool +isValid pl = length pl /= 0 && v' pl + where + v' :: Euclidean a => [a] -> Bool + v' [] = True + v' (x:xs) = x /= 0 && abs x /= 1 && abs x == x && all (coprime x) xs && v' xs diff --git a/Math/NumberTheory/UniqueFactorisation.hs b/Math/NumberTheory/UniqueFactorisation.hs --- a/Math/NumberTheory/UniqueFactorisation.hs +++ b/Math/NumberTheory/UniqueFactorisation.hs @@ -9,8 +9,9 @@ -- An abstract type class for unique factorisation domains. -- -{-# LANGUAGE CPP #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DefaultSignatures #-} module Math.NumberTheory.UniqueFactorisation ( Prime @@ -20,15 +21,11 @@ import Control.Arrow import Data.Coerce -#if MIN_VERSION_base(4,8,0) -#else -import Data.Word -#endif - -import Math.NumberTheory.Primes.Factorisation as F (factorise') +import qualified Math.NumberTheory.Primes.Factorisation as F (factorise) import Math.NumberTheory.Primes.Testing.Probabilistic as T (isPrime) import Math.NumberTheory.Primes.Types (Prime, Prm(..), PrimeNat(..)) -import qualified Math.NumberTheory.GaussianIntegers as G +import qualified Math.NumberTheory.Quadratic.EisensteinIntegers as E +import qualified Math.NumberTheory.Quadratic.GaussianIntegers as G import Math.NumberTheory.Utils.FromIntegral import Numeric.Natural @@ -43,8 +40,10 @@ class UniqueFactorisation a where unPrime :: Prime a -> a factorise :: a -> [(Prime a, Word)] - isPrime :: a -> Maybe (Prime a) + + default isPrime :: (Eq a, Num a) => a -> Maybe (Prime a) + isPrime 0 = Nothing isPrime n = case factorise n of [(p, 1)] -> Just p _ -> Nothing @@ -53,34 +52,21 @@ instance UniqueFactorisation Int where unPrime = coerce wordToInt - factorise m' = if m <= 1 - then [] - else map (coerce integerToWord *** intToWord) . F.factorise' . intToInteger $ m - where - m = abs m' - isPrime n = if T.isPrime (toInteger n) then Just (coerce $ intToWord $ abs n) else Nothing + factorise = map (coerce integerToWord *** intToWord) . F.factorise . intToInteger instance UniqueFactorisation Word where - unPrime = coerce - factorise m = if m <= 1 - then [] - else map (coerce integerToWord *** intToWord) . F.factorise' . wordToInteger $ m + unPrime = coerce + factorise = map (coerce integerToWord *** intToWord) . F.factorise . wordToInteger isPrime n = if T.isPrime (toInteger n) then Just (coerce n) else Nothing instance UniqueFactorisation Integer where - unPrime = coerce naturalToInteger - factorise m' = if m <= 1 - then [] - else map (coerce integerToNatural *** intToWord) . F.factorise' $ m - where - m = abs m' + unPrime = coerce naturalToInteger + factorise = map (coerce integerToNatural *** intToWord) . F.factorise isPrime n = if T.isPrime n then Just (coerce $ integerToNatural $ abs n) else Nothing instance UniqueFactorisation Natural where unPrime = coerce - factorise m = if m <= 1 - then [] - else map (coerce integerToNatural *** intToWord) . F.factorise' . naturalToInteger $ m + factorise = map (coerce integerToNatural *** intToWord) . F.factorise . naturalToInteger isPrime n = if T.isPrime (toInteger n) then Just (coerce n) else Nothing newtype GaussianPrime = GaussianPrime { _unGaussianPrime :: G.GaussianInteger } @@ -90,4 +76,15 @@ unPrime = coerce factorise 0 = [] - factorise g = map (coerce *** intToWord) $ filter (\(h, _) -> abs h /= 1) $ G.factorise g + factorise g = map (coerce *** intToWord) $ G.factorise g + +newtype EisensteinPrime = EisensteinPrime { _unEisensteinPrime :: E.EisensteinInteger } + deriving (Eq, Show) + +type instance Prime E.EisensteinInteger = EisensteinPrime + +instance UniqueFactorisation E.EisensteinInteger where + unPrime = coerce + + factorise 0 = [] + factorise e = map (coerce *** intToWord) $ E.factorise e diff --git a/Math/NumberTheory/Utils.hs b/Math/NumberTheory/Utils.hs --- a/Math/NumberTheory/Utils.hs +++ b/Math/NumberTheory/Utils.hs @@ -6,7 +6,7 @@ -- Stability: Provisional -- Portability: Non-portable (GHC extensions) -- --- Some utilities for bit twiddling. +-- Some utilities, mostly for bit twiddling. -- {-# LANGUAGE CPP, MagicHash, UnboxedTuples, BangPatterns #-} {-# OPTIONS_HADDOCK hide #-} @@ -21,6 +21,10 @@ , uncheckedShiftR , splitOff , splitOff# + + , mergeBy + + , recipMod ) where #include "MachDeps.h" @@ -29,23 +33,10 @@ import GHC.Integer import GHC.Integer.GMP.Internals +import GHC.Natural import Data.Bits -#if WORD_SIZE_IN_BITS == 64 -#define m5 0x5555555555555555 -#define m3 0x3333333333333333 -#define mf 0x0F0F0F0F0F0F0F0F -#define m1 0x0101010101010101 -#define sd 56 -#else -#define m5 0x55555555 -#define m3 0x33333333 -#define mf 0x0F0F0F0F -#define m1 0x01010101 -#define sd 24 -#endif - uncheckedShiftR :: Word -> Int -> Word uncheckedShiftR (W# w#) (I# i#) = W# (uncheckedShiftRL# w# i#) @@ -56,6 +47,7 @@ "shiftToOddCount/Int" shiftToOddCount = shiftOCInt "shiftToOddCount/Word" shiftToOddCount = shiftOCWord "shiftToOddCount/Integer" shiftToOddCount = shiftOCInteger +"shiftToOddCount/Natural" shiftToOddCount = shiftOCNatural #-} {-# INLINE [1] shiftToOddCount #-} shiftToOddCount :: Integral a => a -> (Int, a) @@ -82,25 +74,25 @@ (# z#, w# #) | isTrue# (z# ==# 0#) -> (0, n) | otherwise -> (I# z#, S# (word2Int# w#)) -#if __GLASGOW_HASKELL__ < 709 -shiftOCInteger n@(J# _ ba#) = case count 0# 0# of -#else shiftOCInteger n@(Jp# bn#) = case bigNatZeroCount bn# of 0# -> (0, n) z# -> (I# z#, n `shiftRInteger` z#) shiftOCInteger n@(Jn# bn#) = case bigNatZeroCount bn# of -#endif 0# -> (0, n) z# -> (I# z#, n `shiftRInteger` z#) -#if __GLASGOW_HASKELL__ < 709 - where - count a# i# = - case indexWordArray# ba# i# of - 0## -> count (a# +# WORD_SIZE_IN_BITS#) (i# +# 1#) - w# -> a# +# trailZeros# w# -#endif -#if __GLASGOW_HASKELL__ >= 709 +-- | Specialised version for @'Natural'@. +-- Precondition: argument nonzero (not checked). +shiftOCNatural :: Natural -> (Int, Natural) +shiftOCNatural n@(NatS# i#) = + case shiftToOddCount# i# of + (# z#, w# #) + | isTrue# (z# ==# 0#) -> (0, n) + | otherwise -> (I# z#, NatS# w#) +shiftOCNatural n@(NatJ# bn#) = case bigNatZeroCount bn# of + 0# -> (0, n) + z# -> (I# z#, NatJ# (bn# `shiftRBigNat` z#)) + -- | Count trailing zeros in a @'BigNat'@. -- Precondition: argument nonzero (not checked, Integer invariant). bigNatZeroCount :: BigNat -> Int# @@ -109,8 +101,7 @@ count a# i# = case indexBigNat# bn# i# of 0## -> count (a# +# WORD_SIZE_IN_BITS#) (i# +# 1#) - w# -> a# +# trailZeros# w# -#endif + w# -> a# +# word2Int# (ctz# w#) -- | Remove factors of @2@. If @n = 2^k*m@ with @m@ odd, the result is @m@. -- Precondition: argument not @0@ (not checked). @@ -137,33 +128,21 @@ -- Precondition: argument nonzero (not checked). shiftOInteger :: Integer -> Integer shiftOInteger (S# i#) = S# (word2Int# (shiftToOdd# (int2Word# i#))) -#if __GLASGOW_HASKELL__ < 709 -shiftOInteger n@(J# _ ba#) = case count 0# 0# of -#else shiftOInteger n@(Jn# bn#) = case bigNatZeroCount bn# of 0# -> n z# -> n `shiftRInteger` z# shiftOInteger n@(Jp# bn#) = case bigNatZeroCount bn# of -#endif 0# -> n z# -> n `shiftRInteger` z# -#if __GLASGOW_HASKELL__ < 709 - where - count a# i# = - case indexWordArray# ba# i# of - 0## -> count (a# +# WORD_SIZE_IN_BITS#) (i# +# 1#) - w# -> a# +# trailZeros# w# -#endif -- | Shift argument right until the result is odd. -- Precondition: argument not @0@, not checked. shiftToOdd# :: Word# -> Word# -shiftToOdd# w# = case trailZeros# w# of - k# -> uncheckedShiftRL# w# k# +shiftToOdd# w# = uncheckedShiftRL# w# (word2Int# (ctz# w#)) -- | Like @'shiftToOdd#'@, but count the number of places to shift too. shiftToOddCount# :: Word# -> (# Int#, Word# #) -shiftToOddCount# w# = case trailZeros# w# of +shiftToOddCount# w# = case word2Int# (ctz# w#) of k# -> (# k#, uncheckedShiftRL# w# k# #) -- | Number of 1-bits in a @'Word#'@. @@ -179,20 +158,7 @@ bitCountInt :: Int -> Int bitCountInt = popCount --- | Number of trailing zeros in a @'Word#'@, wrong for @0@. -{-# INLINE trailZeros# #-} -trailZeros# :: Word# -> Int# -trailZeros# w = - case xor# w (w `minusWord#` 1##) `uncheckedShiftRL#` 1# of - v0 -> - case v0 `minusWord#` (uncheckedShiftRL# v0 1# `and#` m5##) of - v1 -> - case (v1 `and#` m3##) `plusWord#` (uncheckedShiftRL# v1 2# `and#` m3##) of - v2 -> - case (v2 `plusWord#` uncheckedShiftRL# v2 4#) `and#` mf## of - v3 -> word2Int# (uncheckedShiftRL# (v3 `timesWord#` m1##) sd#) - -splitOff :: Integer -> Integer -> (Int, Integer) +splitOff :: Integral a => a -> a -> (Int, a) splitOff _ 0 = (0, 0) -- prevent infinite loop splitOff p n = go 0 n where @@ -211,3 +177,21 @@ (# q, 0## #) -> go (k +# 1#) q _ -> (# k, m #) {-# INLINABLE splitOff# #-} + +-- | Merges two ordered lists into an ordered list. Checks for neither its +-- precondition or postcondition. +mergeBy :: (a -> a -> Ordering) -> [a] -> [a] -> [a] +mergeBy cmp = loop + where + loop [] ys = ys + loop xs [] = xs + loop (x:xs) (y:ys) + = case cmp x y of + GT -> y : loop (x:xs) ys + _ -> x : loop xs (y:ys) + +-- | Work around https://ghc.haskell.org/trac/ghc/ticket/14085 +recipMod :: Integer -> Integer -> Maybe Integer +recipMod x m = case recipModInteger (x `mod` m) m of + 0 -> Nothing + y -> Just y diff --git a/Math/NumberTheory/Utils/FromIntegral.hs b/Math/NumberTheory/Utils/FromIntegral.hs --- a/Math/NumberTheory/Utils/FromIntegral.hs +++ b/Math/NumberTheory/Utils/FromIntegral.hs @@ -22,9 +22,6 @@ ) where import Numeric.Natural -#if __GLASGOW_HASKELL__ < 709 -import Data.Word -#endif wordToInt :: Word -> Int wordToInt = fromIntegral diff --git a/Math/NumberTheory/Zeta.hs b/Math/NumberTheory/Zeta.hs --- a/Math/NumberTheory/Zeta.hs +++ b/Math/NumberTheory/Zeta.hs @@ -1,115 +1,21 @@ -- | -- Module: Math.NumberTheory.Zeta --- Copyright: (c) 2016 Andrew Lelechenko +-- Copyright: (c) 2018 Andrew Lelechenko -- Licence: MIT -- Maintainer: Andrew Lelechenko -- Stability: Provisional -- Portability: Non-portable (GHC extensions) -- --- Riemann zeta-function. +-- Interface to work with Riemann zeta-function and Dirichlet beta-function. {-# LANGUAGE ScopedTypeVariables #-} module Math.NumberTheory.Zeta - ( zetas - , zetasEven - , approximateValue + ( module Math.NumberTheory.Zeta.Dirichlet + , module Math.NumberTheory.Zeta.Riemann + , module Math.NumberTheory.Zeta.Utils ) where -import Data.ExactPi -import Data.Ratio - -import Math.NumberTheory.Recurrencies.Bilinear (bernoulli) -import Math.NumberTheory.Recurrencies.Linear (factorial) - --- | Infinite sequence of exact values of Riemann zeta-function at even arguments, starting with @ζ(0)@. --- Note that due to numerical errors convertation to 'Double' may return values below 1: --- --- > > approximateValue (zetasEven !! 25) :: Double --- > 0.9999999999999996 --- --- Use your favorite type for long-precision arithmetic. For instance, 'Data.Number.Fixed.Fixed' works fine: --- --- > > approximateValue (zetasEven !! 25) :: Fixed Prec50 --- > 1.00000000000000088817842111574532859293035196051773 --- -zetasEven :: [ExactPi] -zetasEven = zipWith Exact [0, 2 ..] $ zipWith (*) (skipOdds bernoulli) cs - where - cs = (- 1 % 2) : zipWith (\i f -> i * (-4) / fromInteger (2 * f * (2 * f - 1))) cs [1..] - -skipOdds :: [a] -> [a] -skipOdds (x : _ : xs) = x : skipOdds xs -skipOdds xs = xs - -zetasEven' :: Floating a => [a] -zetasEven' = map approximateValue zetasEven - -zetasOdd :: forall a. (Floating a, Ord a) => a -> [a] -zetasOdd eps = (1 / 0) : zets - where - zets :: [a] -- [zeta(3), zeta(5), zeta(7)...] - zets = zipWith (*) zs (tail (iterate (* (- pi * pi)) 1)) - - zs :: [a] -- [zeta(3) / (-pi^2), zeta(5) / pi^4, zeta(7) / (-pi^6)...] - zs = zipWith (\w f -> negate (w / (1 + f))) ws fourth - - ys :: [a] -- [(1 - 1/4) * zeta(3) / (-pi^2), (1 - 1/4^2) * zeta(5) / pi^4...] - ys = zipWith (*) zs fourth - yss :: [[a]] -- [[], [ys !! 0], [ys !! 1, ys !! 0], [ys !! 2, ys !! 1, ys !! 0]...] - yss = scanl (flip (:)) [] ys - - xs :: [a] -- first summand of RHS in (57) for m=[1..] - xs = map (sum . zipWith (flip (/)) factorial2) yss - - ws :: [a] -- RHS in (57) for m=[1..] - ws = zipWith (+) xs cs - - rs :: [a] -- [1, 1/2, 1/3, 1/4...] - rs = map (\n -> recip (fromInteger n)) [1..] - rss :: [[a]] -- [[1, 1/2, 1/3...], [1/2, 1/3, 1/4...], [1/3, 1/4...]] - rss = iterate tail rs - - factorial2 :: [a] -- [2!, 4!, 6!..] - factorial2 = map fromInteger $ tail $ skipOdds factorial - - fourth :: [a] -- [1 - 1/4, 1 - 1/4^2, 1 - 1/4^3...] - fourth = tail $ map (1 -) $ iterate (/ 4) 1 - - as :: [a] -- [zeta(0), zeta(2)/4, zeta(2*2)/4^2, zeta(2*3)/4^3...] - as = zipWith (/) zetasEven' (iterate (* 4) 1) - - bs :: [a] -- map (+ log 2) [b(1), b(2), b(3)...], - -- where b(m) = \sum_{n=0}^\infty zeta(2n) / 4^n / (n + m) - bs = map ((+ log 2) . suminf eps . zipWith (*) as) rss - - cs :: [a] -- second summand of RHS in (57) for m = [1..] - cs = zipWith (\b f -> b / f) bs factorial2 - -suminf :: (Floating a, Ord a) => a -> [a] -> a -suminf eps = sum . takeWhile ((>= eps / 111) . abs) - --- | Infinite sequence of approximate (up to given precision) --- values of Riemann zeta-function at integer arguments, starting with @ζ(0)@. --- Computations for odd arguments are performed in accordance to --- --- by J. M. Borwein, D. M. Bradley, R. E. Crandall, formula (57). --- --- > > take 5 (zetas 1e-14) :: [Double] --- > [-0.5,Infinity,1.6449340668482262,1.2020569031595942,1.0823232337111381] --- --- Beware to force evaluation of @zetas !! 1@, if the type @a@ does not support infinite values --- (for instance, 'Data.Number.Fixed.Fixed'). --- -zetas :: (Floating a, Ord a) => a -> [a] -zetas eps = e : o : scanl1 f (intertwine es os) - where - e : es = zetasEven' - o : os = zetasOdd eps - - intertwine (x : xs) (y : ys) = x : y : intertwine xs ys - intertwine xs ys = xs ++ ys - - -- Cap-and-floor to improve numerical stability: - -- 0 < zeta(n + 1) - 1 < (zeta(n) - 1) / 2 - f x y = 1 `max` (y `min` (1 + (x - 1) / 2)) +import Math.NumberTheory.Zeta.Dirichlet +import Math.NumberTheory.Zeta.Riemann +import Math.NumberTheory.Zeta.Utils diff --git a/Math/NumberTheory/Zeta/Dirichlet.hs b/Math/NumberTheory/Zeta/Dirichlet.hs new file mode 100644 --- /dev/null +++ b/Math/NumberTheory/Zeta/Dirichlet.hs @@ -0,0 +1,171 @@ +-- | +-- Module: Math.NumberTheory.Zeta.Dirichlet +-- Copyright: (c) 2018 Alexandre Rodrigues Baldé +-- Licence: MIT +-- Maintainer: Alexandre Rodrigues Baldé +-- Stability: Provisional +-- Portability: Non-portable (GHC extensions) +-- +-- Dirichlet beta-function. + +{-# LANGUAGE ScopedTypeVariables #-} + +module Math.NumberTheory.Zeta.Dirichlet + ( betas + , betasEven + , betasOdd + ) where + +import Data.ExactPi (ExactPi (..), approximateValue) +import Data.List (zipWith4) +import Data.Ratio ((%)) + +import Math.NumberTheory.Recurrencies (euler, eulerPolyAt1, factorial) +import Math.NumberTheory.Zeta.Riemann (zetasOdd) +import Math.NumberTheory.Zeta.Utils (intertwine, skipEvens, skipOdds, + suminf) + +-- | Infinite sequence of exact values of Dirichlet beta-function at odd arguments, starting with @β(1)@. +-- +-- > > approximateValue (betasOdd !! 25) :: Double +-- > 0.9999999999999987 +-- +-- Using 'Data.Number.Fixed.Fixed': +-- +-- > > approximateValue (betasOdd !! 25) :: Fixed Prec50 +-- > 0.99999999999999999999999960726927497384196726751694z +-- +betasOdd :: [ExactPi] +betasOdd = zipWith Exact [1, 3 ..] $ zipWith4 + (\sgn denom eul twos -> sgn * (eul % (twos * denom))) + (cycle [1, -1]) + (skipOdds factorial) + (skipOdds euler) + (iterate (4 *) 4) + +-- | @betasOdd@, but with @forall a . Floating a => a@ instead of @ExactPi@s. +-- Used in @betasEven@. +betasOdd' :: Floating a => [a] +betasOdd' = map approximateValue betasOdd + +-- | Infinite sequence of approximate values of the Dirichlet @β@ function at +-- positive even integer arguments, starting with @β(0)@. +betasEven :: forall a. (Floating a, Ord a) => a -> [a] +betasEven eps = (1 / 2) : bets + where + bets :: [a] + bets = zipWith3 (\r1 r2 r3 -> (r1 + (negate r2) + r3)) rhs1 rhs2 rhs3 + + -- [1!, 3!, 5!..] + factorial1AsInteger :: [Integer] + factorial1AsInteger = skipEvens factorial + + -- [1!, 3!, 5!..] + factorial1 :: [a] + factorial1 = map fromInteger factorial1AsInteger + + -- [2^1 * 1!, 2^3 * 3!, 2^5 * 5!, 2^7 * 7! ..] + denoms :: [a] + denoms = zipWith + (\pow fac -> fromInteger $ pow * fac) + factorial1AsInteger + (iterate (4 *) 2) + + -- First term of the right hand side of (12). + rhs1 = zipWith + (\sgn piFrac -> sgn * piFrac * log 2) + (cycle [1, -1]) + (zipWith (\p f -> p / f) (iterate ((pi * pi) *) pi) denoms) + + -- [1 - (1 / (2^2)), 1 - (1 / (2^4)), 1 - (1 / (2^6)), ..] + second :: [a] + second = map (1 -) $ (iterate (/ 4) (1/4)) + + -- [- (1 - (1 / (2^2))) * zeta(3), (1 - (1 / (2^4))) * zeta(5), - (1 - (1 / (2^6))) * zeta(7), ..] + zets :: [a] + zets = zipWith3 + (\sgn twosFrac z -> sgn * twosFrac * z) + (cycle [-1, 1]) + second + (tail $ zetasOdd eps) + + -- [pi / (2^1 * 1!), pi^3 / (2^3 * 3!), pi^5 / (2^5 * 5!), ..] + pisAndFacs :: [a] + pisAndFacs = zipWith3 + (\p pow fac -> p / (pow * fac)) + (iterate ((pi * pi) *) pi) + (iterate (4 *) 2) + factorial1 + + -- [[], [pisAndFacs !! 0], [pisAndFacs !! 1, pisAndFacs !! 0], [pisAndFacs !! 2, pisAndFacs !! 1, pisAndFacs !! 0]...] + pisAndFacs' :: [[a]] + pisAndFacs' = scanl (flip (:)) [] pisAndFacs + + -- Second summand of RHS in (12) for k = [1 ..] + rhs2 :: [a] + rhs2 = zipWith (*) (cycle [-1, 1]) $ map (sum . zipWith (*) zets) pisAndFacs' + + -- [pi^3 / (2^4), pi^5 / (2^6), pi^7 / (2^8) ..] + -- Second factor of third addend in RHS of (12). + pis :: [a] + pis = zipWith + (\p f -> p / f) + (iterate ((pi * pi) *) (pi ^^ (3 :: Integer))) + (iterate (4 *) 16) + + -- [[3!, 5!, 7! ..], [5!, 7! ..] ..] + oddFacs :: [[a]] + oddFacs = iterate tail (tail factorial1) + + -- [1, 4, 16 ..] + fours :: [a] + fours = iterate (4 *) 1 + + -- [[3! * 2^0, 5! * 2^2, 7! * 2^4 ..], [5! * 2^0, 7! * 2^2, 9! * 2^4 ..] ..] + infSumDenoms :: [[a]] + infSumDenoms = map (zipWith (*) fours) oddFacs + + -- [pi^0, pi^2, pi^4, pi^6 ..] + pis2 :: [a] + pis2 = iterate ((pi * pi) *) 1 + + -- [pi^0 * E_1(1), - pi^2 * E_3(1), pi^4 * E_5(1) ..] + infSumNum :: [a] + infSumNum = zipWith3 + (\sgn p eulerP -> sgn * p * eulerP) + (cycle [1, -1]) + pis2 + (map fromRational . skipEvens $ eulerPolyAt1) + + -- [ [ pi^0 * E_1(1) (-1) * pi^2 * E_3(1) ] [ (-1) * pi^2 * E_3(1) pi^4 * E_5(1) ] [ pi^4 * E_5(1) (-1) * pi^6 * E_7(1) ] ] + -- | sum | -------------, -------------------- ..|, sum | --------------------, ------------- .. |, sum | -------------, -------------------- .. |..| + -- [ [ 3! 5! ] [ 5! 7! ] [ 7! 9! ] ] + infSum :: [a] + infSum = map (suminf eps . zipWith (/) infSumNum) infSumDenoms + + -- Third summand of the right hand side of (12). + rhs3 :: [a] + rhs3 = zipWith3 + (\sgn p inf -> sgn * p * inf) + (cycle [-1, 1]) + pis + infSum + +-- | Infinite sequence of approximate (up to given precision) +-- values of Dirichlet beta-function at integer arguments, starting with @β(0)@. +-- The algorithm used to compute @β@ for even arguments was derived from +-- +-- by F. M. S. Lima, formula (12). +-- +-- > > take 5 (betas 1e-14) :: [Double] +-- > [0.5,0.7853981633974483,0.9159655941772191,0.9689461462593693,0.988944551741105] +betas :: (Floating a, Ord a) => a -> [a] +betas eps = e : o : scanl1 f (intertwine es os) + where + e : es = betasEven eps + o : os = betasOdd' + + -- Cap-and-floor to improve numerical stability: + -- 1 > beta(n + 1) - 1 > (beta(n) - 1) / 2 + -- A similar method is used in @Math.NumberTheory.Zeta.Riemann.zetas@. + f x y = 1 `min` (y `max` (1 + (x - 1) / 2)) diff --git a/Math/NumberTheory/Zeta/Riemann.hs b/Math/NumberTheory/Zeta/Riemann.hs new file mode 100644 --- /dev/null +++ b/Math/NumberTheory/Zeta/Riemann.hs @@ -0,0 +1,106 @@ +-- | +-- Module: Math.NumberTheory.Zeta.Riemann +-- Copyright: (c) 2016 Andrew Lelechenko +-- Licence: MIT +-- Maintainer: Andrew Lelechenko +-- Stability: Provisional +-- Portability: Non-portable (GHC extensions) +-- +-- Riemann zeta-function. + +{-# LANGUAGE ScopedTypeVariables #-} + +module Math.NumberTheory.Zeta.Riemann + ( zetas + , zetasEven + , zetasOdd + ) where + +import Data.ExactPi (ExactPi (..), approximateValue) +import Data.Ratio ((%)) + +import Math.NumberTheory.Recurrencies (bernoulli, factorial) +import Math.NumberTheory.Zeta.Utils (intertwine, skipOdds, suminf) + +-- | Infinite sequence of exact values of Riemann zeta-function at even arguments, starting with @ζ(0)@. +-- Note that due to numerical errors conversion to 'Double' may return values below 1: +-- +-- >>> approximateValue (zetasEven !! 25) :: Double +-- 0.9999999999999996 +-- +-- Use your favorite type for long-precision arithmetic. For instance, 'Data.Number.Fixed.Fixed' works fine: +-- +-- >>> import Data.Number.Fixed +-- >>> approximateValue (zetasEven !! 25) :: Fixed Prec50 +-- 1.00000000000000088817842111574532859293035196051773 +-- +zetasEven :: [ExactPi] +zetasEven = zipWith Exact [0, 2 ..] $ zipWith (*) (skipOdds bernoulli) cs + where + cs = (- 1 % 2) : zipWith (\i f -> i * (-4) / fromInteger (2 * f * (2 * f - 1))) cs [1..] + +zetasEven' :: Floating a => [a] +zetasEven' = map approximateValue zetasEven + +zetasOdd :: forall a. (Floating a, Ord a) => a -> [a] +zetasOdd eps = (1 / 0) : zets + where + zets :: [a] -- [zeta(3), zeta(5), zeta(7)...] + zets = zipWith (*) zs (tail (iterate (* (- pi * pi)) 1)) + + zs :: [a] -- [zeta(3) / (-pi^2), zeta(5) / pi^4, zeta(7) / (-pi^6)...] + zs = zipWith (\w f -> negate (w / (1 + f))) ws fourth + + ys :: [a] -- [(1 - 1/4) * zeta(3) / (-pi^2), (1 - 1/4^2) * zeta(5) / pi^4...] + ys = zipWith (*) zs fourth + yss :: [[a]] -- [[], [ys !! 0], [ys !! 1, ys !! 0], [ys !! 2, ys !! 1, ys !! 0]...] + yss = scanl (flip (:)) [] ys + + xs :: [a] -- first summand of RHS in (57) for m=[1..] + xs = map (sum . zipWith (flip (/)) factorial2) yss + + ws :: [a] -- RHS in (57) for m=[1..] + ws = zipWith (+) xs cs + + rs :: [a] -- [1, 1/2, 1/3, 1/4...] + rs = map (\n -> recip (fromInteger n)) [1..] + rss :: [[a]] -- [[1, 1/2, 1/3...], [1/2, 1/3, 1/4...], [1/3, 1/4...]] + rss = iterate tail rs + + factorial2 :: [a] -- [2!, 4!, 6!..] + factorial2 = map fromInteger $ tail $ skipOdds factorial + + fourth :: [a] -- [1 - 1/4, 1 - 1/4^2, 1 - 1/4^3...] + fourth = tail $ map (1 -) $ iterate (/ 4) 1 + + as :: [a] -- [zeta(0), zeta(2)/4, zeta(2*2)/4^2, zeta(2*3)/4^3...] + as = zipWith (/) zetasEven' (iterate (* 4) 1) + + bs :: [a] -- map (+ log 2) [b(1), b(2), b(3)...], + -- where b(m) = \sum_{n=0}^\infty (zeta(2n) / 4^n) / (n + m) + bs = map ((+ log 2) . suminf eps . zipWith (*) as) rss + + cs :: [a] -- second summand of RHS in (57) for m = [1..] + cs = zipWith (\b f -> b / f) bs factorial2 + +-- | Infinite sequence of approximate (up to given precision) +-- values of Riemann zeta-function at integer arguments, starting with @ζ(0)@. +-- Computations for odd arguments are performed in accordance to +-- +-- by J. M. Borwein, D. M. Bradley, R. E. Crandall, formula (57). +-- +-- >>> take 5 (zetas 1e-14) :: [Double] +-- > [-0.5,Infinity,1.6449340668482262,1.2020569031595942,1.0823232337111381] +-- +-- Beware to force evaluation of @zetas !! 1@, if the type @a@ does not support infinite values +-- (for instance, 'Data.Number.Fixed.Fixed'). +-- +zetas :: (Floating a, Ord a) => a -> [a] +zetas eps = e : o : scanl1 f (intertwine es os) + where + e : es = zetasEven' + o : os = zetasOdd eps + + -- Cap-and-floor to improve numerical stability: + -- 0 < zeta(n + 1) - 1 < (zeta(n) - 1) / 2 + f x y = 1 `max` (y `min` (1 + (x - 1) / 2)) diff --git a/Math/NumberTheory/Zeta/Utils.hs b/Math/NumberTheory/Zeta/Utils.hs new file mode 100644 --- /dev/null +++ b/Math/NumberTheory/Zeta/Utils.hs @@ -0,0 +1,51 @@ +-- | +-- Module: Math.NumberTheory.Zeta.Utils +-- Copyright: (c) 2018 Alexandre Rodrigues Baldé +-- Licence: MIT +-- Maintainer: Alexandre Rodrigues Baldé +-- Stability: Provisional +-- Portability: Non-portable (GHC extensions) +-- +-- Shared utilities used by functions from @Math.NumberTheory.Zeta@. + +module Math.NumberTheory.Zeta.Utils + ( intertwine + , skipEvens + , skipOdds + , suminf + ) where + +-- | Joins two lists element-by-element together into one, starting with the +-- first one provided as argument. +-- +-- >>> take 10 $ intertwine [0, 2 ..] [1, 3 ..] +-- [0, 1, 2, 3, 4, 5, 6, 7, 8, 9] +intertwine :: [a] -> [a] -> [a] +intertwine [] ys = ys +intertwine (x : xs) ys = x : intertwine ys xs + +-- | Skips every odd-indexed element from an infinite list. +-- Do NOT use with finite lists. +-- +-- >>> take 10 (skipOdds [0, 1 ..]) +-- [0, 2, 4, 6, 8, 10, 12, 14, 16, 18] +skipOdds :: [a] -> [a] +skipOdds (x : _ : xs) = x : skipOdds xs +skipOdds xs = xs + +-- | Skips every even-indexed element from an infinite list. +-- Do NOT use with finite lists. +-- +-- >>> take 10 (skipEvens [0, 1 ..]) +-- [1, 3, 5, 7, 9, 11, 13, 15, 17, 19] +skipEvens :: [a] -> [a] +skipEvens = skipOdds . tail + +-- | Sums every element of an infinite list up to a certain precision. +-- I.e. once an element falls below the given threshold it stops traversing +-- the list. +-- +-- >>> suminf 1e-14 (iterate (/ 10) 1) +-- 1.1111111111111112 +suminf :: (Floating a, Ord a) => a -> [a] -> a +suminf eps = sum . takeWhile ((>= eps / 111) . abs) diff --git a/arithmoi.cabal b/arithmoi.cabal --- a/arithmoi.cabal +++ b/arithmoi.cabal @@ -1,200 +1,217 @@ -name : arithmoi -version : 0.7.0.0 -cabal-version : >= 1.10 -author : Daniel Fischer -copyright : (c) 2011 Daniel Fischer, 2016-2018 Andrew Lelechenko, Carter Schonwald -license : MIT -license-file : LICENSE -maintainer : Carter Schonwald carter at wellposed dot com, - Andrew Lelechenko andrew dot lelechenko at gmail dot com -build-type : Simple -stability : Provisional -homepage : https://github.com/cartazio/arithmoi -bug-reports : https://github.com/cartazio/arithmoi/issues - -synopsis : Efficient basic number-theoretic functions. -description : A library of basic functionality needed for - number-theoretic calculations. The aim of this library - is to provide efficient implementations of the functions. - - Primes and related things (totients, factorisation), - powers (integer roots and tests, modular exponentiation). - -category : Math, Algorithms, Number Theory - -tested-with : GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.2 - -extra-source-files : Changes - -flag check-bounds - description : Replace unsafe array operations with safe ones - default : False - manual : True - -library - default-language: Haskell2010 - build-depends : base >= 4.7 && < 5 - , array >= 0.5 && < 0.6 - , ghc-prim < 0.6 - , integer-gmp < 1.1 - , containers >= 0.5 && < 0.6 - , random >= 1.0 && < 1.2 - , mtl >= 2.0 && < 2.3 - , exact-pi >= 0.4.1.1 - , integer-logarithms >= 1.0 - , vector >= 0.12 - if impl(ghc < 7.10) - build-depends : nats >= 1 && <1.2 - if impl(ghc < 8.0) - build-depends : semigroups >= 0.8 - - exposed-modules : Math.NumberTheory.ArithmeticFunctions - Math.NumberTheory.ArithmeticFunctions.Class - Math.NumberTheory.ArithmeticFunctions.Mertens - Math.NumberTheory.ArithmeticFunctions.Moebius - Math.NumberTheory.ArithmeticFunctions.SieveBlock - Math.NumberTheory.ArithmeticFunctions.Standard - Math.NumberTheory.Curves.Montgomery - Math.NumberTheory.Moduli - Math.NumberTheory.Moduli.Chinese - Math.NumberTheory.Moduli.Class - Math.NumberTheory.Moduli.Jacobi - Math.NumberTheory.Moduli.PrimitiveRoot - Math.NumberTheory.Moduli.Sqrt - Math.NumberTheory.MoebiusInversion - Math.NumberTheory.MoebiusInversion.Int - Math.NumberTheory.Recurrencies.Bilinear - Math.NumberTheory.Recurrencies.Linear - Math.NumberTheory.GaussianIntegers - Math.NumberTheory.GCD - Math.NumberTheory.GCD.LowLevel - Math.NumberTheory.Powers - Math.NumberTheory.Powers.Squares - Math.NumberTheory.Powers.Squares.Internal - Math.NumberTheory.Powers.Cubes - Math.NumberTheory.Powers.Fourth - Math.NumberTheory.Powers.General - Math.NumberTheory.Powers.Modular - Math.NumberTheory.Primes - Math.NumberTheory.Primes.Sieve - Math.NumberTheory.Primes.Factorisation - Math.NumberTheory.Primes.Factorisation.Certified - Math.NumberTheory.Primes.Counting - Math.NumberTheory.Primes.Testing - Math.NumberTheory.Primes.Testing.Certificates - Math.NumberTheory.Primes.Heap - Math.NumberTheory.UniqueFactorisation - Math.NumberTheory.Zeta - Math.NumberTheory.Prefactored - GHC.TypeNats.Compat - Math.NumberTheory.SmoothNumbers - - other-modules : Math.NumberTheory.ArithmeticFunctions.SieveBlock.Unboxed - Math.NumberTheory.Utils - Math.NumberTheory.Utils.FromIntegral - Math.NumberTheory.Utils.Hyperbola - Math.NumberTheory.Unsafe - Math.NumberTheory.Primes.Counting.Impl - Math.NumberTheory.Primes.Counting.Approximate - Math.NumberTheory.Primes.Factorisation.Montgomery - Math.NumberTheory.Primes.Factorisation.TrialDivision - Math.NumberTheory.Primes.Sieve.Eratosthenes - Math.NumberTheory.Primes.Sieve.Indexing - Math.NumberTheory.Primes.Sieve.Misc - Math.NumberTheory.Primes.Testing.Probabilistic - Math.NumberTheory.Primes.Testing.Certified - Math.NumberTheory.Primes.Testing.Certificates.Internal - Math.NumberTheory.Primes.Types - other-extensions : BangPatterns - - ghc-options : -O2 -Wall - ghc-prof-options : -O2 -auto - if flag(check-bounds) - cpp-options : -DCheckBounds +name: arithmoi +version: 0.8.0.0 +cabal-version: >=1.10 +build-type: Simple +license: MIT +license-file: LICENSE +copyright: (c) 2011 Daniel Fischer, 2016-2018 Andrew Lelechenko, Carter Schonwald +maintainer: Carter Schonwald carter at wellposed dot com, + Andrew Lelechenko andrew dot lelechenko at gmail dot com +stability: Provisional +homepage: https://github.com/cartazio/arithmoi +bug-reports: https://github.com/cartazio/arithmoi/issues +synopsis: Efficient basic number-theoretic functions. +description: + A library of basic functionality needed for + number-theoretic calculations. The aim of this library + is to provide efficient implementations of the functions. + Primes and related things (totients, factorisation), + powers (integer roots and tests, modular exponentiation). +category: Math, Algorithms, Number Theory +author: Daniel Fischer +tested-with: GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.3 +extra-source-files: + Changes source-repository head - type: git + type: git location: https://github.com/cartazio/arithmoi +flag check-bounds + description: + Replace unsafe array operations with safe ones + default: False + manual: True -benchmark criterion - build-depends: base - , arithmoi - , gauge - , containers - , random - , integer-logarithms - , vector - if impl(ghc < 7.10) - build-depends : nats >= 1 && <1.2 - if impl(ghc < 8.0) - build-depends : semigroups >= 0.8 - other-modules: Math.NumberTheory.ArithmeticFunctionsBench - , Math.NumberTheory.GCDBench - , Math.NumberTheory.MertensBench - , Math.NumberTheory.PowersBench - , Math.NumberTheory.PrimesBench - , Math.NumberTheory.RecurrenciesBench - , Math.NumberTheory.SieveBlockBench - hs-source-dirs: benchmark - main-is: Bench.hs - type: exitcode-stdio-1.0 +library + build-depends: + base >=4.7 && <5, + array >=0.5 && <0.6, + containers >=0.5 && <0.7, + deepseq, + exact-pi >=0.4.1.1, + ghc-prim <0.6, + integer-gmp <1.1, + integer-logarithms >=1.0, + random >=1.0 && <1.2, + transformers >=0.4 && <0.6, + vector >= 0.12 + if impl(ghc <8.0) + build-depends: + semigroups >=0.8 + exposed-modules: + GHC.TypeNats.Compat + Math.NumberTheory.ArithmeticFunctions + Math.NumberTheory.ArithmeticFunctions.Mertens + Math.NumberTheory.ArithmeticFunctions.Moebius + Math.NumberTheory.ArithmeticFunctions.SieveBlock + Math.NumberTheory.Curves.Montgomery + Math.NumberTheory.Euclidean + Math.NumberTheory.Euclidean.Coprimes + Math.NumberTheory.GaussianIntegers + Math.NumberTheory.GCD + Math.NumberTheory.GCD.LowLevel + Math.NumberTheory.Moduli + Math.NumberTheory.Moduli.Chinese + Math.NumberTheory.Moduli.Class + Math.NumberTheory.Moduli.DiscreteLogarithm + Math.NumberTheory.Moduli.Equations + Math.NumberTheory.Moduli.Jacobi + Math.NumberTheory.Moduli.PrimitiveRoot + Math.NumberTheory.Moduli.Sqrt + Math.NumberTheory.MoebiusInversion + Math.NumberTheory.MoebiusInversion.Int + Math.NumberTheory.Powers + Math.NumberTheory.Powers.Cubes + Math.NumberTheory.Powers.Fourth + Math.NumberTheory.Powers.General + Math.NumberTheory.Powers.Modular + Math.NumberTheory.Powers.Squares + Math.NumberTheory.Powers.Squares.Internal + Math.NumberTheory.Prefactored + Math.NumberTheory.Primes + Math.NumberTheory.Primes.Counting + Math.NumberTheory.Primes.Factorisation + Math.NumberTheory.Primes.Factorisation.Certified + Math.NumberTheory.Primes.Sieve + Math.NumberTheory.Primes.Testing + Math.NumberTheory.Primes.Testing.Certificates + Math.NumberTheory.Quadratic.GaussianIntegers + Math.NumberTheory.Quadratic.EisensteinIntegers + Math.NumberTheory.Recurrencies + Math.NumberTheory.Recurrencies.Bilinear + Math.NumberTheory.Recurrencies.Linear + Math.NumberTheory.SmoothNumbers + Math.NumberTheory.UniqueFactorisation + Math.NumberTheory.Zeta + Math.NumberTheory.Zeta.Dirichlet + Math.NumberTheory.Zeta.Riemann + other-modules: + Math.NumberTheory.ArithmeticFunctions.Class + Math.NumberTheory.ArithmeticFunctions.SieveBlock.Unboxed + Math.NumberTheory.ArithmeticFunctions.Standard + Math.NumberTheory.Moduli.SqrtOld + Math.NumberTheory.Primes.Counting.Approximate + Math.NumberTheory.Primes.Counting.Impl + Math.NumberTheory.Primes.Factorisation.Montgomery + Math.NumberTheory.Primes.Factorisation.TrialDivision + Math.NumberTheory.Primes.Sieve.Eratosthenes + Math.NumberTheory.Primes.Sieve.Indexing + Math.NumberTheory.Primes.Testing.Certificates.Internal + Math.NumberTheory.Primes.Testing.Certified + Math.NumberTheory.Primes.Testing.Probabilistic + Math.NumberTheory.Primes.Types + Math.NumberTheory.Recurrencies.Pentagonal + Math.NumberTheory.Unsafe + Math.NumberTheory.Utils + Math.NumberTheory.Utils.FromIntegral + Math.NumberTheory.Utils.Hyperbola + Math.NumberTheory.Zeta.Utils default-language: Haskell2010 + ghc-options: -O2 -Wall + if flag(check-bounds) + cpp-options: -DCheckBounds test-suite spec - type: exitcode-stdio-1.0 - hs-source-dirs: test-suite - ghc-options: -Wall - main-is: Test.hs + build-depends: + base >=4.6 && <5, + arithmoi, + containers, + exact-pi >=0.4.1.1, + integer-gmp <1.1, + QuickCheck >=2.10 && <2.13, + smallcheck >=1.1.3 && <1.2, + tasty >=0.10 && <1.2, + tasty-hunit >=0.9 && <0.11, + tasty-quickcheck >=0.9 && <0.11, + tasty-smallcheck >=0.8 && <0.9, + transformers >=0.5, + vector + if impl(ghc <8.0) + build-depends: + semigroups >=0.8 + other-modules: + Math.NumberTheory.ArithmeticFunctionsTests + Math.NumberTheory.ArithmeticFunctions.MertensTests + Math.NumberTheory.ArithmeticFunctions.SieveBlockTests + Math.NumberTheory.CurvesTests + Math.NumberTheory.EisensteinIntegersTests + Math.NumberTheory.GaussianIntegersTests + Math.NumberTheory.GCDTests + Math.NumberTheory.Moduli.ChineseTests + Math.NumberTheory.Moduli.DiscreteLogarithmTests + Math.NumberTheory.Moduli.ClassTests + Math.NumberTheory.Moduli.EquationsTests + Math.NumberTheory.Moduli.JacobiTests + Math.NumberTheory.Moduli.PrimitiveRootTests + Math.NumberTheory.Moduli.SqrtTests + Math.NumberTheory.MoebiusInversion.IntTests + Math.NumberTheory.MoebiusInversionTests + Math.NumberTheory.Powers.CubesTests + Math.NumberTheory.Powers.FourthTests + Math.NumberTheory.Powers.GeneralTests + Math.NumberTheory.Powers.ModularTests + Math.NumberTheory.Powers.SquaresTests + Math.NumberTheory.PrefactoredTests + Math.NumberTheory.Primes.CountingTests + Math.NumberTheory.Primes.FactorisationTests + Math.NumberTheory.Primes.SieveTests + Math.NumberTheory.Primes.TestingTests + Math.NumberTheory.PrimesTests + Math.NumberTheory.Recurrencies.PentagonalTests + Math.NumberTheory.Recurrencies.BilinearTests + Math.NumberTheory.Recurrencies.LinearTests + Math.NumberTheory.SmoothNumbersTests + Math.NumberTheory.TestUtils + Math.NumberTheory.TestUtils.MyCompose + Math.NumberTheory.TestUtils.Wrappers + Math.NumberTheory.UniqueFactorisationTests + Math.NumberTheory.Zeta.DirichletTests + Math.NumberTheory.Zeta.RiemannTests + type: exitcode-stdio-1.0 + main-is: Test.hs default-language: Haskell2010 - build-depends: arithmoi - , base >= 4.6 && < 5 - , containers >= 0.5 && < 0.6 - , tasty >= 0.10 && < 1.1 - , tasty-smallcheck >= 0.8 && < 0.9 - , tasty-quickcheck >= 0.9 && < 0.11 - , tasty-hunit >= 0.9 && < 0.11 - , QuickCheck >= 2.10 && < 2.12 - , transformers >= 0.5 - , integer-gmp < 1.1 - , vector - if impl(ghc < 7.10) - build-depends : smallcheck >= 1.1 && < 1.1.3, - nats >= 1 && <1.2 - else - build-depends : smallcheck >= 1.1.3 && < 1.2 - if impl(ghc < 8.0) - build-depends : semigroups >= 0.8 + hs-source-dirs: test-suite + ghc-options: -Wall - other-modules : Math.NumberTheory.ArithmeticFunctionsTests - , Math.NumberTheory.ArithmeticFunctions.MertensTests - , Math.NumberTheory.ArithmeticFunctions.SieveBlockTests - , Math.NumberTheory.CurvesTests - , Math.NumberTheory.GaussianIntegersTests - , Math.NumberTheory.GCDTests - , Math.NumberTheory.GCD.LowLevelTests - , Math.NumberTheory.Recurrencies.LinearTests - , Math.NumberTheory.Recurrencies.BilinearTests - , Math.NumberTheory.Moduli.ChineseTests - , Math.NumberTheory.Moduli.ClassTests - , Math.NumberTheory.Moduli.JacobiTests - , Math.NumberTheory.Moduli.PrimitiveRootTests - , Math.NumberTheory.Moduli.SqrtTests - , Math.NumberTheory.Powers.CubesTests - , Math.NumberTheory.MoebiusInversionTests - , Math.NumberTheory.MoebiusInversion.IntTests - , Math.NumberTheory.Powers.FourthTests - , Math.NumberTheory.Powers.GeneralTests - , Math.NumberTheory.Powers.ModularTests - , Math.NumberTheory.Powers.SquaresTests - , Math.NumberTheory.PrefactoredTests - , Math.NumberTheory.PrimesTests - , Math.NumberTheory.Primes.CountingTests - , Math.NumberTheory.Primes.FactorisationTests - , Math.NumberTheory.Primes.SieveTests - , Math.NumberTheory.Primes.TestingTests - , Math.NumberTheory.TestUtils - , Math.NumberTheory.TestUtils.Wrappers - , Math.NumberTheory.TestUtils.MyCompose - , Math.NumberTheory.UniqueFactorisationTests - , Math.NumberTheory.ZetaTests +benchmark criterion + build-depends: + base, + arithmoi, + containers, + deepseq, + gauge, + integer-logarithms, + random, + vector + if impl(ghc <8.0) + build-depends: + semigroups >=0.8 + other-modules: + Math.NumberTheory.ArithmeticFunctionsBench + Math.NumberTheory.DiscreteLogarithmBench + Math.NumberTheory.EisensteinIntegersBench + Math.NumberTheory.GaussianIntegersBench + Math.NumberTheory.GCDBench + Math.NumberTheory.JacobiBench + Math.NumberTheory.MertensBench + Math.NumberTheory.PowersBench + Math.NumberTheory.PrimesBench + Math.NumberTheory.PrimitiveRootsBench + Math.NumberTheory.RecurrenciesBench + Math.NumberTheory.SieveBlockBench + Math.NumberTheory.SmoothNumbersBench + type: exitcode-stdio-1.0 + main-is: Bench.hs + default-language: Haskell2010 + hs-source-dirs: benchmark diff --git a/benchmark/Bench.hs b/benchmark/Bench.hs --- a/benchmark/Bench.hs +++ b/benchmark/Bench.hs @@ -3,19 +3,32 @@ import Gauge.Main import Math.NumberTheory.ArithmeticFunctionsBench as ArithmeticFunctions +import Math.NumberTheory.DiscreteLogarithmBench as DiscreteLogarithm +import Math.NumberTheory.EisensteinIntegersBench as Eisenstein +import Math.NumberTheory.GaussianIntegersBench as Gaussian import Math.NumberTheory.GCDBench as GCD +import Math.NumberTheory.JacobiBench as Jacobi import Math.NumberTheory.MertensBench as Mertens import Math.NumberTheory.PowersBench as Powers import Math.NumberTheory.PrimesBench as Primes +import Math.NumberTheory.PrimitiveRootsBench as PrimitiveRoots import Math.NumberTheory.RecurrenciesBench as Recurrencies import Math.NumberTheory.SieveBlockBench as SieveBlock +import Math.NumberTheory.SmoothNumbersBench as SmoothNumbers +main :: IO () main = defaultMain [ ArithmeticFunctions.benchSuite + , DiscreteLogarithm.benchSuite + , Eisenstein.benchSuite + , Gaussian.benchSuite , GCD.benchSuite + , Jacobi.benchSuite , Mertens.benchSuite , Powers.benchSuite , Primes.benchSuite + , PrimitiveRoots.benchSuite , Recurrencies.benchSuite , SieveBlock.benchSuite + , SmoothNumbers.benchSuite ] diff --git a/benchmark/Math/NumberTheory/ArithmeticFunctionsBench.hs b/benchmark/Math/NumberTheory/ArithmeticFunctionsBench.hs --- a/benchmark/Math/NumberTheory/ArithmeticFunctionsBench.hs +++ b/benchmark/Math/NumberTheory/ArithmeticFunctionsBench.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -fno-warn-type-defaults #-} + module Math.NumberTheory.ArithmeticFunctionsBench ( benchSuite ) where @@ -7,20 +9,23 @@ import Math.NumberTheory.ArithmeticFunctions as A -compareFunctions :: String -> (Integer -> Integer) -> Benchmark -compareFunctions name new = bench name $ nf (map new) [1..100000] +compareFunctions :: String -> (Integer -> Integer) -> [Integer] -> Benchmark +compareFunctions name new range = bench name $ nf (map new) range compareSetFunctions :: String -> (Integer -> Set Integer) -> Benchmark compareSetFunctions name new = bench name $ nf (map new) [1..100000] benchSuite :: Benchmark benchSuite = bgroup "ArithmeticFunctions" - [ compareSetFunctions "divisors" A.divisors - , bench "divisors/int" $ nf (map A.divisorsSmall) [1 :: Int .. 100000] - , compareFunctions "totient" A.totient - , compareFunctions "carmichael" A.carmichael - , compareFunctions "moebius" (A.runMoebius . A.moebius) - , compareFunctions "tau" A.tau - , compareFunctions "sigma 1" (A.sigma 1) - , compareFunctions "sigma 2" (A.sigma 2) + [ compareSetFunctions "divisors" A.divisors + , bench "divisors/int" $ nf (map A.divisorsSmall) [1 :: Int .. 100000] + , compareFunctions "totient" A.totient [1..100000] + , compareFunctions "carmichael" A.carmichael [1..100000] + , compareFunctions "moebius" (A.runMoebius . A.moebius) [1..100000] + , compareFunctions "tau" A.tau [1..100000] + , compareFunctions "sigma 1" (A.sigma 1) [1..100000] + , compareFunctions "sigma 2" (A.sigma 2) [1..100000] + , compareFunctions "ramanujan range" ramanujan [1..2000] + , compareFunctions "ramanujan large prime" ramanujan [100003] + , compareFunctions "ramanujan prime power" ramanujan [2^3000] ] diff --git a/benchmark/Math/NumberTheory/DiscreteLogarithmBench.hs b/benchmark/Math/NumberTheory/DiscreteLogarithmBench.hs new file mode 100644 --- /dev/null +++ b/benchmark/Math/NumberTheory/DiscreteLogarithmBench.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{-# OPTIONS_GHC -fno-warn-type-defaults #-} + +module Math.NumberTheory.DiscreteLogarithmBench + ( benchSuite + , rangeCases + , discreteLogarithm' + ) where + +import Gauge.Main +import Data.Maybe +import GHC.TypeNats.Compat +import Data.Proxy +import Numeric.Natural + +import Math.NumberTheory.Moduli.Class (isMultElement, KnownNat, MultMod, multElement, getVal,Mod) +import Math.NumberTheory.Moduli.DiscreteLogarithm (discreteLogarithm) +import Math.NumberTheory.Moduli.PrimitiveRoot (PrimitiveRoot, isPrimitiveRoot, unPrimitiveRoot, cyclicGroupFromModulo) + +data Case = forall m. KnownNat m => Case (PrimitiveRoot m) (MultMod m) String + +instance Show Case where + show (Case a b s) = concat [show (getVal a'), "ⁿ == ", show b', " mod ", s] + where a' = multElement $ unPrimitiveRoot a + b' = getVal $ multElement b + +makeCase :: (Integer, Integer, Natural, String) -> Maybe Case +makeCase (a,b,n,s) = + case someNatVal n of + SomeNat (_ :: Proxy m) -> + Case <$> isPrimitiveRoot a' <*> isMultElement b' <*> pure s + where a' = fromInteger a :: Mod m + b' = fromInteger b + +cases :: [Case] +cases = mapMaybe makeCase [ (5, 8, 10^9 + 7, "10^9 + 7") + , (2, 7, 3^1000, "3^1000") + , (2, 3, 10^11 + 3, "10^11 + 3") + , (3, 17, 5^700, "5^700") + ] + +rangeCases :: Natural -> Int -> [Case] +rangeCases start num = take num $ do + n <- [start..] + _cg <- maybeToList $ cyclicGroupFromModulo n + case someNatVal n of + SomeNat (_ :: Proxy m) -> do + a <- take 1 $ mapMaybe isPrimitiveRoot [2 :: Mod m .. maxBound] + b <- take 1 $ filter (/= unPrimitiveRoot a) $ mapMaybe isMultElement [2 .. maxBound] + return $ Case a b (show n) + +discreteLogarithm' :: Case -> Natural +discreteLogarithm' (Case a b _) = discreteLogarithm a b + +benchSuite :: Benchmark +benchSuite = bgroup "Discrete logarithm" + [ bgroup "individual case" + [ bench (show c) $ nf discreteLogarithm' c | c <- cases] + , bgroup "range" + [ bench (show num ++ " cases near " ++ show n) $ nf (map discreteLogarithm') $ rangeCases n num + | (n, num) <- [(10000, 100), (1000000, 100), (100000000, 100), (10000000000, 100)] + ] + ] diff --git a/benchmark/Math/NumberTheory/EisensteinIntegersBench.hs b/benchmark/Math/NumberTheory/EisensteinIntegersBench.hs new file mode 100644 --- /dev/null +++ b/benchmark/Math/NumberTheory/EisensteinIntegersBench.hs @@ -0,0 +1,26 @@ +{-# OPTIONS_GHC -fno-warn-type-defaults #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Math.NumberTheory.EisensteinIntegersBench + ( benchSuite + ) where + +import Control.DeepSeq +import Gauge.Main + +import Math.NumberTheory.ArithmeticFunctions (tau) +import Math.NumberTheory.Quadratic.EisensteinIntegers + +instance NFData EisensteinInteger + +benchFindPrime :: Integer -> Benchmark +benchFindPrime n = bench (show n) $ nf findPrime n + +benchTau :: Integer -> Benchmark +benchTau n = bench (show n) $ nf (\m -> sum [tau (x :+ y) | x <- [1..m], y <- [0..m]] :: Word) n + +benchSuite :: Benchmark +benchSuite = bgroup "Eisenstein" + [ bgroup "findPrime" $ map benchFindPrime [1000003, 10000141, 100000039, 1000000021, 10000000033, 100000000003, 1000000000039, 10000000000051] + , bgroup "tau" $ map benchTau [10, 20, 40, 80] + ] diff --git a/benchmark/Math/NumberTheory/GCDBench.hs b/benchmark/Math/NumberTheory/GCDBench.hs --- a/benchmark/Math/NumberTheory/GCDBench.hs +++ b/benchmark/Math/NumberTheory/GCDBench.hs @@ -1,3 +1,6 @@ +{-# OPTIONS_GHC -fno-warn-type-defaults #-} +{-# OPTIONS_GHC -fno-warn-deprecations #-} + module Math.NumberTheory.GCDBench ( benchSuite ) where @@ -6,16 +9,29 @@ import Math.NumberTheory.GCD as A import Prelude as P +import Numeric.Natural +averageGCD :: Integral a => (a -> a -> a) -> a -> a +averageGCD gcdF lim = sum [ gcdF x y | x <- [lim .. 2 * lim], y <- [lim .. x] ] + +benchSuite :: Benchmark benchSuite = bgroup "GCD" [ subSuite "large coprimes" 1073741823 100003 , subSuite "powers of 2" (2^12) (2^19) , subSuite "power of 23" (23^3) (23^7) + , bench "average prelude Int" $ nf (averageGCD P.gcd) (2000 :: Int) + , bench "average arithmoi Int" $ nf (averageGCD A.binaryGCD) (2000 :: Int) + , bench "average prelude Word" $ nf (averageGCD P.gcd) (2000 :: Word) + , bench "average arithmoi Word" $ nf (averageGCD A.binaryGCD) (2000 :: Word) + , bench "average prelude Integer" $ nf (averageGCD P.gcd) (2000 :: Integer) + , bench "average arithmoi Integer" $ nf (averageGCD A.binaryGCD) (2000 :: Integer) + , bench "average prelude Natural" $ nf (averageGCD P.gcd) (2000 :: Natural) + , bench "average arithmoi Natural" $ nf (averageGCD A.binaryGCD) (2000 :: Natural) ] where subSuite :: String -> Int -> Int -> Benchmark subSuite name m n = bgroup name [ bench "Prelude.gcd" $ nf (P.gcd m) n , bench "binaryGCD" $ nf (A.binaryGCD m) n - , bench "Prelude.coprime" $ nf (\n -> 1 == P.gcd m n) n + , bench "Prelude.coprime" $ nf (\t -> 1 == P.gcd m t) n , bench "coprime" $ nf (A.coprime m) n ] diff --git a/benchmark/Math/NumberTheory/GaussianIntegersBench.hs b/benchmark/Math/NumberTheory/GaussianIntegersBench.hs new file mode 100644 --- /dev/null +++ b/benchmark/Math/NumberTheory/GaussianIntegersBench.hs @@ -0,0 +1,22 @@ +{-# OPTIONS_GHC -fno-warn-type-defaults #-} + +module Math.NumberTheory.GaussianIntegersBench + ( benchSuite + ) where + +import Gauge.Main + +import Math.NumberTheory.ArithmeticFunctions (tau) +import Math.NumberTheory.Quadratic.GaussianIntegers + +benchFindPrime :: Integer -> Benchmark +benchFindPrime n = bench (show n) $ nf findPrime n + +benchTau :: Integer -> Benchmark +benchTau n = bench (show n) $ nf (\m -> sum [tau (x :+ y) | x <- [1..m], y <- [0..m]] :: Word) n + +benchSuite :: Benchmark +benchSuite = bgroup "Gaussian" + [ bgroup "findPrime" $ map benchFindPrime [1000033, 10000121, 100000037, 1000000009, 10000000033, 100000000057, 1000000000061, 10000000000037] + , bgroup "tau" $ map benchTau [10, 20, 40, 80] + ] diff --git a/benchmark/Math/NumberTheory/JacobiBench.hs b/benchmark/Math/NumberTheory/JacobiBench.hs new file mode 100644 --- /dev/null +++ b/benchmark/Math/NumberTheory/JacobiBench.hs @@ -0,0 +1,21 @@ +{-# OPTIONS_GHC -fno-warn-type-defaults #-} + +module Math.NumberTheory.JacobiBench + ( benchSuite + ) where + +import Gauge.Main +import Numeric.Natural + +import Math.NumberTheory.Moduli.Jacobi + +doBench :: Integral a => (a -> a -> JacobiSymbol) -> a -> a +doBench func lim = sum [ x + y | y <- [3, 5 .. lim], x <- [0..y], func x y == One ] + +benchSuite :: Benchmark +benchSuite = bgroup "Jacobi" + [ bench "jacobi/Int" $ nf (doBench jacobi :: Int -> Int) 2000 + , bench "jacobi/Word" $ nf (doBench jacobi :: Word -> Word) 2000 + , bench "jacobi/Integer" $ nf (doBench jacobi :: Integer -> Integer) 2000 + , bench "jacobi/Natural" $ nf (doBench jacobi :: Natural -> Natural) 2000 + ] diff --git a/benchmark/Math/NumberTheory/MertensBench.hs b/benchmark/Math/NumberTheory/MertensBench.hs --- a/benchmark/Math/NumberTheory/MertensBench.hs +++ b/benchmark/Math/NumberTheory/MertensBench.hs @@ -8,9 +8,6 @@ ) where import Gauge.Main -#if __GLASGOW_HASKELL__ < 709 -import Data.Word -#endif import Math.NumberTheory.ArithmeticFunctions.Mertens diff --git a/benchmark/Math/NumberTheory/PrimitiveRootsBench.hs b/benchmark/Math/NumberTheory/PrimitiveRootsBench.hs new file mode 100644 --- /dev/null +++ b/benchmark/Math/NumberTheory/PrimitiveRootsBench.hs @@ -0,0 +1,40 @@ +{-# OPTIONS_GHC -fno-warn-type-defaults #-} + +module Math.NumberTheory.PrimitiveRootsBench + ( benchSuite + ) where + +import Gauge.Main +import Data.Maybe + +import Math.NumberTheory.Moduli.PrimitiveRoot +import Math.NumberTheory.UniqueFactorisation + +primRootWrap :: Integer -> Word -> Integer -> Bool +primRootWrap p k g = isPrimitiveRoot' (CGOddPrimePower p' k) g + where p' = fromJust $ isPrime p + +primRootWrap2 :: Integer -> Word -> Integer -> Bool +primRootWrap2 p k g = isPrimitiveRoot' (CGDoubleOddPrimePower p' k) g + where p' = fromJust $ isPrime p + +cyclicWrap :: Integer -> Maybe (CyclicGroup Integer) +cyclicWrap = cyclicGroupFromModulo + +benchSuite :: Benchmark +benchSuite = bgroup "PrimRoot" + [ bgroup "groupFromModulo" + [ bench "3^20000" $ nf cyclicWrap (3^20000) -- prime to large power + , bench "10000000000000061" $ nf cyclicWrap (10^16 + 61) -- large prime + , bench "2*3^20000" $ nf cyclicWrap (2*3^20000) -- twice prime to large power + , bench "10000000000000046" $ nf cyclicWrap (10^16 + 46) -- twice large prime + , bench "224403121196654400" $ nf cyclicWrap (224403121196654400) -- highly composite + ] + , bgroup "check prim roots" + [ bench "3^20000" $ nf (primRootWrap 3 20000) 2 -- prime to large power + , bench "10000000000000061" $ nf (primRootWrap (10^16 + 61) 1) 3 -- large prime + , bench "10000000000000061^2" $ nf (primRootWrap (10^16 + 61) 2) 3 -- large prime squared + , bench "2*3^20000" $ nf (primRootWrap2 3 20000) 5 -- twice prime to large power + , bench "10000000000000046" $ nf (primRootWrap2 (5*10^15 + 23) 1) 5 -- twice large prime + ] + ] diff --git a/benchmark/Math/NumberTheory/RecurrenciesBench.hs b/benchmark/Math/NumberTheory/RecurrenciesBench.hs --- a/benchmark/Math/NumberTheory/RecurrenciesBench.hs +++ b/benchmark/Math/NumberTheory/RecurrenciesBench.hs @@ -6,7 +6,8 @@ import Gauge.Main -import Math.NumberTheory.Recurrencies.Bilinear +import Math.NumberTheory.Recurrencies (binomial, eulerian1, eulerian2, + stirling1, stirling2, partition) benchTriangle :: String -> (forall a. (Integral a) => [[a]]) -> Int -> Benchmark benchTriangle name triangle n = bgroup name @@ -19,11 +20,29 @@ benchAt i j = bench ("!! " ++ show i ++ " !! " ++ show j) $ nf (\(x, y) -> triangle !! x !! y :: Integer) (i, j) +benchPartition :: Int -> Benchmark +benchPartition n = bgroup "partition" + [ benchAt n + , benchAt (n * 10) + , benchAt (n * 100) + ] + where + benchAt m = bench ("!!" ++ show m) $ nf (\k -> partition !! k :: Integer) m + benchSuite :: Benchmark -benchSuite = bgroup "Bilinear" - [ benchTriangle "binomial" binomial 1000 - , benchTriangle "stirling1" stirling1 100 - , benchTriangle "stirling2" stirling2 100 - , benchTriangle "eulerian1" eulerian1 100 - , benchTriangle "eulerian2" eulerian2 100 +benchSuite = bgroup "Recurrencies" + [ + bgroup "Bilinear" + [ benchTriangle "binomial" binomial 1000 + , benchTriangle "stirling1" stirling1 100 + , benchTriangle "stirling2" stirling2 100 + , benchTriangle "eulerian1" eulerian1 100 + , benchTriangle "eulerian2" eulerian2 100 + ] + , + bgroup "Pentagonal" + [ bgroup "Partition function" + [ benchPartition 1000 + ] + ] ] diff --git a/benchmark/Math/NumberTheory/SieveBlockBench.hs b/benchmark/Math/NumberTheory/SieveBlockBench.hs --- a/benchmark/Math/NumberTheory/SieveBlockBench.hs +++ b/benchmark/Math/NumberTheory/SieveBlockBench.hs @@ -14,16 +14,12 @@ #endif import qualified Data.Vector as V import qualified Data.Vector.Unboxed as U -#if __GLASGOW_HASKELL__ < 709 -import Data.Word -#endif import Math.NumberTheory.ArithmeticFunctions.Moebius import Math.NumberTheory.ArithmeticFunctions.SieveBlock -import Math.NumberTheory.Primes.Factorisation (totientSieve, sieveTotient, carmichaelSieve, sieveCarmichael) blockLen :: Word -blockLen = 10^6 +blockLen = 1000000 totientHelper :: Word -> Word -> Word totientHelper p 1 = p - 1 @@ -37,12 +33,6 @@ , sbcFunctionOnPrimePower = totientHelper } -sumOldTotientSieve :: Word -> Word -sumOldTotientSieve len' = sum $ map (fromInteger . sieveTotient sieve) [1 .. len] - where - len = toInteger len' - sieve = totientSieve len - carmichaelHelper :: Word -> Word -> Word carmichaelHelper 2 1 = 1 carmichaelHelper 2 2 = 2 @@ -59,12 +49,6 @@ , sbcFunctionOnPrimePower = carmichaelHelper } -sumOldCarmichaelSieve :: Word -> Word -sumOldCarmichaelSieve len' = sum $ map (fromInteger . sieveCarmichael sieve) [1 .. len] - where - len = toInteger len' - sieve = carmichaelSieve len - moebiusConfig :: SieveBlockConfig Moebius moebiusConfig = SieveBlockConfig { sbcEmpty = MoebiusP @@ -78,13 +62,11 @@ benchSuite :: Benchmark benchSuite = bgroup "SieveBlock" [ bgroup "totient" - [ bench "old" $ nf sumOldTotientSieve blockLen - , bench "boxed" $ nf (V.sum . sieveBlock totientBlockConfig 1) blockLen + [ bench "boxed" $ nf (V.sum . sieveBlock totientBlockConfig 1) blockLen , bench "unboxed" $ nf (U.sum . sieveBlockUnboxed totientBlockConfig 1) blockLen ] , bgroup "carmichael" - [ bench "old" $ nf sumOldCarmichaelSieve blockLen - , bench "boxed" $ nf (V.sum . sieveBlock carmichaelBlockConfig 1) blockLen + [ bench "boxed" $ nf (V.sum . sieveBlock carmichaelBlockConfig 1) blockLen , bench "unboxed" $ nf (U.sum . sieveBlockUnboxed carmichaelBlockConfig 1) blockLen ] , bgroup "moebius" diff --git a/benchmark/Math/NumberTheory/SmoothNumbersBench.hs b/benchmark/Math/NumberTheory/SmoothNumbersBench.hs new file mode 100644 --- /dev/null +++ b/benchmark/Math/NumberTheory/SmoothNumbersBench.hs @@ -0,0 +1,21 @@ +{-# OPTIONS_GHC -fno-warn-type-defaults #-} + +module Math.NumberTheory.SmoothNumbersBench + ( benchSuite + ) where + +import Data.List (genericTake) +import Data.Maybe +import Gauge.Main + +import Math.NumberTheory.SmoothNumbers + +doBench :: Integral a => a -> a +doBench lim = sum $ genericTake lim $ smoothOver $ fromJust $ fromSmoothUpperBound lim + +benchSuite :: Benchmark +benchSuite = bgroup "SmoothNumbers" + [ bench "100" $ nf doBench (100 :: Int) + , bench "1000" $ nf doBench (1000 :: Int) + , bench "10000" $ nf doBench (10000 :: Int) + ] diff --git a/test-suite/Math/NumberTheory/ArithmeticFunctions/MertensTests.hs b/test-suite/Math/NumberTheory/ArithmeticFunctions/MertensTests.hs --- a/test-suite/Math/NumberTheory/ArithmeticFunctions/MertensTests.hs +++ b/test-suite/Math/NumberTheory/ArithmeticFunctions/MertensTests.hs @@ -24,9 +24,6 @@ #endif import qualified Data.Vector as V import qualified Data.Vector.Unboxed as U -#if __GLASGOW_HASKELL__ < 709 -import Data.Word -#endif import Math.NumberTheory.ArithmeticFunctions import Math.NumberTheory.ArithmeticFunctions.Mertens diff --git a/test-suite/Math/NumberTheory/ArithmeticFunctions/SieveBlockTests.hs b/test-suite/Math/NumberTheory/ArithmeticFunctions/SieveBlockTests.hs --- a/test-suite/Math/NumberTheory/ArithmeticFunctions/SieveBlockTests.hs +++ b/test-suite/Math/NumberTheory/ArithmeticFunctions/SieveBlockTests.hs @@ -25,9 +25,6 @@ #endif import qualified Data.Vector as V import qualified Data.Vector.Unboxed as U -#if __GLASGOW_HASKELL__ < 709 -import Data.Word -#endif import Math.NumberTheory.ArithmeticFunctions import Math.NumberTheory.ArithmeticFunctions.SieveBlock diff --git a/test-suite/Math/NumberTheory/ArithmeticFunctionsTests.hs b/test-suite/Math/NumberTheory/ArithmeticFunctionsTests.hs --- a/test-suite/Math/NumberTheory/ArithmeticFunctionsTests.hs +++ b/test-suite/Math/NumberTheory/ArithmeticFunctionsTests.hs @@ -20,18 +20,11 @@ import Test.Tasty import Test.Tasty.HUnit -#if MIN_VERSION_base(4,8,0) -#else -import Prelude hiding (sum, all, elem) -import Data.Foldable -#endif - import Data.List (sort) import qualified Data.Set as S import qualified Data.IntSet as IS import Math.NumberTheory.ArithmeticFunctions -import Math.NumberTheory.Primes.Factorisation import Math.NumberTheory.TestUtils import Numeric.Natural @@ -39,25 +32,28 @@ oeisAssertion :: (Eq a, Show a) => String -> ArithmeticFunction Natural a -> [a] -> Assertion oeisAssertion name f baseline = assertEqual name baseline (map (runFunction f) [1 .. fromIntegral (length baseline)]) +wolframAlphaAssertion :: (Eq a, Show a) => String -> ArithmeticFunction Integer a -> [Integer] -> [a] -> Assertion +wolframAlphaAssertion name f domain baseline = assertEqual name baseline (map (runFunction f) domain) + -- | tau(n) equals to a number of divisors. -divisorsProperty1 :: Natural -> Bool -divisorsProperty1 n = S.size (runFunction divisorsA n) == runFunction tauA n +divisorsProperty1 :: NonZero Natural -> Bool +divisorsProperty1 (NonZero n) = S.size (runFunction divisorsA n) == runFunction tauA n -- | sigma(n) equals to a number of divisors. -divisorsProperty2 :: Natural -> Bool -divisorsProperty2 n = sum (runFunction divisorsA n) == runFunction (sigmaA 1) n +divisorsProperty2 :: NonZero Natural -> Bool +divisorsProperty2 (NonZero n) = sum (runFunction divisorsA n) == runFunction (sigmaA 1) n -- | All divisors of n truly divides n. -divisorsProperty3 :: Natural -> Bool -divisorsProperty3 n = all (\d -> n `mod` d == 0) (runFunction divisorsA n) +divisorsProperty3 :: NonZero Natural -> Bool +divisorsProperty3 (NonZero n) = all (\d -> n `mod` d == 0) (runFunction divisorsA n) -- | 'divisorsA' matches 'divisorsSmallA' -divisorsProperty4 :: Int -> Bool -divisorsProperty4 n = S.toAscList (runFunction divisorsA n) == IS.toAscList (runFunction divisorsSmallA n) +divisorsProperty4 :: NonZero Int -> Bool +divisorsProperty4 (NonZero n) = S.toAscList (runFunction divisorsA n) == IS.toAscList (runFunction divisorsSmallA n) -- | 'divisorsA' matches 'divisorsListA' -divisorsProperty5 :: Int -> Bool -divisorsProperty5 n = S.toAscList (runFunction divisorsA n) == sort (runFunction divisorsListA n) +divisorsProperty5 :: NonZero Int -> Bool +divisorsProperty5 (NonZero n) = S.toAscList (runFunction divisorsA n) == sort (runFunction divisorsListA n) -- | tau matches baseline from OEIS. tauOeis :: Assertion @@ -70,12 +66,12 @@ ] -- | sigma_0 coincides with tau by definition -sigmaProperty1 :: Natural -> Bool -sigmaProperty1 n = runFunction tauA n == runFunction (sigmaA 0) n +sigmaProperty1 :: NonZero Natural -> Bool +sigmaProperty1 (NonZero n) = runFunction tauA n == runFunction (sigmaA 0) n -- | value of totient is bigger than argument -sigmaProperty2 :: Natural -> Bool -sigmaProperty2 n = n <= 1 || runFunction (sigmaA 1) n > n +sigmaProperty2 :: NonZero Natural -> Bool +sigmaProperty2 (NonZero n) = n <= 1 || runFunction (sigmaA 1) n > n -- | sigma_1 matches baseline from OEIS. sigma1Oeis :: Assertion @@ -96,21 +92,12 @@ ] -- | value of totient if even, except totient(1) and totient(2) -totientProperty1 :: Natural -> Bool -totientProperty1 n = n <= 2 || even (runFunction totientA n) +totientProperty1 :: NonZero Natural -> Bool +totientProperty1 (NonZero n) = n <= 2 || even (runFunction totientA n) -- | value of totient is smaller than argument -totientProperty2 :: Natural -> Bool -totientProperty2 n = n <= 1 || runFunction totientA n < n - -totientSieve100 :: TotientSieve -totientSieve100 = totientSieve 100 - --- | totient matches sieveTotient -totientProperty3 :: Natural -> Bool -totientProperty3 n = n < 1 - || fromIntegral (runFunction totientA n) - == sieveTotient totientSieve100 (fromIntegral n) +totientProperty2 :: NonZero Natural -> Bool +totientProperty2 (NonZero n) = n <= 1 || runFunction totientA n < n -- | totient matches baseline from OEIS. totientOeis :: Assertion @@ -122,12 +109,12 @@ ] -- | jordan_0 is zero for argument > 1 -jordanProperty1 :: Natural -> Bool -jordanProperty1 n = n <= 1 || runFunction (jordanA 0) n == 0 +jordanProperty1 :: NonZero Natural -> Bool +jordanProperty1 (NonZero n) = n <= 1 || runFunction (jordanA 0) n == 0 -- | jordan_1 coincides with totient by definition -jordanProperty2 :: Natural -> Bool -jordanProperty2 n = runFunction totientA n == runFunction (jordanA 1) n +jordanProperty2 :: NonZero Natural -> Bool +jordanProperty2 (NonZero n) = runFunction totientA n == runFunction (jordanA 1) n -- | jordan_2 matches baseline from OEIS. jordan2Oeis :: Assertion @@ -138,6 +125,72 @@ , 1728, 1584, 2208, 1536 ] +-- | congruences 1,2,3,4 from https://en.wikipedia.org/wiki/Ramanujan_tau_function +ramanujanCongruence1 :: NonZero Natural -> Bool +ramanujanCongruence1 (NonZero n) + | k == 1 = (ramanujan n' - sigma 11 n') `mod` (2^11) == 0 + | k == 3 = (ramanujan n' - 1217 * sigma 11 n') `mod` (2^13) == 0 + | k == 5 = (ramanujan n' - 1537 * sigma 11 n') `mod` (2^12) == 0 + | k == 7 = (ramanujan n' - 705 * sigma 11 n') `mod` (2^14) == 0 + | otherwise = True + where k = n `mod` 8 + n' = fromIntegral n :: Integer + +-- | congruences 8,9 from https://en.wikipedia.org/wiki/Ramanujan_tau_function +ramanujanCongruence2 :: NonZero Natural -> Bool +ramanujanCongruence2 (NonZero n) + | (n `mod` 7) `elem` [0,1,2,4] = m `mod` 7 == 0 + | otherwise = m `mod` 49 == 0 + where m = ramanujan n' - n' * sigma 9 n' + n' = fromIntegral n :: Integer + +-- | ramanujan matches baseline from wolframAlpha: https://www.wolframalpha.com/input/?i=RamanujanTau%5BRange%5B100%5D%5D +ramanujanRange :: Assertion +ramanujanRange = wolframAlphaAssertion "A000594" ramanujanA [1..100] + [ 1, -24, 252, -1472, 4830, -6048, -16744, 84480, -113643, -115920 + , 534612, -370944, -577738, 401856, 1217160, 987136, -6905934, 2727432 + , 10661420, -7109760, -4219488, -12830688, 18643272, 21288960, -25499225 + , 13865712, -73279080, 24647168, 128406630, -29211840, -52843168 + , -196706304, 134722224, 165742416, -80873520, 167282496, -182213314 + , -255874080, -145589976, 408038400, 308120442, 101267712, -17125708 + , -786948864, -548895690, -447438528, 2687348496, 248758272, -1696965207 + , 611981400, -1740295368, 850430336, -1596055698, 1758697920, 2582175960 + , -1414533120, 2686677840, -3081759120, -5189203740, -1791659520, 6956478662 + , 1268236032, 1902838392, 2699296768, -2790474540, -3233333376, -15481826884 + , 10165534848, 4698104544, 1940964480, 9791485272, -9600560640, 1463791322 + , 4373119536, -6425804700, -15693610240, -8951543328, 3494159424, 38116845680 + , 4767866880, 1665188361, -7394890608, -29335099668, 6211086336, -33355661220 + , 411016992, 32358470760, 45164021760, -24992917110, 13173496560, 9673645072 + , -27442896384, -13316478336, -64496363904, 51494658600, -49569988608 + , 75013568546, 40727164968, -60754911516, 37534859200 + ] + +-- | ramanujan matches baseline from wolframAlpha: https://www.wolframalpha.com/input/?i=RamanujanTau%5B2%5ERange%5B20%5D%5D +ramanujanPowers2 :: Assertion +ramanujanPowers2 = wolframAlphaAssertion "wolframAlpha2^n" ramanujanA [2^n | n <- [1..20]] + [ -24, -1472, 84480, 987136, -196706304, 2699296768, 338071388160 + , -13641873096704, -364965248630784, 36697722069188608, -133296500464680960 + , -71957818786545926144, 1999978883828768833536, 99370119662955604738048 + , -6480839625992253084794880, -47969854045919004468445184 + , 14424036051134190424902598656, -247934604141178449046286630912 + , -23589995333334539213089642905600, 1073929957281162404760946449842176 + ] + +-- | ramanujan matches baseline from wolframAlpha: https://www.wolframalpha.com/input/?i=RamanujanTau%5B3%5ERange%5B20%5D%5D +ramanujanPowers3 :: Assertion +ramanujanPowers3 = wolframAlphaAssertion "wolframAlpha3^n" ramanujanA [3^n | n <- [1..20]] + [ 252, -113643, -73279080, 1665188361, 13400796651732, 3082017633650397 + , -1597242480784468560, -948475282905952954479, 43930942451226107469612 + , 179090148438649827109433637, 37348482744132405171657919560 + , -22313464873940134819697044764519, -12239164820907737153507340756954108 + , 868493827155123300221022518147812077, 2386991774972433985188062567645398013280 + , 447670851294004737003138291024309833342241 + , -310035377434952569449318870332553243856267428 + , -157432463407787104647123294163886831498857358283 + , 15248856227707192449163419793501327951694151780600 + , 31731400364681474724113131979212395183355010696469801 + ] + -- | moebius does not require full factorisation moebiusLazy :: Assertion moebiusLazy = assertEqual "moebius" MoebiusZ (runFunction moebiusA (2^2 * (2^100000-1) :: Natural)) @@ -152,12 +205,12 @@ ] -- | liouville values are [-1, 1] -liouvilleProperty1 :: Natural -> Bool -liouvilleProperty1 n = runFunction liouvilleA n `elem` [-1, 1] +liouvilleProperty1 :: NonZero Natural -> Bool +liouvilleProperty1 (NonZero n) = runFunction liouvilleA n `elem` [-1, 1] -- | moebius is zero or equal to liouville -liouvilleProperty2 :: Natural -> Bool -liouvilleProperty2 n = m == MoebiusZ || l == runMoebius m +liouvilleProperty2 :: NonZero Natural -> Bool +liouvilleProperty2 (NonZero n) = m == MoebiusZ || l == runMoebius m where l = runFunction liouvilleA n m = runFunction moebiusA n @@ -173,17 +226,8 @@ ] -- | carmichaeil divides totient -carmichaelProperty1 :: Natural -> Bool -carmichaelProperty1 n = runFunction totientA n `mod` runFunction carmichaelA n == 0 - -carmichaelSieve100 :: CarmichaelSieve -carmichaelSieve100 = carmichaelSieve 100 - --- | carmichael matches sieveCarmichael -carmichaelProperty2 :: Natural -> Bool -carmichaelProperty2 n = n < 1 - || fromIntegral (runFunction carmichaelA n) - == sieveCarmichael carmichaelSieve100 (fromIntegral n) +carmichaelProperty1 :: NonZero Natural -> Bool +carmichaelProperty1 (NonZero n) = runFunction totientA n `mod` runFunction carmichaelA n == 0 -- | carmichael matches baseline from OEIS. carmichaelOeis :: Assertion @@ -195,8 +239,8 @@ ] -- | smallOmega is smaller than bigOmega -omegaProperty1 :: Natural -> Bool -omegaProperty1 n = runFunction smallOmegaA n <= runFunction bigOmegaA n +omegaProperty1 :: NonZero Natural -> Bool +omegaProperty1 (NonZero n) = runFunction smallOmegaA n <= runFunction bigOmegaA n -- | smallOmega matches baseline from OEIS. smallOmegaOeis :: Assertion @@ -248,7 +292,6 @@ , testGroup "Totient" [ testSmallAndQuick "totient is even" totientProperty1 , testSmallAndQuick "totient n < n" totientProperty2 - , testSmallAndQuick "matches sieveTotient" totientProperty3 , testCase "OEIS" totientOeis ] , testGroup "Jordan" @@ -256,6 +299,13 @@ , testSmallAndQuick "jordan_1 = totient" jordanProperty2 , testCase "OEIS jordan_2" jordan2Oeis ] + , testGroup "Ramanujan" + [ testSmallAndQuick "ramanujan mod 8 congruences" ramanujanCongruence1 + , testSmallAndQuick "ramanujan mod 7 congruences" ramanujanCongruence2 + , testCase "baseline ramanujan range" ramanujanRange + , testCase "baseline ramanujan powers2" ramanujanPowers2 + , testCase "baseline ramanujan powers3" ramanujanPowers3 + ] , testGroup "Moebius" [ testCase "OEIS" moebiusOeis , testCase "Lazy" moebiusLazy @@ -267,7 +317,6 @@ ] , testGroup "Carmichael" [ testSmallAndQuick "carmichael divides totient" carmichaelProperty1 - , testSmallAndQuick "matches sieveCarmichael" carmichaelProperty2 , testCase "OEIS" carmichaelOeis ] , testGroup "Omegas" diff --git a/test-suite/Math/NumberTheory/CurvesTests.hs b/test-suite/Math/NumberTheory/CurvesTests.hs --- a/test-suite/Math/NumberTheory/CurvesTests.hs +++ b/test-suite/Math/NumberTheory/CurvesTests.hs @@ -22,10 +22,6 @@ import Math.NumberTheory.Curves.Montgomery import Math.NumberTheory.TestUtils -#if __GLASGOW_HASKELL__ < 709 -import Data.Word -#endif - (==>?) :: Maybe a -> (a -> Property) -> Property x ==>? f = case x of Nothing -> discard diff --git a/test-suite/Math/NumberTheory/EisensteinIntegersTests.hs b/test-suite/Math/NumberTheory/EisensteinIntegersTests.hs new file mode 100644 --- /dev/null +++ b/test-suite/Math/NumberTheory/EisensteinIntegersTests.hs @@ -0,0 +1,208 @@ +{-# OPTIONS_GHC -fno-warn-type-defaults #-} + +-- | +-- Module: Math.NumberTheory.EisensteinIntegersTests +-- Copyright: (c) 2018 Alexandre Rodrigues Baldé +-- Licence: MIT +-- Maintainer: Alexandre Rodrigues Baldé Bool +signumAbsProperty z = z == signum z * abs z + +-- | Check that @abs@ maps an @EisensteinInteger@ to its associate in first +-- sextant. +absProperty :: E.EisensteinInteger -> Bool +absProperty z = isOrigin || (inFirstSextant && isAssociate) + where + z'@(x' E.:+ y') = abs z + isOrigin = z' == 0 && z == 0 + -- The First sextant includes the positive real axis, but not the origin + -- or the line defined by the linear equation @y = (sqrt 3) * x@ in the + -- Cartesian plane. + inFirstSextant = x' > y' && y' >= 0 + isAssociate = z' `elem` map (\e -> z * (1 E.:+ 1) ^ e) [0 .. 5] + +-- | Verify that @div@ and @mod@ are what `divMod` produces. +divModProperty1 :: E.EisensteinInteger -> E.EisensteinInteger -> Bool +divModProperty1 x y = y == 0 || (q == q' && r == r') + where + (q, r) = ED.divMod x y + q' = ED.div x y + r' = ED.mod x y + +-- | Verify that @divModE` produces the right quotient and remainder. +divModProperty2 :: E.EisensteinInteger -> E.EisensteinInteger -> Bool +divModProperty2 x y = (y == 0) || (x `ED.div` y) * y + (x `ED.mod` y) == x + +-- | Verify that @divModE@ produces a remainder smaller than the divisor with +-- regards to the Euclidean domain's function. +modProperty1 :: E.EisensteinInteger -> E.EisensteinInteger -> Bool +modProperty1 x y = (y == 0) || (E.norm $ x `ED.mod` y) < (E.norm y) + +-- | Verify that @quot@ and @rem@ are what `quotRem` produces. +quotRemProperty1 :: E.EisensteinInteger -> E.EisensteinInteger -> Bool +quotRemProperty1 x y = (y == 0) || q == q' && r == r' + where + (q, r) = ED.quotRem x y + q' = ED.quot x y + r' = ED.rem x y + +-- | Verify that @quotRemE@ produces the right quotient and remainder. +quotRemProperty2 :: E.EisensteinInteger -> E.EisensteinInteger -> Bool +quotRemProperty2 x y = (y == 0) || (x `ED.quot` y) * y + (x `ED.rem` y) == x + +-- | Verify that @gcd z1 z2@ always divides @z1@ and @z2@. +gcdEProperty1 :: E.EisensteinInteger -> E.EisensteinInteger -> Bool +gcdEProperty1 z1 z2 + = z1 == 0 && z2 == 0 + || z1 `ED.rem` z == 0 && z2 `ED.rem` z == 0 && z == abs z + where + z = ED.gcd z1 z2 + +-- | Verify that a common divisor of @z1, z2@ is a always divisor of @gcd z1 z2@. +gcdEProperty2 :: E.EisensteinInteger -> E.EisensteinInteger -> E.EisensteinInteger -> Bool +gcdEProperty2 z z1 z2 + = z == 0 + || (ED.gcd z1' z2') `ED.rem` z == 0 + where + z1' = z * z1 + z2' = z * z2 + +-- | A special case that tests rounding/truncating in GCD. +gcdESpecialCase1 :: Assertion +gcdESpecialCase1 = assertEqual "gcd" 1 $ ED.gcd (12 E.:+ 23) (23 E.:+ 34) + +findPrimesProperty1 :: Positive Int -> Bool +findPrimesProperty1 (Positive index) = + let -- Only retain primes that are of the form @6k + 1@, for some nonzero natural @k@. + prop prime = prime `mod` 6 == 1 + p = (!! index) $ filter prop $ drop 3 primes + in E.isPrime $ E.findPrime p + +-- | Checks that the @norm@ of the Euclidean domain of Eisenstein integers +-- is multiplicative i.e. +-- @forall e1 e2 in Z[ω] . norm(e1 * e2) == norm(e1) * norm(e2)@. +euclideanDomainProperty1 :: E.EisensteinInteger -> E.EisensteinInteger -> Bool +euclideanDomainProperty1 e1 e2 = E.norm (e1 * e2) == E.norm e1 * E.norm e2 + +-- | Checks that the numbers produced by @primes@ are actually Eisenstein +-- primes. +primesProperty1 :: Positive Int -> Bool +primesProperty1 (Positive index) = all E.isPrime $ take index $ E.primes + +-- | Checks that the infinite list of Eisenstein primes @primes@ is ordered +-- by the numbers' norm. +primesProperty2 :: Positive Int -> Bool +primesProperty2 (Positive index) = + let isOrdered :: [E.EisensteinInteger] -> Bool + isOrdered xs = all (\(x,y) -> E.norm x <= E.norm y) . zip xs $ tail xs + in isOrdered $ take index E.primes + +-- | Checks that the numbers produced by @primes@ are all in the first +-- sextant. +primesProperty3 :: Positive Int -> Bool +primesProperty3 (Positive index) = + all (\e -> abs e == e) $ take index $ E.primes + +-- | An Eisenstein integer is either zero or associated (i.e. equal up to +-- multiplication by a unit) to the product of its factors raised to their +-- respective exponents. +factoriseProperty1 :: E.EisensteinInteger -> Bool +factoriseProperty1 g = g == 0 || abs g == abs g' + where + factors = E.factorise g + g' = product $ map (uncurry (^)) factors + +-- | Check that there are no factors with exponent @0@ in the factorisation. +factoriseProperty2 :: E.EisensteinInteger -> Bool +factoriseProperty2 z = z == 0 || all ((> 0) . snd) (E.factorise z) + +-- | Check that no factor produced by @factorise@ is a unit. +factoriseProperty3 :: E.EisensteinInteger -> Bool +factoriseProperty3 z = z == 0 || all ((> 1) . E.norm . fst) (E.factorise z) + +-- | Check that every prime factor in the factorisation is primary, excluding +-- @1 - ω@, if it is a factor. +factoriseProperty4 :: E.EisensteinInteger -> Bool +factoriseProperty4 z = + z == 0 || + (all (\e -> e `ED.mod` 3 == 2) $ + filter (\e -> not $ elem e $ E.associates $ 1 E.:+ (-1)) $ + map fst $ E.factorise z) + +factoriseSpecialCase1 :: Assertion +factoriseSpecialCase1 = assertEqual "should be equal" + [(2 E.:+ 1, 3), (2 E.:+ 3, 1)] + (E.factorise (15 E.:+ 12)) + +testSuite :: TestTree +testSuite = testGroup "EisensteinIntegers" $ + [ testSmallAndQuick "forall z . z == signum z * abs z" signumAbsProperty + , testSmallAndQuick "abs z always returns an @EisensteinInteger@ in the\ + \ first sextant of the complex plane" absProperty + , testGroup "Division" + [ testSmallAndQuick "divE and modE work properly" divModProperty1 + , testSmallAndQuick "divModE works properly" divModProperty2 + , testSmallAndQuick "The remainder's norm is smaller than the divisor's" + modProperty1 + + , testSmallAndQuick "quotE and remE work properly" quotRemProperty1 + , testSmallAndQuick "quotRemE works properly" quotRemProperty2 + ] + + , testGroup "g.c.d." + [ testSmallAndQuick "The g.c.d. of two Eisenstein integers divides them" + gcdEProperty1 + , testSmallAndQuick "A common divisor of two Eisenstein integers always\ + \ divides the g.c.d. of those two integers" + gcdEProperty2 + , testCase "g.c.d. (12 :+ 23) (23 :+ 34)" gcdESpecialCase1 + ] + , testSmallAndQuick "The Eisenstein norm function is multiplicative" + euclideanDomainProperty1 + , testGroup "Primality" + [ testSmallAndQuick "Eisenstein primes found by the norm search used in\ + \ findPrime are really prime" + findPrimesProperty1 + , testSmallAndQuick "Eisenstein primes generated by `primes` are actually\ + \ primes" + primesProperty1 + , testSmallAndQuick "The infinite list of Eisenstein primes produced by\ + \ `primes` is ordered. " + primesProperty2 + , testSmallAndQuick "All generated primes are in the first sextant" + primesProperty3 + ] + + , testGroup "Factorisation" + [ testSmallAndQuick "factorise produces correct results" + factoriseProperty1 + , testSmallAndQuick "factorise produces no factors with exponent 0" + factoriseProperty2 + , testSmallAndQuick "factorise produces no unit factors" + factoriseProperty3 + , testSmallAndQuick "factorise only produces primary primes" + factoriseProperty4 + , testCase "factorise 15:+12" factoriseSpecialCase1 + ] + ] diff --git a/test-suite/Math/NumberTheory/GCD/LowLevelTests.hs b/test-suite/Math/NumberTheory/GCD/LowLevelTests.hs deleted file mode 100644 --- a/test-suite/Math/NumberTheory/GCD/LowLevelTests.hs +++ /dev/null @@ -1,74 +0,0 @@ --- | --- Module: Math.NumberTheory.GCD.LowLevelTests --- Copyright: (c) 2016 Andrew Lelechenko --- Licence: MIT --- Maintainer: Andrew Lelechenko --- Stability: Provisional --- --- Tests for Math.NumberTheory.GCD.LowLevel --- - -{-# LANGUAGE CPP #-} -{-# LANGUAGE MagicHash #-} - -{-# OPTIONS_GHC -fno-warn-type-defaults #-} - -module Math.NumberTheory.GCD.LowLevelTests - ( testSuite - ) where - -import Test.Tasty - -#if MIN_VERSION_base(4,8,0) -#else -import Data.Word -#endif - -import GHC.Exts - -import Math.NumberTheory.GCD.LowLevel -import Math.NumberTheory.TestUtils - --- | Check that 'gcdInt' matches 'gcd'. -gcdIntProperty :: Int -> Int -> Bool -gcdIntProperty a b = gcdInt a b == gcd a b - --- | Check that 'gcdWord' matches 'gcd'. -gcdWordProperty :: Word -> Word -> Bool -gcdWordProperty a b = gcdWord a b == gcd a b - --- | Check that 'gcdInt#' matches 'gcd'. -gcdIntProperty# :: Int -> Int -> Bool -gcdIntProperty# a@(I# a') b@(I# b') = I# (gcdInt# a' b') == gcd a b - --- | Check that 'gcdWord#' matches 'gcd'. -gcdWordProperty# :: Word -> Word -> Bool -gcdWordProperty# a@(W# a') b@(W# b') = W# (gcdWord# a' b') == gcd a b - --- | Check that numbers are coprime iff their gcd equals to 1. -coprimeIntProperty :: Int -> Int -> Bool -coprimeIntProperty a b = coprimeInt a b == (gcd a b == 1) - --- | Check that numbers are coprime iff their gcd equals to 1. -coprimeWordProperty :: Word -> Word -> Bool -coprimeWordProperty a b = coprimeWord a b == (gcd a b == 1) - --- | Check that numbers are coprime iff their gcd equals to 1. -coprimeIntProperty# :: Int -> Int -> Bool -coprimeIntProperty# a@(I# a') b@(I# b') = coprimeInt# a' b' == (gcd a b == 1) - --- | Check that numbers are coprime iff their gcd equals to 1. -coprimeWordProperty# :: Word -> Word -> Bool -coprimeWordProperty# a@(W# a') b@(W# b') = coprimeWord# a' b' == (gcd a b == 1) - -testSuite :: TestTree -testSuite = testGroup "LowLevel" - [ testSmallAndQuick "gcdInt" gcdIntProperty - , testSmallAndQuick "gcdWord" gcdWordProperty - , testSmallAndQuick "gcdInt#" gcdIntProperty# - , testSmallAndQuick "gcdWord#" gcdWordProperty# - , testSmallAndQuick "coprimeInt" coprimeIntProperty - , testSmallAndQuick "coprimeWord" coprimeWordProperty - , testSmallAndQuick "coprimeInt#" coprimeIntProperty# - , testSmallAndQuick "coprimeWord#" coprimeWordProperty# - ] diff --git a/test-suite/Math/NumberTheory/GCDTests.hs b/test-suite/Math/NumberTheory/GCDTests.hs --- a/test-suite/Math/NumberTheory/GCDTests.hs +++ b/test-suite/Math/NumberTheory/GCDTests.hs @@ -11,7 +11,9 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -fno-warn-type-defaults #-} +{-# OPTIONS_GHC -fno-warn-type-defaults #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +{-# OPTIONS_GHC -fno-warn-deprecations #-} module Math.NumberTheory.GCDTests ( testSuite @@ -22,13 +24,11 @@ import Control.Arrow import Data.Bits -import Data.List (tails) -#if MIN_VERSION_base(4,8,0) -#else -import Data.Word -#endif +import Data.Semigroup +import Data.List (tails, sort) import Numeric.Natural +import Math.NumberTheory.Euclidean.Coprimes import Math.NumberTheory.GCD import Math.NumberTheory.TestUtils @@ -52,13 +52,13 @@ coprimeProperty (AnySign a) (AnySign b) = coprime a b == (gcd a b == 1) splitIntoCoprimesProperty1 :: [(Positive Natural, Power Word)] -> Bool -splitIntoCoprimesProperty1 fs' = factorback fs == factorback (splitIntoCoprimes fs) +splitIntoCoprimesProperty1 fs' = factorback fs == factorback (unCoprimes $ splitIntoCoprimes fs) where fs = map (getPositive *** getPower) fs' factorback = product . map (uncurry (^)) splitIntoCoprimesProperty2 :: [(Positive Natural, Power Word)] -> Bool -splitIntoCoprimesProperty2 fs' = multiplicities fs <= multiplicities (splitIntoCoprimes fs) +splitIntoCoprimesProperty2 fs' = multiplicities fs <= multiplicities (unCoprimes $ splitIntoCoprimes fs) where fs = map (getPositive *** getPower) fs' multiplicities = sum . map snd . filter ((/= 1) . fst) @@ -66,7 +66,7 @@ splitIntoCoprimesProperty3 :: [(Positive Natural, Power Word)] -> Bool splitIntoCoprimesProperty3 fs' = and [ coprime x y | (x : xs) <- tails fs, y <- xs ] where - fs = map fst $ splitIntoCoprimes $ map (getPositive *** getPower) fs' + fs = map fst $ unCoprimes $ splitIntoCoprimes $ map (getPositive *** getPower) fs' -- | Check that evaluation never freezes. splitIntoCoprimesProperty4 :: [(Integer, Word)] -> Bool @@ -86,6 +86,43 @@ splitIntoCoprimesSpecialCase2 = assertBool "should not fail" $ splitIntoCoprimesProperty4 [(0, 1), (-2, 0)] +toListReturnsCorrectValues :: Assertion +toListReturnsCorrectValues = assertEqual + "should be equal" + (sort $ unCoprimes $ splitIntoCoprimes [(140, 1), (165, 1)]) + ([(5,2),(28,1),(33,1)] :: [(Integer, Word)]) + +unionReturnsCorrectValues :: Assertion +unionReturnsCorrectValues = assertEqual "should be equal" expected actual + where + a :: Coprimes Integer Word + a = splitIntoCoprimes [(700, 1), (165, 1)] -- [(5,3),(28,1),(33,1)] + b = splitIntoCoprimes [(360, 1), (210, 1)] -- [(2,4),(3,3),(5,2),(7,1)] + expected = [(2,6),(3,4),(5,5),(7,2),(11,1)] + actual = sort $ unCoprimes (a <> b) + +insertReturnsCorrectValuesWhenCoprimeBase :: Assertion +insertReturnsCorrectValuesWhenCoprimeBase = + let a = insert 5 2 (singleton 4 3) + expected = [(4,3), (5,2)] + actual = sort $ unCoprimes a :: [(Int, Int)] + in assertEqual "should be equal" expected actual + +insertReturnsCorrectValuesWhenNotCoprimeBase :: Assertion +insertReturnsCorrectValuesWhenNotCoprimeBase = + let a = insert 2 4 (insert 7 1 (insert 5 2 (singleton 4 3))) + actual = sort $ unCoprimes a :: [(Int, Int)] + expected = [(2,10), (5,2), (7,1)] + in assertEqual "should be equal" expected actual + +unionProperty1 :: [(Positive Natural, Power Word)] -> [(Positive Natural, Power Word)] -> Bool +unionProperty1 xs ys + = sort (unCoprimes (splitIntoCoprimes (xs' <> ys'))) + == sort (unCoprimes (splitIntoCoprimes xs' <> splitIntoCoprimes ys')) + where + xs' = map (getPositive *** getPower) xs + ys' = map (getPositive *** getPower) ys + testSuite :: TestTree testSuite = testGroup "GCD" [ testSameIntegralProperty "binaryGCD" binaryGCDProperty @@ -99,5 +136,12 @@ , testCase "does not freeze 1" splitIntoCoprimesSpecialCase1 , testCase "does not freeze 2" splitIntoCoprimesSpecialCase2 , testSmallAndQuick "does not freeze random" splitIntoCoprimesProperty4 + ] + , testGroup "Coprimes" + [ testCase "test equality" toListReturnsCorrectValues + , testCase "test union" unionReturnsCorrectValues + , testCase "test insert with coprime base" insertReturnsCorrectValuesWhenCoprimeBase + , testCase "test insert with non-coprime base" insertReturnsCorrectValuesWhenNotCoprimeBase + , testSmallAndQuick "property union" unionProperty1 ] ] diff --git a/test-suite/Math/NumberTheory/GaussianIntegersTests.hs b/test-suite/Math/NumberTheory/GaussianIntegersTests.hs --- a/test-suite/Math/NumberTheory/GaussianIntegersTests.hs +++ b/test-suite/Math/NumberTheory/GaussianIntegersTests.hs @@ -15,10 +15,15 @@ ) where import Control.Monad (zipWithM_) +import Data.List (groupBy, sort) import Test.Tasty import Test.Tasty.HUnit -import Math.NumberTheory.GaussianIntegers +import qualified Math.NumberTheory.Euclidean as ED +import Math.NumberTheory.Quadratic.GaussianIntegers +import Math.NumberTheory.Moduli.Sqrt +import Math.NumberTheory.Powers (integerSquareRoot) +import Math.NumberTheory.UniqueFactorisation (unPrime) import Math.NumberTheory.TestUtils lazyCases :: [(GaussianInteger, [(GaussianInteger, Int)])] @@ -26,69 +31,140 @@ [ ( 14145130733 * 10000000000000000000000000000000000000121 * 100000000000000000000000000000000000000000000000447 - , [(21037 :+ 117058, 1), (117058 :+ 21037, 1)] + , [(117058 :+ 21037, 1), (21037 :+ 117058, 1)] ) ] -- | Number is zero or is equal to the product of its factors. -factoriseProperty1 :: Integer -> Integer -> Bool -factoriseProperty1 x y - = x == 0 && y == 0 - || g == g' +factoriseProperty1 :: GaussianInteger -> Bool +factoriseProperty1 g + = g == 0 + || abs g == abs g' where - g = x :+ y factors = factorise g - g' = product $ map (uncurry (.^)) factors + g' = product $ map (uncurry (^)) factors -factoriseProperty2 :: (GaussianInteger, [(GaussianInteger, Int)]) -> Assertion -factoriseProperty2 (n, fs) = zipWithM_ (assertEqual (show n)) fs (factorise n) +factoriseProperty2 :: GaussianInteger -> Bool +factoriseProperty2 z = z == 0 || all ((> 0) . snd) (factorise z) +factoriseProperty3 :: GaussianInteger -> Bool +factoriseProperty3 z = z == 0 || all ((> 1) . norm . fst) (factorise z) + +factoriseSpecialCase1 :: Assertion +factoriseSpecialCase1 = assertEqual "should be equal" + [(3, 2), (1 :+ 2, 1), (2 :+ 3, 1)] + (factorise (63 :+ 36)) + +factoriseSpecialCase2 :: (GaussianInteger, [(GaussianInteger, Int)]) -> Assertion +factoriseSpecialCase2 (n, fs) = zipWithM_ (assertEqual (show n)) fs (factorise n) + +findPrimeReference :: PrimeWrapper Integer -> GaussianInteger +findPrimeReference (PrimeWrapper p) = + let c : _ = sqrtsModPrime (-1) p + k = integerSquareRoot (unPrime p) + bs = [1 .. k] + asbs = map (\b' -> ((b' * c) `mod` (unPrime p), b')) bs + (a, b) = head [ (a', b') | (a', b') <- asbs, a' <= k] + in a :+ b + +findPrimeProperty1 :: PrimeWrapper Integer -> Bool +findPrimeProperty1 p'@(PrimeWrapper p) + = unPrime p `mod` 4 /= (1 :: Integer) + || p1 == p2 + || abs (p1 * p2) == fromInteger (unPrime p) + where + p1 = findPrimeReference p' + p2 = findPrime (unPrime p) + -- | Number is prime iff it is non-zero -- and has exactly one (non-unit) factor. -isPrimeProperty :: Integer -> Integer -> Bool -isPrimeProperty x y - = x == 0 && y == 0 +isPrimeProperty :: GaussianInteger -> Bool +isPrimeProperty g + = g == 0 || isPrime g && n == 1 || not (isPrime g) && n /= 1 where - g = x :+ y factors = factorise g - nonUnitFactors = filter (\(p, _) -> norm p /= 1) factors -- Count factors taking into account multiplicity - n = sum $ map snd nonUnitFactors + n = sum $ map snd factors +primesSpecialCase1 :: Assertion +primesSpecialCase1 = assertEqual "primes" + (f [1+ι,2+ι,1+2*ι,3,3+2*ι,2+3*ι,4+ι,1+4*ι,5+2*ι,2+5*ι,6+ι,1+6*ι,5+4*ι,4+5*ι,7,7+2*ι,2+7*ι,6+5*ι,5+6*ι,8+3*ι,3+8*ι,8+5*ι,5+8*ι,9+4*ι,4+9*ι,10+ι,1+10*ι,10+3*ι,3+10*ι,8+7*ι,7+8*ι,11,11+4*ι,4+11*ι,10+7*ι,7+10*ι,11+6*ι,6+11*ι,13+2*ι,2+13*ι,10+9*ι,9+10*ι,12+7*ι,7+12*ι,14+ι,1+14*ι,15+2*ι,2+15*ι,13+8*ι,8+13*ι,15+4*ι]) + (f $ take 51 primes) + where + f :: [GaussianInteger] -> [[GaussianInteger]] + f = map sort . groupBy (\g1 g2 -> norm g1 == norm g2) + -- | The list of primes should include only primes. primesGeneratesPrimesProperty :: NonNegative Int -> Bool primesGeneratesPrimesProperty (NonNegative i) = isPrime (primes !! i) +-- | Check that primes generates the primes in order. +orderingPrimes :: Assertion +orderingPrimes = assertBool "primes are ordered" (and $ zipWith (<=) xs (tail xs)) + where xs = map norm $ take 1000 primes + +numberOfPrimes :: Assertion +numberOfPrimes = assertEqual "counting primes: OEIS A091100" + [16,100,668,4928,38404,313752,2658344] + [4 * (length $ takeWhile ((<= 10^n) . norm) primes) | n <- [1..7]] + -- | signum and abs should satisfy: z == signum z * abs z -signumAbsProperty :: Integer -> Integer -> Bool -signumAbsProperty x y = z == signum z * abs z - where - z = x :+ y +signumAbsProperty :: GaussianInteger -> Bool +signumAbsProperty z = z == signum z * abs z -- | abs maps a Gaussian integer to its associate in first quadrant. -absProperty :: Integer -> Integer -> Bool -absProperty x y = isOrigin || (inFirstQuadrant && isAssociate) +absProperty :: GaussianInteger -> Bool +absProperty z = isOrigin || (inFirstQuadrant && isAssociate) where - z = x :+ y z'@(x' :+ y') = abs z isOrigin = z' == 0 && z == 0 inFirstQuadrant = x' > 0 && y' >= 0 -- first quadrant includes the positive real axis, but not the origin or the positive imaginary axis - isAssociate = z' `elem` map (\e -> z * (0 :+ 1) .^ e) [0 .. 3] + isAssociate = z' `elem` map (\e -> z * (0 :+ 1) ^ e) [0 .. 3] +gcdGProperty1 :: GaussianInteger -> GaussianInteger -> Bool +gcdGProperty1 z1 z2 + = z1 == 0 && z2 == 0 + || z1 `ED.rem` z == 0 && z2 `ED.rem` z == 0 && z == abs z + where + z = ED.gcd z1 z2 + +gcdGProperty2 :: GaussianInteger -> GaussianInteger -> GaussianInteger -> Bool +gcdGProperty2 z z1 z2 + = z == 0 + || (ED.gcd z1' z2') `ED.rem` z == 0 + where + z1' = z * z1 + z2' = z * z2 + -- | a special case that tests rounding/truncating in GCD. gcdGSpecialCase1 :: Assertion -gcdGSpecialCase1 = assertEqual "gcdG" 1 $ gcdG (12 :+ 23) (23 :+ 34) +gcdGSpecialCase1 = assertEqual "gcdG" 1 $ ED.gcd (12 :+ 23) (23 :+ 34) testSuite :: TestTree testSuite = testGroup "GaussianIntegers" $ - [ testSmallAndQuick "factorise" factoriseProperty1 - , testSmallAndQuick "isPrime" isPrimeProperty - , testSmallAndQuick "primes" primesGeneratesPrimesProperty - , testSmallAndQuick "signumAbsProperty" signumAbsProperty - , testSmallAndQuick "absProperty" absProperty - , testCase "gcdG (12 :+ 23) (23 :+ 34)" gcdGSpecialCase1 + [ testGroup "factorise" ( + [ testSmallAndQuick "factor back" factoriseProperty1 + , testSmallAndQuick "powers are > 0" factoriseProperty2 + , testSmallAndQuick "factors are > 1" factoriseProperty3 + , testCase "factorise 63:+36" factoriseSpecialCase1 + ] + ++ + map (\x -> testCase ("laziness " ++ show (fst x)) (factoriseSpecialCase2 x)) + lazyCases) + + , testSmallAndQuick "findPrime'" findPrimeProperty1 + , testSmallAndQuick "isPrime" isPrimeProperty + , testCase "primes matches reference" primesSpecialCase1 + , testSmallAndQuick "primes" primesGeneratesPrimesProperty + , testCase "primes are ordered" orderingPrimes + , testCase "counting primes" numberOfPrimes + , testSmallAndQuick "signumAbsProperty" signumAbsProperty + , testSmallAndQuick "absProperty" absProperty + , testGroup "gcd" + [ testSmallAndQuick "is divisor" gcdGProperty1 + , testSmallAndQuick "is greatest" gcdGProperty2 + , testCase "(12 :+ 23) (23 :+ 34)" gcdGSpecialCase1 + ] ] - ++ - map (\x -> testCase ("laziness " ++ show (fst x)) (factoriseProperty2 x)) lazyCases diff --git a/test-suite/Math/NumberTheory/Moduli/ClassTests.hs b/test-suite/Math/NumberTheory/Moduli/ClassTests.hs --- a/test-suite/Math/NumberTheory/Moduli/ClassTests.hs +++ b/test-suite/Math/NumberTheory/Moduli/ClassTests.hs @@ -19,7 +19,6 @@ import Test.Tasty -import Data.Bits import Data.Maybe import Numeric.Natural @@ -40,7 +39,7 @@ Just (SomeMod inv) -> gcd k m == 1 && k * getVal inv `mod` m == 1 -- | Check that 'powerMod' is multiplicative by first argument. -powerModProperty2 :: (Integral a, Bits a) => NonNegative a -> AnySign Integer -> AnySign Integer -> Positive Integer -> Bool +powerModProperty2 :: (Integral a) => NonNegative a -> AnySign Integer -> AnySign Integer -> Positive Integer -> Bool powerModProperty2 (NonNegative e) (AnySign b1) (AnySign b2) (Positive m) = e < 0 && (isNothing (invertMod b1 m) || isNothing (invertMod b2 m)) || pm1 * pm2 == pm12 @@ -50,7 +49,7 @@ pm12 = powerMod (b1 * b2) e m -- | Check that 'powerMod' is additive by second argument. -powerModProperty3 :: (Integral a, Bits a) => NonNegative a -> NonNegative a -> AnySign Integer -> Positive Integer -> Bool +powerModProperty3 :: (Integral a) => NonNegative a -> NonNegative a -> AnySign Integer -> Positive Integer -> Bool powerModProperty3 (NonNegative e1) (NonNegative e2) (AnySign b) (Positive m) = (e1 < 0 || e2 < 0) && isNothing (invertMod b m) || e2 >= 0 && e1 + e2 < e1 -- check overflow diff --git a/test-suite/Math/NumberTheory/Moduli/DiscreteLogarithmTests.hs b/test-suite/Math/NumberTheory/Moduli/DiscreteLogarithmTests.hs new file mode 100644 --- /dev/null +++ b/test-suite/Math/NumberTheory/Moduli/DiscreteLogarithmTests.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DataKinds #-} +{-# OPTIONS_GHC -fno-warn-type-defaults #-} +module Math.NumberTheory.Moduli.DiscreteLogarithmTests + ( testSuite + ) where + +import Data.Maybe +import Numeric.Natural +import Test.Tasty +import Data.Semigroup +import Data.Proxy +import GHC.TypeNats.Compat + +import Math.NumberTheory.Moduli.Class +import Math.NumberTheory.Moduli.PrimitiveRoot +import Math.NumberTheory.Moduli.DiscreteLogarithm +import Math.NumberTheory.ArithmeticFunctions (totient) +import Math.NumberTheory.TestUtils + +-- | Ensure 'discreteLogarithm' returns in the appropriate range. +discreteLogRange :: Positive Natural -> Integer -> Integer -> Bool +discreteLogRange (Positive m) a b = + case someNatVal m of + SomeNat (_ :: Proxy m) -> fromMaybe True $ do + a' <- isPrimitiveRoot (fromInteger a :: Mod m) + b' <- isMultElement (fromInteger b) + return $ discreteLogarithm a' b' < totient m + +-- | Check that 'discreteLogarithm' inverts exponentiation. +discreteLogarithmProperty :: Positive Natural -> Integer -> Integer -> Bool +discreteLogarithmProperty (Positive m) a b = + case someNatVal m of + SomeNat (_ :: Proxy m) -> fromMaybe True $ do + a' <- isPrimitiveRoot (fromInteger a :: Mod m) + b' <- isMultElement (fromInteger b) + return $ discreteLogarithm a' b' `stimes` unPrimitiveRoot a' == b' + +-- | Check that 'discreteLogarithm' inverts exponentiation in the other direction. +discreteLogarithmProperty' :: Positive Natural -> Integer -> Natural -> Bool +discreteLogarithmProperty' (Positive m) a k = + case someNatVal m of + SomeNat (_ :: Proxy m) -> fromMaybe True $ do + a'' <- isPrimitiveRoot (fromInteger a :: Mod m) + let a' = unPrimitiveRoot a'' + return $ discreteLogarithm a'' (k `stimes` a') == k `mod` totient m + +testSuite :: TestTree +testSuite = testGroup "Discrete logarithm" + [ testSmallAndQuick "output is correct range" discreteLogRange + , testSmallAndQuick "a^(log_a b) == b" discreteLogarithmProperty + , testSmallAndQuick "log_a a^k == k" discreteLogarithmProperty' + ] diff --git a/test-suite/Math/NumberTheory/Moduli/EquationsTests.hs b/test-suite/Math/NumberTheory/Moduli/EquationsTests.hs new file mode 100644 --- /dev/null +++ b/test-suite/Math/NumberTheory/Moduli/EquationsTests.hs @@ -0,0 +1,47 @@ +-- | +-- Module: Math.NumberTheory.Moduli.EquationsTests +-- Copyright: (c) 2018 Andrew Lelechenko +-- Licence: MIT +-- Maintainer: Andrew Lelechenko +-- Stability: Provisional +-- Portability: Non-portable (GHC extensions) +-- + +{-# LANGUAGE ScopedTypeVariables #-} + +module Math.NumberTheory.Moduli.EquationsTests + ( testSuite + ) where + +import Test.Tasty + +import Data.List +import Data.Proxy +import GHC.TypeNats.Compat +import Numeric.Natural + +import Math.NumberTheory.Moduli.Class +import Math.NumberTheory.Moduli.Equations +import Math.NumberTheory.TestUtils + +solveLinearProp :: KnownNat m => Mod m -> Mod m -> Bool +solveLinearProp a b = sort (solveLinear a b) == + filter (\x -> a * x + b == 0) [minBound .. maxBound] + +solveLinearProperty1 :: Positive Natural -> Integer -> Integer -> Bool +solveLinearProperty1 (Positive m) a b = case someNatVal m of + SomeNat (_ :: Proxy t) -> solveLinearProp (fromInteger a :: Mod t) (fromInteger b) + +solveQuadraticProp :: KnownNat m => Mod m -> Mod m -> Mod m -> Bool +solveQuadraticProp a b c = sort (solveQuadratic a b c) == + filter (\x -> a * x * x + b * x + c == 0) [minBound .. maxBound] + +solveQuadraticProperty1 :: Positive Natural -> Integer -> Integer -> Integer -> Bool +solveQuadraticProperty1 (Positive m) a b c = case someNatVal m of + SomeNat (_ :: Proxy t) -> solveQuadraticProp (fromInteger a :: Mod t) (fromInteger b) (fromInteger c) + +testSuite :: TestTree +testSuite = testGroup "Equations" + [ testSmallAndQuick "solveLinear" solveLinearProperty1 + , testSmallAndQuick "solveQuadratic" solveQuadraticProperty1 + ] diff --git a/test-suite/Math/NumberTheory/Moduli/JacobiTests.hs b/test-suite/Math/NumberTheory/Moduli/JacobiTests.hs --- a/test-suite/Math/NumberTheory/Moduli/JacobiTests.hs +++ b/test-suite/Math/NumberTheory/Moduli/JacobiTests.hs @@ -23,6 +23,7 @@ #if __GLASGOW_HASKELL__ < 803 import Data.Semigroup #endif +import Numeric.Natural import Math.NumberTheory.Moduli hiding (invertMod) import Math.NumberTheory.TestUtils @@ -40,29 +41,90 @@ Zero -> a `gcd` n /= 1 One -> a `gcd` n == 1 +doesProductOverflow :: Integral a => a -> a -> Bool +doesProductOverflow x y = abs (toInteger (x * y)) < abs (toInteger x * toInteger y) + -- https://en.wikipedia.org/wiki/Jacobi_symbol#Properties, item 4 jacobiProperty4 :: (Integral a, Bits a) => AnySign a -> AnySign a -> (MyCompose Positive Odd) a -> Bool -jacobiProperty4 (AnySign a) (AnySign b) (MyCompose (Positive (Odd n))) = jacobi (a * b) n == jacobi a n <> jacobi b n +jacobiProperty4 (AnySign a) (AnySign b) (MyCompose (Positive (Odd n))) = + doesProductOverflow a b || + jacobi (a * b) n == jacobi a n <> jacobi b n +jacobiProperty4_Int :: AnySign Int -> AnySign Int -> (MyCompose Positive Odd) Int -> Bool +jacobiProperty4_Int = jacobiProperty4 + +jacobiProperty4_Word :: AnySign Word -> AnySign Word -> (MyCompose Positive Odd) Word -> Bool +jacobiProperty4_Word = jacobiProperty4 + jacobiProperty4_Integer :: AnySign Integer -> AnySign Integer -> (MyCompose Positive Odd) Integer -> Bool jacobiProperty4_Integer = jacobiProperty4 +jacobiProperty4_Natural :: AnySign Natural -> AnySign Natural -> (MyCompose Positive Odd) Natural -> Bool +jacobiProperty4_Natural = jacobiProperty4 + -- https://en.wikipedia.org/wiki/Jacobi_symbol#Properties, item 5 jacobiProperty5 :: (Integral a, Bits a) => AnySign a -> (MyCompose Positive Odd) a -> (MyCompose Positive Odd) a -> Bool -jacobiProperty5 (AnySign a) (MyCompose (Positive (Odd m))) (MyCompose (Positive (Odd n))) = jacobi a (m * n) == jacobi a m <> jacobi a n +jacobiProperty5 (AnySign a) (MyCompose (Positive (Odd m))) (MyCompose (Positive (Odd n))) = + doesProductOverflow m n || + jacobi a (m * n) == jacobi a m <> jacobi a n +jacobiProperty5_Int :: AnySign Int -> (MyCompose Positive Odd) Int -> (MyCompose Positive Odd) Int -> Bool +jacobiProperty5_Int = jacobiProperty5 + +jacobiProperty5_Word :: AnySign Word -> (MyCompose Positive Odd) Word -> (MyCompose Positive Odd) Word -> Bool +jacobiProperty5_Word = jacobiProperty5 + jacobiProperty5_Integer :: AnySign Integer -> (MyCompose Positive Odd) Integer -> (MyCompose Positive Odd) Integer -> Bool jacobiProperty5_Integer = jacobiProperty5 +jacobiProperty5_Natural :: AnySign Natural -> (MyCompose Positive Odd) Natural -> (MyCompose Positive Odd) Natural -> Bool +jacobiProperty5_Natural = jacobiProperty5 + -- https://en.wikipedia.org/wiki/Jacobi_symbol#Properties, item 6 jacobiProperty6 :: (Integral a, Bits a) => (MyCompose Positive Odd) a -> (MyCompose Positive Odd) a -> Bool jacobiProperty6 (MyCompose (Positive (Odd m))) (MyCompose (Positive (Odd n))) = gcd m n /= 1 || jacobi m n <> jacobi n m == (if m `mod` 4 == 1 || n `mod` 4 == 1 then One else MinusOne) +-- https://en.wikipedia.org/wiki/Jacobi_symbol#Properties, item 7 +jacobiProperty7 :: (Integral a, Bits a) => (MyCompose Positive Odd) a -> Bool +jacobiProperty7 (MyCompose (Positive (Odd n))) = + jacobi (-1) n == if n `mod` 4 == 1 then One else MinusOne + +jacobiProperty7_Int :: (MyCompose Positive Odd) Int -> Bool +jacobiProperty7_Int = jacobiProperty7 + +jacobiProperty7_Integer :: (MyCompose Positive Odd) Integer -> Bool +jacobiProperty7_Integer = jacobiProperty7 + +-- https://en.wikipedia.org/wiki/Jacobi_symbol#Properties, item 8 +jacobiProperty8 :: (Integral a, Bits a) => (MyCompose Positive Odd) a -> Bool +jacobiProperty8 (MyCompose (Positive (Odd n))) = + even n || + jacobi 2 n == if n `mod` 8 == 1 || n `mod` 8 == 7 then One else MinusOne + +jacobiProperty9 :: (Integral a, Bits a, Bounded a) => (MyCompose Positive Odd) a -> Bool +jacobiProperty9 (MyCompose (Positive (Odd n))) = + jacobi m n == jacobi (toInteger m) (toInteger n) + where + m = minBound + +jacobiProperty9_Int :: (MyCompose Positive Odd) Int -> Bool +jacobiProperty9_Int = jacobiProperty9 + testSuite :: TestTree testSuite = testGroup "Jacobi" [ testSameIntegralProperty "same modulo n" jacobiProperty2 , testSameIntegralProperty "consistent with gcd" jacobiProperty3 - , testSmallAndQuick "multiplicative 1" jacobiProperty4_Integer - , testSmallAndQuick "multiplicative 2" jacobiProperty5_Integer + , testSmallAndQuick "multiplicative 1 Int" jacobiProperty4_Int + , testSmallAndQuick "multiplicative 1 Word" jacobiProperty4_Word + , testSmallAndQuick "multiplicative 1 Integer" jacobiProperty4_Integer + , testSmallAndQuick "multiplicative 1 Natural" jacobiProperty4_Natural + , testSmallAndQuick "multiplicative 2 Int" jacobiProperty5_Int + , testSmallAndQuick "multiplicative 2 Word" jacobiProperty5_Word + , testSmallAndQuick "multiplicative 2 Integer" jacobiProperty5_Integer + , testSmallAndQuick "multiplicative 2 Natural" jacobiProperty5_Natural , testSameIntegralProperty "law of quadratic reciprocity" jacobiProperty6 + , testSmallAndQuick "-1 Int" jacobiProperty7_Int + , testSmallAndQuick "-1 Integer" jacobiProperty7_Integer + , testIntegralProperty "2" jacobiProperty8 + , testSmallAndQuick "minBound Int" jacobiProperty9_Int ] diff --git a/test-suite/Math/NumberTheory/Moduli/PrimitiveRootTests.hs b/test-suite/Math/NumberTheory/Moduli/PrimitiveRootTests.hs --- a/test-suite/Math/NumberTheory/Moduli/PrimitiveRootTests.hs +++ b/test-suite/Math/NumberTheory/Moduli/PrimitiveRootTests.hs @@ -17,25 +17,27 @@ ( testSuite ) where +import Prelude hiding (gcd) import Test.Tasty import qualified Data.Set as S -import Data.List (genericTake) -import Data.Maybe +import Data.List (genericTake, genericLength) +import Data.Maybe (isJust, isNothing, mapMaybe) +import Control.Arrow (first) import Numeric.Natural - -#if !(MIN_VERSION_base(4,8,0)) -import Data.Word -#endif +import Data.Proxy +import GHC.TypeNats.Compat import Math.NumberTheory.ArithmeticFunctions (totient) +import Math.NumberTheory.Euclidean +import Math.NumberTheory.Euclidean.Coprimes import Math.NumberTheory.Moduli.Class (Mod, SomeMod(..), modulo) import Math.NumberTheory.Moduli.PrimitiveRoot -import Math.NumberTheory.Prefactored (prefValue) +import Math.NumberTheory.Prefactored (fromFactors, prefFactors, prefValue, Prefactored) import Math.NumberTheory.TestUtils import Math.NumberTheory.UniqueFactorisation -cyclicGroupProperty1 :: (Integral a, UniqueFactorisation a, Show a) => AnySign a -> Bool +cyclicGroupProperty1 :: (Euclidean a, Integral a, UniqueFactorisation a) => AnySign a -> Bool cyclicGroupProperty1 (AnySign n) = case cyclicGroupFromModulo n of Nothing -> True Just cg -> prefValue (cyclicGroupToModulo cg) == n @@ -60,30 +62,32 @@ go acc (x : xs) = if x `S.member` acc then False else go (S.insert x acc) xs isPrimitiveRoot'Property1 - :: (Eq a, Integral a, UniqueFactorisation a) + :: (Euclidean a, Integral a, UniqueFactorisation a) => AnySign a -> CyclicGroup a -> Bool isPrimitiveRoot'Property1 (AnySign n) cg - = gcd n (prefValue (cyclicGroupToModulo cg)) == 1 + = gcd (toInteger n) (prefValue (castPrefactored (cyclicGroupToModulo cg))) == 1 || not (isPrimitiveRoot' cg n) +castPrefactored :: Integral a => Prefactored a -> Prefactored Integer +castPrefactored = fromFactors . splitIntoCoprimes . map (first toInteger) . unCoprimes . prefFactors + isPrimitiveRootProperty1 :: AnySign Integer -> Positive Natural -> Bool isPrimitiveRootProperty1 (AnySign n) (Positive m) = case n `modulo` m of SomeMod n' -> gcd n (toInteger m) == 1 - || not (isPrimitiveRoot n') + || isNothing (isPrimitiveRoot n') InfMod{} -> False isPrimitiveRootProperty2 :: Positive Natural -> Bool isPrimitiveRootProperty2 (Positive m) = isNothing (cyclicGroupFromModulo m) - || case 0 `modulo` m of - SomeMod (_ :: Mod t) -> any isPrimitiveRoot [(minBound :: Mod t) .. maxBound] - InfMod{} -> False + || case someNatVal m of + SomeNat (_ :: Proxy t) -> any (isJust . isPrimitiveRoot) [(minBound :: Mod t) .. maxBound] isPrimitiveRootProperty3 :: AnySign Integer -> Positive Natural -> Bool isPrimitiveRootProperty3 (AnySign n) (Positive m) = case n `modulo` m of - SomeMod n' -> not (isPrimitiveRoot n') + SomeMod n' -> isNothing (isPrimitiveRoot n') || allUnique (genericTake (totient m - 1) (iterate (* n') 1)) InfMod{} -> False @@ -91,9 +95,15 @@ isPrimitiveRootProperty4 (AnySign n) (Positive m) = isJust (cyclicGroupFromModulo m) || case n `modulo` m of - SomeMod n' -> not (isPrimitiveRoot n') + SomeMod n' -> isNothing (isPrimitiveRoot n') InfMod{} -> False +isPrimitiveRootProperty5 :: Positive Natural -> Bool +isPrimitiveRootProperty5 (Positive m) + = isNothing (cyclicGroupFromModulo m) + || case someNatVal m of + SomeNat (_ :: Proxy t) -> genericLength (mapMaybe isPrimitiveRoot [(minBound :: Mod t) .. maxBound]) == totient (totient m) + testSuite :: TestTree testSuite = testGroup "Primitive root" [ testGroup "CyclicGroup" @@ -110,9 +120,10 @@ ] ] , testGroup "isPrimitiveRoot" - [ testSmallAndQuick "primitive root is coprime with modulo" isPrimitiveRootProperty1 - , testSmallAndQuick "cyclic group has a primitive root" isPrimitiveRootProperty2 - , testSmallAndQuick "primitive root generates cyclic group" isPrimitiveRootProperty3 - , testSmallAndQuick "no primitive root in non-cyclic group" isPrimitiveRootProperty4 + [ testSmallAndQuick "primitive root is coprime with modulo" isPrimitiveRootProperty1 + , testSmallAndQuick "cyclic group has a primitive root" isPrimitiveRootProperty2 + , testSmallAndQuick "primitive root generates cyclic group" isPrimitiveRootProperty3 + , testSmallAndQuick "no primitive root in non-cyclic group" isPrimitiveRootProperty4 + , testSmallAndQuick "cyclic group has right number of primitive roots" isPrimitiveRootProperty5 ] ] diff --git a/test-suite/Math/NumberTheory/Moduli/SqrtTests.hs b/test-suite/Math/NumberTheory/Moduli/SqrtTests.hs --- a/test-suite/Math/NumberTheory/Moduli/SqrtTests.hs +++ b/test-suite/Math/NumberTheory/Moduli/SqrtTests.hs @@ -20,107 +20,219 @@ import Test.Tasty import Test.Tasty.HUnit -import Data.List (nub) +import Control.Arrow +import Data.List (group, sort) import Data.Maybe (fromJust) +import Numeric.Natural import Math.NumberTheory.Moduli hiding (invertMod) -import Math.NumberTheory.UniqueFactorisation (unPrime, isPrime) +import Math.NumberTheory.UniqueFactorisation (unPrime, isPrime, Prime) import Math.NumberTheory.TestUtils -unwrapP :: PrimeWrapper Integer -> Integer -unwrapP (PrimeWrapper p) = unPrime p +unwrapP :: PrimeWrapper Integer -> Prime Integer +unwrapP (PrimeWrapper p) = p -unwrapPP :: (PrimeWrapper Integer, Power Int) -> (Integer, Int) -unwrapPP (p, Power e) = (unwrapP p, e) +unwrapPP :: (PrimeWrapper Integer, Power Word) -> (Prime Integer, Word) +unwrapPP (p, Power e) = (unwrapP p, e `mod` 5) +nubOrd :: Ord a => [a] -> [a] +nubOrd = map head . group . sort + -- | Check that 'sqrtMod' is defined iff a quadratic residue exists. -- Also check that the result is a solution of input modular equation. -sqrtModPProperty :: AnySign Integer -> PrimeWrapper Integer -> Bool -sqrtModPProperty (AnySign n) (unwrapP -> p) = case sqrtModP n p of - Nothing -> jacobi n p == MinusOne - Just rt -> (p == 2 || jacobi n p /= MinusOne) && rt ^ 2 `mod` p == n `mod` p +sqrtsModPrimeProperty1 :: AnySign Integer -> PrimeWrapper Integer -> Bool +sqrtsModPrimeProperty1 (AnySign n) (unwrapP -> p'@(unPrime -> p)) = case sqrtsModPrime n p' of + [] -> jacobi n p == MinusOne + rt : _ -> (p == 2 || jacobi n p /= MinusOne) && rt ^ 2 `mod` p == n `mod` p -sqrtModPListProperty :: AnySign Integer -> PrimeWrapper Integer -> Bool -sqrtModPListProperty (AnySign n) (unwrapP -> p) = all (\rt -> rt ^ 2 `mod` p == n `mod` p) (sqrtModPList n p) +sqrtsModPrimeProperty2 :: AnySign Integer -> PrimeWrapper Integer -> Bool +sqrtsModPrimeProperty2 (AnySign n) (unwrapP -> p'@(unPrime -> p)) = all (\rt -> rt ^ 2 `mod` p == n `mod` p) (sqrtsModPrime n p') -sqrtModP'Property :: Positive Integer -> PrimeWrapper Integer -> Bool -sqrtModP'Property (Positive n) (unwrapP -> p) = (p /= 2 && jacobi n p /= One) || rt ^ 2 `mod` p == n `mod` p +sqrtsModPrimeProperty3 :: AnySign Integer -> PrimeWrapper Integer -> Bool +sqrtsModPrimeProperty3 (AnySign n) (unwrapP -> p'@(unPrime -> p)) = nubOrd rts == sort rts where - rt = sqrtModP' n p + rts = map (`mod` p) $ sqrtsModPrime n p' +sqrtsModPrimeProperty4 :: AnySign Integer -> PrimeWrapper Integer -> Bool +sqrtsModPrimeProperty4 (AnySign n) (unwrapP -> p'@(unPrime -> p)) = all (\rt -> rt >= 0 && rt < p) (sqrtsModPrime n p') + tonelliShanksProperty1 :: Positive Integer -> PrimeWrapper Integer -> Bool -tonelliShanksProperty1 (Positive n) (unwrapP -> p) = p `mod` 4 /= 1 || jacobi n p /= One || rt ^ 2 `mod` p == n `mod` p +tonelliShanksProperty1 (Positive n) (unwrapP -> p'@(unPrime -> p)) = p `mod` 4 /= 1 || jacobi n p /= One || rt ^ 2 `mod` p == n `mod` p where - rt = tonelliShanks n p + rt : _ = sqrtsModPrime n p' tonelliShanksProperty2 :: PrimeWrapper Integer -> Bool -tonelliShanksProperty2 (unwrapP -> p) = p `mod` 4 /= 1 || rt ^ 2 `mod` p == n `mod` p +tonelliShanksProperty2 (unwrapP -> p'@(unPrime -> p)) = p `mod` 4 /= 1 || rt ^ 2 `mod` p == n `mod` p where n = head $ filter (\s -> jacobi s p == One) [2..p-1] - rt = tonelliShanks n p + rt : _ = sqrtsModPrime n p' +tonelliShanksProperty3 :: PrimeWrapper Integer -> Bool +tonelliShanksProperty3 (unwrapP -> p'@(unPrime -> p)) + = p `mod` 4 /= 1 + || rt ^ 2 `mod` p == p - 1 + where + rt : _ = sqrtsModPrime (-1) p' + tonelliShanksSpecialCases :: Assertion tonelliShanksSpecialCases = assertEqual "OEIS A002224" [6, 32, 219, 439, 1526, 2987, 22193, 11740, 13854, 91168, 326277, 232059, 3230839, 4379725, 11754394, 32020334, 151024619, 345641931, 373671108, 1857111865, 8110112775, 4184367042] rts where + ps :: [Integer] ps = [17, 73, 241, 1009, 2689, 8089, 33049, 53881, 87481, 483289, 515761, 1083289, 3818929, 9257329, 22000801, 48473881, 175244281, 427733329, 898716289, 8114538721, 9176747449, 23616331489] - rts = map (\p -> tonelliShanks 2 p) ps + rts = map (head . sqrtsModPrime 2 . fromJust . isPrime) ps -sqrtModPPProperty :: AnySign Integer -> (PrimeWrapper Integer, Power Int) -> Bool -sqrtModPPProperty (AnySign n) (unwrapP -> p, Power e) = gcd n p > 1 || case sqrtModPP n (p, e) of - Nothing -> True - Just rt -> rt ^ 2 `mod` (p ^ e) == n `mod` (p ^ e) +sqrtsModPrimePowerProperty1 :: AnySign Integer -> (PrimeWrapper Integer, Power Word) -> Bool +sqrtsModPrimePowerProperty1 (AnySign n) (unwrapP -> p'@(unPrime -> p), Power e) = gcd n p > 1 + || all (\rt -> rt ^ 2 `mod` (p ^ e) == n `mod` (p ^ e)) (sqrtsModPrimePower n p' e) -sqrtModPPBase2Property :: AnySign Integer -> Power Int -> Bool -sqrtModPPBase2Property n e = sqrtModPPProperty n (PrimeWrapper $ fromJust $ isPrime (2 :: Integer), e) +sqrtsModPrimePowerProperty2 :: AnySign Integer -> Power Word -> Bool +sqrtsModPrimePowerProperty2 n e = sqrtsModPrimePowerProperty1 n (PrimeWrapper $ fromJust $ isPrime (2 :: Integer), e) -sqrtModPPSpecialCase1 :: Assertion -sqrtModPPSpecialCase1 = - assertEqual "sqrtModPP 16 2 2 = 4" (Just 0) (sqrtModPP 16 (2, 2)) +sqrtsModPrimePowerProperty3 :: AnySign Integer -> (PrimeWrapper Integer, Power Word) -> Bool +sqrtsModPrimePowerProperty3 (AnySign n) (unwrapP -> p'@(unPrime -> p), Power e') = nubOrd rts == sort rts + where + e = e' `mod` 5 + m = p ^ e + rts = map (`mod` m) $ sqrtsModPrimePower n p' e -sqrtModPPSpecialCase2 :: Assertion -sqrtModPPSpecialCase2 = - assertEqual "sqrtModPP 16 3 2 = 4" (Just 4) (sqrtModPP 16 (3, 2)) +sqrtsModPrimePowerProperty4 :: AnySign Integer -> Power Word -> Bool +sqrtsModPrimePowerProperty4 n e = sqrtsModPrimePowerProperty3 n (PrimeWrapper $ fromJust $ isPrime (2 :: Integer), e) -sqrtModPPListProperty :: AnySign Integer -> (PrimeWrapper Integer, Power Int) -> Bool -sqrtModPPListProperty (AnySign n) (unwrapP -> p, Power e) = gcd n p > 1 - || all (\rt -> rt ^ 2 `mod` (p ^ e) == n `mod` (p ^ e)) (sqrtModPPList n (p, e)) +sqrtsModPrimePowerProperty5 :: AnySign Integer -> (PrimeWrapper Integer, Power Word) -> Bool +sqrtsModPrimePowerProperty5 (AnySign n) (unwrapP -> p'@(unPrime -> p), Power e') = all (\rt -> rt >= 0 && rt < m) rts + where + e = e' `mod` 5 + m = p ^ e + rts = sqrtsModPrimePower n p' e -sqrtModFProperty :: AnySign Integer -> [(PrimeWrapper Integer, Power Int)] -> Bool -sqrtModFProperty (AnySign n) (map unwrapPP -> pes) = case sqrtModF n pes of - Nothing -> True - Just rt -> all (\(p, e) -> rt ^ 2 `mod` (p ^ e) == n `mod` (p ^ e)) pes +sqrtsModPrimePowerProperty6 :: AnySign Integer -> Power Word -> Bool +sqrtsModPrimePowerProperty6 n e = sqrtsModPrimePowerProperty5 n (PrimeWrapper $ fromJust $ isPrime (2 :: Integer), e) -sqrtModFListProperty :: AnySign Integer -> [(PrimeWrapper Integer, Power Int)] -> Bool -sqrtModFListProperty (AnySign n) (map unwrapPP -> pes) - = nub ps /= ps || all +sqrtsModPrimePowerSpecialCase1 :: Assertion +sqrtsModPrimePowerSpecialCase1 = + assertEqual "should be equal" [0, 2] (sort (sqrtsModPrimePower 16 (fromJust (isPrime (2 :: Integer))) 2)) + +sqrtsModPrimePowerSpecialCase2 :: Assertion +sqrtsModPrimePowerSpecialCase2 = + assertEqual "should be equal" [4, 5] (sort (sqrtsModPrimePower 16 (fromJust (isPrime (3 :: Integer))) 2)) + +sqrtsModPrimePowerSpecialCase3 :: Assertion +sqrtsModPrimePowerSpecialCase3 = + assertEqual "should be equal" [0, 3, 6] (sort (sqrtsModPrimePower 0 (fromJust (isPrime (3 :: Integer))) 2)) + +sqrtsModPrimePowerSpecialCase4 :: Assertion +sqrtsModPrimePowerSpecialCase4 = + assertEqual "should be equal" [0, 9, 18] (sort (sqrtsModPrimePower 0 (fromJust (isPrime (3 :: Integer))) 3)) + +sqrtsModPrimePowerSpecialCase5 :: Assertion +sqrtsModPrimePowerSpecialCase5 = + assertEqual "should be equal" [0, 4, 8, 12] (sort (sqrtsModPrimePower 0 (fromJust (isPrime (2 :: Integer))) 4)) + +sqrtsModPrimePowerSpecialCase6 :: Assertion +sqrtsModPrimePowerSpecialCase6 = + assertEqual "should be equal" [3, 6, 12, 15, 21, 24] (sort (sqrtsModPrimePower 9 (fromJust (isPrime (3 :: Integer))) 3)) + +sqrtsModPrimePowerSpecialCase7 :: Assertion +sqrtsModPrimePowerSpecialCase7 = + assertEqual "should be equal" [2, 6] (sort (sqrtsModPrimePower 4 (fromJust (isPrime (2 :: Integer))) 3)) + +sqrtsModPrimePowerSpecialCase8 :: Assertion +sqrtsModPrimePowerSpecialCase8 = + assertEqual "should be equal" [1, 3] (sort (sqrtsModPrimePower 1 (fromJust (isPrime (2 :: Integer))) 2)) + +sqrtsModPrimePowerSpecialCase9 :: Assertion +sqrtsModPrimePowerSpecialCase9 = + assertEqual "should be equal" [] (sort (sqrtsModPrimePower (-1) (fromJust (isPrime (2 :: Integer))) 2)) + +sqrtsModPrimePowerSpecialCase10 :: Assertion +sqrtsModPrimePowerSpecialCase10 = + assertEqual "should be equal" [2, 6, 10, 14] (sort (sqrtsModPrimePower 4 (fromJust (isPrime (2 :: Integer))) 4)) + +sqrtsModPrimePowerSpecialCase11 :: Assertion +sqrtsModPrimePowerSpecialCase11 = + assertEqual "should be equal" [4,12,20,28,36,44,52,60] (sort (sqrtsModPrimePower 16 (fromJust (isPrime (2 :: Integer))) 6)) + +sqrtsModFactorisationProperty1 :: AnySign Integer -> [(PrimeWrapper Integer, Power Word)] -> Bool +sqrtsModFactorisationProperty1 (AnySign n) (take 10 . map unwrapPP -> pes'@(map (first unPrime) -> pes)) + = nubOrd ps /= sort ps || all (\rt -> all (\(p, e) -> rt ^ 2 `mod` (p ^ e) == n `mod` (p ^ e)) pes) - (sqrtModFList n pes) + (take 1000 $ sqrtsModFactorisation n pes') where ps = map fst pes -sqrtModFListSpecialCase :: Assertion -sqrtModFListSpecialCase = - assertEqual "sqrtModPPList 0 [(2,1), (3,1), (5,1)]" [0] (sqrtModFList 0 [(2,1), (3,1), (5,1)]) +sqrtsModFactorisationProperty2 :: AnySign Integer -> [(PrimeWrapper Integer, Power Word)] -> Bool +sqrtsModFactorisationProperty2 (AnySign n) (take 10 . map unwrapPP -> pes'@(map (first unPrime) -> pes)) + = nubOrd ps /= sort ps || nubOrd rts == sort rts + where + ps = map fst pes + m = product $ map (\(p, e) -> p ^ e) pes + rts = map (`mod` m) $ take 1000 $ sqrtsModFactorisation n pes' +sqrtsModFactorisationProperty3 :: AnySign Integer -> [(PrimeWrapper Integer, Power Word)] -> Bool +sqrtsModFactorisationProperty3 (AnySign n) (take 10 . map unwrapPP -> pes'@(map (first unPrime) -> pes)) + = nubOrd ps /= sort ps || all (\rt -> rt >= 0 && rt < m) rts + where + ps = map fst pes + m = product $ map (\(p, e) -> p ^ e) pes + rts = take 1000 $ sqrtsModFactorisation n pes' + +sqrtsModFactorisationSpecialCase1 :: Assertion +sqrtsModFactorisationSpecialCase1 = + assertEqual "should be equal" [0] + (sqrtsModFactorisation 0 $ map (first (fromJust . isPrime)) [(2 :: Integer, 1), (3, 1), (5, 1)]) + +sqrtsModFactorisationSpecialCase2 :: Assertion +sqrtsModFactorisationSpecialCase2 = + assertEqual "should be equal" [0] + (sqrtsModFactorisation 0 $ map (first (fromJust . isPrime)) [(3 :: Integer, 1), (5, 1)]) + +sqrtsModProperty1 :: AnySign Integer -> Positive Natural -> Bool +sqrtsModProperty1 (AnySign n) (Positive m) = case n `modulo` m of + SomeMod x -> sort (sqrtsMod x) == filter (\rt -> rt * rt == x) [minBound .. maxBound] + InfMod{} -> True + testSuite :: TestTree testSuite = testGroup "Sqrt" - [ testSmallAndQuick "sqrtModP" sqrtModPProperty - , testSmallAndQuick "sqrtModPList" sqrtModPListProperty - , testSmallAndQuick "sqrtModP'" sqrtModP'Property + [ testGroup "sqrtsModPrime" + [ testSmallAndQuick "matches jacobi" sqrtsModPrimeProperty1 + , testSmallAndQuick "is residue" sqrtsModPrimeProperty2 + , testSmallAndQuick "distinct" sqrtsModPrimeProperty3 + , testSmallAndQuick "bounded" sqrtsModPrimeProperty4 + ] , testGroup "tonelliShanks" [ testSmallAndQuick "generic" tonelliShanksProperty1 , testSmallAndQuick "smallest residue" tonelliShanksProperty2 + , testSmallAndQuick "-1" tonelliShanksProperty3 , testCase "OEIS A002224" tonelliShanksSpecialCases ] - , testGroup "sqrtModPP" - [ testSmallAndQuick "generic" sqrtModPPProperty - , testSmallAndQuick "_ 2 _" sqrtModPPBase2Property - , testCase "16 2 2" sqrtModPPSpecialCase1 - , testCase "16 3 2" sqrtModPPSpecialCase2 + , testGroup "sqrtsModPrimePower" + [ testSmallAndQuick "generic" sqrtsModPrimePowerProperty1 + , testSmallAndQuick "_ 2 _" sqrtsModPrimePowerProperty2 + , testSmallAndQuick "distinct" sqrtsModPrimePowerProperty3 + , testSmallAndQuick "_ 2 _" sqrtsModPrimePowerProperty4 + , testSmallAndQuick "bounded" sqrtsModPrimePowerProperty5 + , testSmallAndQuick "_ 2 _" sqrtsModPrimePowerProperty6 + , testCase "16 2 2" sqrtsModPrimePowerSpecialCase1 + , testCase "16 3 2" sqrtsModPrimePowerSpecialCase2 + , testCase "0 3 2" sqrtsModPrimePowerSpecialCase3 + , testCase "0 3 3" sqrtsModPrimePowerSpecialCase4 + , testCase "0 2 4" sqrtsModPrimePowerSpecialCase5 + , testCase "9 3 3" sqrtsModPrimePowerSpecialCase6 + , testCase "4 2 3" sqrtsModPrimePowerSpecialCase7 + , testCase "1 2 2" sqrtsModPrimePowerSpecialCase8 + , testCase "-1 2 2" sqrtsModPrimePowerSpecialCase9 + , testCase "4 2 4" sqrtsModPrimePowerSpecialCase10 + , testCase "16 2 6" sqrtsModPrimePowerSpecialCase11 ] - , testSmallAndQuick "sqrtModPPList" sqrtModPPListProperty - , testSmallAndQuick "sqrtModF" sqrtModFProperty - , testSmallAndQuick "sqrtModFList" sqrtModFListProperty - , testCase "sqrtModFList 0 [(2,1), (3,1), (5,1)]" sqrtModFListSpecialCase + , testGroup "sqrtsModFactorisation" + [ testSmallAndQuick "generic" sqrtsModFactorisationProperty1 + , testSmallAndQuick "distinct" sqrtsModFactorisationProperty2 + , testSmallAndQuick "bounded" sqrtsModFactorisationProperty3 + , testCase "0 [(2,1), (3,1), (5,1)]" sqrtsModFactorisationSpecialCase1 + , testCase "0 [(3,1), (5,1)]" sqrtsModFactorisationSpecialCase2 + ] + , testGroup "sqrtsMod" + [ testSmallAndQuick "generic" sqrtsModProperty1 + ] ] diff --git a/test-suite/Math/NumberTheory/Powers/CubesTests.hs b/test-suite/Math/NumberTheory/Powers/CubesTests.hs --- a/test-suite/Math/NumberTheory/Powers/CubesTests.hs +++ b/test-suite/Math/NumberTheory/Powers/CubesTests.hs @@ -20,11 +20,6 @@ import Test.Tasty.HUnit import Data.Maybe -#if MIN_VERSION_base(4,8,0) -#else -import Data.Word -#endif - import Math.NumberTheory.Powers.Cubes import Math.NumberTheory.TestUtils diff --git a/test-suite/Math/NumberTheory/Powers/FourthTests.hs b/test-suite/Math/NumberTheory/Powers/FourthTests.hs --- a/test-suite/Math/NumberTheory/Powers/FourthTests.hs +++ b/test-suite/Math/NumberTheory/Powers/FourthTests.hs @@ -20,10 +20,6 @@ import Test.Tasty.HUnit import Data.Maybe -#if MIN_VERSION_base(4,8,0) -#else -import Data.Word -#endif import Math.NumberTheory.Powers.Fourth import Math.NumberTheory.TestUtils diff --git a/test-suite/Math/NumberTheory/Powers/ModularTests.hs b/test-suite/Math/NumberTheory/Powers/ModularTests.hs --- a/test-suite/Math/NumberTheory/Powers/ModularTests.hs +++ b/test-suite/Math/NumberTheory/Powers/ModularTests.hs @@ -17,9 +17,7 @@ ) where import Test.Tasty -#if MIN_VERSION_base(4,8,0) import Test.Tasty.HUnit -#endif import Numeric.Natural @@ -46,7 +44,6 @@ powModProperty3 (NonNegative e1) (NonNegative e2) (AnySign b) (Positive m) = (powMod' b e1 m * powMod' b e2 m) `mod` m == powMod' b (e1 + e2) m -#if __GLASGOW_HASKELL__ > 709 -- | Specialized to trigger 'powModInt'. powModProperty_Int :: AnySign Int -> NonNegative Int -> Positive Int -> Bool powModProperty_Int (AnySign b) (NonNegative e) (Positive m) = powModInt b e m == fromInteger (powMod' (fromIntegral b) (fromIntegral e) (fromIntegral m)) @@ -54,7 +51,6 @@ -- | Specialized to trigger 'powModWord'. powModProperty_Word :: AnySign Word -> NonNegative Word -> Positive Word -> Bool powModProperty_Word (AnySign b) (NonNegative e) (Positive m) = powModWord b e m == fromInteger (powMod' (fromIntegral b) (fromIntegral e) (fromIntegral m)) -#endif -- | Specialized to trigger 'powModInteger'. powModProperty_Integer :: AnySign Integer -> NonNegative Integer -> Positive Integer -> Bool @@ -64,7 +60,7 @@ powModProperty_Natural :: AnySign Natural -> NonNegative Natural -> Positive Natural -> Bool powModProperty_Natural (AnySign b) (NonNegative e) (Positive m) = powMod b e m == fromInteger (powMod' (fromIntegral b) (fromIntegral e) (fromIntegral m)) -#if WORD_SIZE_IN_BITS == 64 && __GLASGOW_HASKELL__ > 709 +#if WORD_SIZE_IN_BITS == 64 -- | Large modulo m such that m^2 overflows. powModSpecialCase1_Int :: Assertion powModSpecialCase1_Int = @@ -83,14 +79,12 @@ , testSmallAndQuick "multiplicative by base" powModProperty2 , testSmallAndQuick "additive by exponent" powModProperty3 -#if __GLASGOW_HASKELL__ > 709 , testSmallAndQuick "powModInt" powModProperty_Int , testSmallAndQuick "powModWord" powModProperty_Word -#endif , testSmallAndQuick "powModInteger" powModProperty_Integer , testSmallAndQuick "powModNatural" powModProperty_Natural -#if WORD_SIZE_IN_BITS == 64 && __GLASGOW_HASKELL__ > 709 +#if WORD_SIZE_IN_BITS == 64 , testCase "large modulo :: Int" powModSpecialCase1_Int , testCase "large modulo :: Word" powModSpecialCase1_Word #endif diff --git a/test-suite/Math/NumberTheory/Powers/SquaresTests.hs b/test-suite/Math/NumberTheory/Powers/SquaresTests.hs --- a/test-suite/Math/NumberTheory/Powers/SquaresTests.hs +++ b/test-suite/Math/NumberTheory/Powers/SquaresTests.hs @@ -20,10 +20,6 @@ import Test.Tasty.HUnit import Data.Maybe -#if MIN_VERSION_base(4,8,0) -#else -import Data.Word -#endif import Math.NumberTheory.Powers.Squares import Math.NumberTheory.TestUtils diff --git a/test-suite/Math/NumberTheory/PrefactoredTests.hs b/test-suite/Math/NumberTheory/PrefactoredTests.hs --- a/test-suite/Math/NumberTheory/PrefactoredTests.hs +++ b/test-suite/Math/NumberTheory/PrefactoredTests.hs @@ -19,25 +19,21 @@ import Test.Tasty import Control.Arrow (second) -import Data.Bits (Bits) import Data.List (tails) -#if MIN_VERSION_base(4,8,0) -#else -import Data.Word -#endif import Numeric.Natural -import Math.NumberTheory.GCD (coprime, splitIntoCoprimes) +import Math.NumberTheory.Euclidean (Euclidean, coprime) +import Math.NumberTheory.Euclidean.Coprimes import Math.NumberTheory.Prefactored import Math.NumberTheory.TestUtils -isValid :: (Eq a, Bits a, Integral a) => Prefactored a -> Bool +isValid :: Euclidean a => Prefactored a -> Bool isValid pref = abs n == abs (product (map (uncurry (^)) fs)) && and [ coprime g h | ((g, _) : gs) <- tails fs, (h, _) <- gs ] where n = prefValue pref - fs = prefFactors pref + fs = unCoprimes $ prefFactors pref fromValueProperty :: Integer -> Bool fromValueProperty n = isValid pref && prefValue pref == n diff --git a/test-suite/Math/NumberTheory/Primes/FactorisationTests.hs b/test-suite/Math/NumberTheory/Primes/FactorisationTests.hs --- a/test-suite/Math/NumberTheory/Primes/FactorisationTests.hs +++ b/test-suite/Math/NumberTheory/Primes/FactorisationTests.hs @@ -45,6 +45,8 @@ , (16757651897802863152387219654541878162,[(2,1),(29,1),(78173,1),(401529283,1),(1995634649,1),(4612433663779,1)]) , (16757651897802863152387219654541878163,[(11,1),(31,1),(112160981904206269,1),(438144115295608147,1)]) , (16757651897802863152387219654541878166,[(2,1),(23,1),(277,1),(505353699591289,1),(2602436338718275457,1)]) + , ((10 ^ 80 - 1) `div` 9, [(11,1),(17,1),(41,1),(73,1),(101,1),(137,1),(271,1),(3541,1),(9091,1),(27961,1), + (1676321,1),(5070721,1),(5882353,1),(5964848081,1),(19721061166646717498359681,1)]) ] lazyCases :: [(Integer, [(Integer, Int)])] @@ -60,7 +62,7 @@ factoriseProperty1 = assertEqual "0" [] (factorise 1) factoriseProperty2 :: Positive Integer -> Bool -factoriseProperty2 (Positive n) = (-1, 1) : factorise n == factorise (negate n) +factoriseProperty2 (Positive n) = factorise n == factorise (negate n) factoriseProperty3 :: Positive Integer -> Bool factoriseProperty3 (Positive n) = all (isPrime . fst) (factorise n) diff --git a/test-suite/Math/NumberTheory/Primes/SieveTests.hs b/test-suite/Math/NumberTheory/Primes/SieveTests.hs --- a/test-suite/Math/NumberTheory/Primes/SieveTests.hs +++ b/test-suite/Math/NumberTheory/Primes/SieveTests.hs @@ -1,6 +1,6 @@ -- | -- Module: Math.NumberTheory.Primes.SieveTests --- Copyright: (c) 2016 Andrew Lelechenko +-- Copyright: (c) 2016-2018 Andrew Lelechenko -- Licence: MIT -- Maintainer: Andrew Lelechenko -- Stability: Provisional @@ -8,7 +8,8 @@ -- Tests for Math.NumberTheory.Primes.Sieve -- -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-} {-# OPTIONS_GHC -fno-warn-deprecations #-} @@ -22,49 +23,97 @@ import Test.Tasty import Test.Tasty.HUnit +import Data.Int +import Data.Proxy (Proxy(..)) +import Data.Word +import Numeric.Natural (Natural) + import Math.NumberTheory.Primes.Sieve -import qualified Math.NumberTheory.Primes.Heap as H +import Math.NumberTheory.Primes.Testing import Math.NumberTheory.TestUtils --- | Check that both 'primes' produce the same. -primesProperty1 :: Assertion -primesProperty1 = do - assertEqual "Sieve == Heap" (trim primes) (trim H.primes) - where - trim = take 100000 +lim1 :: Num a => a +lim1 = 1000000 --- | Check that both 'sieveFrom' produce the same. -sieveFromProperty1 :: AnySign Integer -> Bool -sieveFromProperty1 (AnySign lowBound) - = trim (sieveFrom lowBound) == trim (H.sieveFrom lowBound) - where - trim = take 1000 +lim2 :: Num a => a +lim2 = 100000 +lim3 :: Num a => a +lim3 = 1000 + +-- | Check that 'primes' matches 'isPrime'. +primesProperty1 :: forall a. (Integral a, Show a) => Proxy a -> Assertion +primesProperty1 _ = assertEqual "primes matches isPrime" + (takeWhile (<= lim1) primes :: [a]) + (filter (isPrime . toInteger) [1..lim1]) + +primesProperty2 :: forall a. (Integral a, Bounded a, Show a) => Proxy a -> Assertion +primesProperty2 _ = assertEqual "primes matches isPrime" + (primes :: [a]) + (filter (isPrime . toInteger) [1..maxBound]) + -- | Check that 'primeList' from 'primeSieve' matches truncated 'primes'. primeSieveProperty1 :: AnySign Integer -> Bool -primeSieveProperty1 (AnySign highBound) - = primeList (primeSieve highBound) == takeWhile (<= (highBound `max` 7)) primes +primeSieveProperty1 (AnySign highBound') + = primeList (primeSieve highBound) + == takeWhile (<= (highBound `max` 7)) primes + where + highBound = highBound' `rem` lim1 -- | Check that 'primeList' from 'psieveList' matches 'primes'. -psieveListProperty1 :: Assertion -psieveListProperty1 = do - assertEqual "primes == primeList . psieveList" (trim primes) (trim $ concatMap primeList psieveList) - where - trim = take 100000 +psieveListProperty1 :: forall a. (Integral a, Show a) => Proxy a -> Assertion +psieveListProperty1 _ = assertEqual "primes == primeList . psieveList" + (take lim2 primes :: [a]) + (take lim2 $ concatMap primeList psieveList) --- | Check that 'primeList' from 'psieveFrom' matches 'sieveFrom'. -psieveFromProperty1 :: AnySign Integer -> Bool -psieveFromProperty1 (AnySign lowBound) - = trim (sieveFrom lowBound) == trim (filter (>= lowBound) (concatMap primeList $ psieveFrom lowBound)) +psieveListProperty2 :: forall a. (Integral a, Show a) => Proxy a -> Assertion +psieveListProperty2 _ = assertEqual "primes == primeList . psieveList" + (primes :: [a]) + (concat $ takeWhile (not . null) $ map primeList psieveList) + +-- | Check that 'sieveFrom' matches 'primeList' of 'psieveFrom'. +sieveFromProperty1 :: AnySign Integer -> Bool +sieveFromProperty1 (AnySign lowBound') + = take lim3 (sieveFrom lowBound) + == take lim3 (filter (>= lowBound) (concatMap primeList $ psieveFrom lowBound)) where - trim = take 1000 + lowBound = lowBound' `rem` lim1 +-- | Check that 'sieveFrom' matches 'isPrime' near 0. +sieveFromProperty2 :: AnySign Integer -> Bool +sieveFromProperty2 (AnySign lowBound') + = take lim3 (sieveFrom lowBound) + == take lim3 (filter (isPrime . toInteger) [lowBound `max` 0 ..]) + where + lowBound = lowBound' `rem` lim1 testSuite :: TestTree testSuite = testGroup "Sieve" - [ testCase "primes" primesProperty1 - , testSmallAndQuick "sieveFrom" sieveFromProperty1 + [ testGroup "primes" + [ testCase "Int" (primesProperty1 (Proxy :: Proxy Int)) + , testCase "Word" (primesProperty1 (Proxy :: Proxy Word)) + , testCase "Integer" (primesProperty1 (Proxy :: Proxy Integer)) + , testCase "Natural" (primesProperty1 (Proxy :: Proxy Natural)) + + , testCase "Int8" (primesProperty2 (Proxy :: Proxy Int8)) + , testCase "Int16" (primesProperty2 (Proxy :: Proxy Int16)) + , testCase "Word8" (primesProperty2 (Proxy :: Proxy Word8)) + , testCase "Word16" (primesProperty2 (Proxy :: Proxy Word16)) + ] , testSmallAndQuick "primeSieve" primeSieveProperty1 - , testCase "psieveList" psieveListProperty1 - , testSmallAndQuick "psieveFrom" psieveFromProperty1 + , testGroup "psieveList" + [ testCase "Int" (psieveListProperty1 (Proxy :: Proxy Int)) + , testCase "Word" (psieveListProperty1 (Proxy :: Proxy Word)) + , testCase "Integer" (psieveListProperty1 (Proxy :: Proxy Integer)) + , testCase "Natural" (psieveListProperty1 (Proxy :: Proxy Natural)) + + , testCase "Int8" (psieveListProperty2 (Proxy :: Proxy Int8)) + , testCase "Int16" (psieveListProperty2 (Proxy :: Proxy Int16)) + , testCase "Word8" (psieveListProperty2 (Proxy :: Proxy Word8)) + , testCase "Word16" (psieveListProperty2 (Proxy :: Proxy Word16)) + ] + , testGroup "sieveFrom" + [ testSmallAndQuick "psieveFrom" sieveFromProperty1 + , testSmallAndQuick "isPrime near 0" sieveFromProperty2 + ] ] diff --git a/test-suite/Math/NumberTheory/PrimesTests.hs b/test-suite/Math/NumberTheory/PrimesTests.hs --- a/test-suite/Math/NumberTheory/PrimesTests.hs +++ b/test-suite/Math/NumberTheory/PrimesTests.hs @@ -16,7 +16,6 @@ ) where import Test.Tasty -import Test.Tasty.HUnit import Math.NumberTheory.Primes import Math.NumberTheory.TestUtils @@ -31,17 +30,7 @@ primesSumProperty (NonNegative n) = primesSumWonk n == primesSum n -sieveFactorSpecialCase1 :: Assertion -sieveFactorSpecialCase1 = do - assertEqual "sieveFactor 2048" [(29, 1), (73, 1)] $ sieveFactor (factorSieve 2048) (29*73) - assertEqual "sieveFactor 15" [(3, 1), (5, 2)] $ sieveFactor (factorSieve 15) (75) - -sieveFactorProperty :: Integer -> Bool -sieveFactorProperty n = (n==0) || factorise n == sieveFactor (factorSieve 25) n - testSuite :: TestTree testSuite = testGroup "Primes" [ testSmallAndQuick "primesSum" primesSumProperty - , testCase "sieveFactor special" sieveFactorSpecialCase1 - , testSmallAndQuick "sieveFactor property" sieveFactorProperty ] diff --git a/test-suite/Math/NumberTheory/Recurrencies/BilinearTests.hs b/test-suite/Math/NumberTheory/Recurrencies/BilinearTests.hs --- a/test-suite/Math/NumberTheory/Recurrencies/BilinearTests.hs +++ b/test-suite/Math/NumberTheory/Recurrencies/BilinearTests.hs @@ -19,7 +19,10 @@ import Data.Ratio -import Math.NumberTheory.Recurrencies.Bilinear +import Math.NumberTheory.Recurrencies.Bilinear (bernoulli, binomial, euler, + eulerian1, eulerian2, + eulerPolyAt1, lah, stirling1, + stirling2) import Math.NumberTheory.TestUtils binomialProperty1 :: NonNegative Int -> Bool @@ -149,6 +152,32 @@ | k <- [0 .. m - 1] ] +-- | For every odd positive integer @n@, @E_n@ is @0@. +eulerProperty1 :: Positive Int -> Bool +eulerProperty1 (Positive n) = euler !! (2 * n - 1) == 0 + +-- | Every positive even index produces a negative result. +eulerProperty2 :: NonNegative Int -> Bool +eulerProperty2 (NonNegative n) = euler !! (2 + 4 * n) < 0 + +-- | The Euler number sequence is https://oeis.org/A122045 +eulerSpecialCase1 :: Assertion +eulerSpecialCase1 = assertEqual "euler" + (take 20 euler) + [1, 0, -1, 0, 5, 0, -61, 0, 1385, 0, -50521, 0, 2702765, 0, -199360981, 0, 19391512145, 0, -2404879675441, 0] + +-- | For any even positive integer @n@, @E_n(1)@ is @0@. +eulerPAt1Property1 :: Positive Int -> Bool +eulerPAt1Property1 (Positive n) = (eulerPolyAt1 !! (2 * n)) == 0 + +-- | The numerators in this sequence are from https://oeis.org/A198631 while the +-- denominators are from https://oeis.org/A006519. +eulerPAt1SpecialCase1 :: Assertion +eulerPAt1SpecialCase1 = assertEqual "eulerPolyAt1" + (take 20 eulerPolyAt1) + (zipWith (%) [1, 1, 0, -1, 0, 1, 0, -17, 0, 31, 0, -691, 0, 5461, 0, -929569, 0, 3202291, 0, -221930581] + [1, 2, 1, 4, 1, 2, 1, 8, 1, 2, 1, 4, 1, 2, 1, 16, 1, 2, 1, 4]) + testSuite :: TestTree testSuite = testGroup "Bilinear" [ testGroup "binomial" @@ -192,5 +221,14 @@ , testCase "B_1" bernoulliSpecialCase2 , testSmallAndQuick "sign" bernoulliProperty1 , testSmallAndQuick "recursive definition" bernoulliProperty2 + ] + , testGroup "Euler numbers" + [ testCase "First 20 elements of E_n are correct" eulerSpecialCase1 + , testSmallAndQuick "E_n with n odd is 0" eulerProperty1 + , testSmallAndQuick "E_n for n in [2,6,8,12..] is negative" eulerProperty2 + ] + , testGroup "Euler Polynomial of order N evaluated at 1" + [ testCase "First 20 elements of E_n(1) are correct" eulerPAt1SpecialCase1 + , testSmallAndQuick "E_n(1) with n in [2,4,6..] is 0" eulerPAt1Property1 ] ] diff --git a/test-suite/Math/NumberTheory/Recurrencies/PentagonalTests.hs b/test-suite/Math/NumberTheory/Recurrencies/PentagonalTests.hs new file mode 100644 --- /dev/null +++ b/test-suite/Math/NumberTheory/Recurrencies/PentagonalTests.hs @@ -0,0 +1,105 @@ +-- | +-- Module: Math.NumberTheory.Recurrencies.PentagonalTests +-- Copyright: (c) 2018 Alexandre Rodrigues Baldé +-- Licence: MIT +-- Maintainer: Alexandre Rodrigues Baldé +-- Stability: Provisional +-- Portability: Non-portable (GHC extensions) +-- +-- Tests for Math.NumberTheory.Recurrencies.Pentagonal +-- + +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -fno-warn-type-defaults #-} + +module Math.NumberTheory.Recurrencies.PentagonalTests + ( testSuite + ) where + +import Data.Proxy (Proxy (..)) +import GHC.Natural (Natural) +import GHC.TypeNats.Compat (SomeNat (..), someNatVal) + +import Math.NumberTheory.Moduli (Mod, getVal) +import Math.NumberTheory.Recurrencies (partition) +import Math.NumberTheory.TestUtils + +import Test.Tasty +import Test.Tasty.HUnit + +-- | Helper to avoid writing @partition !!@ too many times. +partition' :: Num a => Int -> a +partition' = (partition !!) + +-- | Check that the @k@-th generalized pentagonal number is +-- @div (3 * k² - k) 2@, where @k ∈ {0, 1, −1, 2, −2, 3, −3, 4, ...}@. +-- Notice that @-1@ is the @2 * abs (-1) == 2@-nd index in the zero-based list, +-- while @2@ is the @2 * 2 - 1 == 3@-rd, and so on. +pentagonalNumbersProperty1 :: AnySign Int -> Bool +pentagonalNumbersProperty1 (AnySign n) + | n == 0 = pents !! 0 == 0 + | n > 0 = pents !! (2 * n - 1) == pent n + | otherwise = pents !! (2 * abs n) == pent n + where + pent m = div (3 * (m * m) - m) 2 + +-- | Check that the first 20 elements of @partition@ are correct per +-- https://oeis.org/A000041. +partitionSpecialCase20 :: Assertion +partitionSpecialCase20 = assertEqual "partition" + (take 20 partition) + [1, 1, 2, 3, 5, 7, 11, 15, 22, 30, 42, 56, 77, 101, 135, 176, 231, 297, 385, 490] + +-- | Copied from @Math.NumberTheory.Recurrencies.Pentagonal@ to test the +-- reference implementation of @partition@. +pentagonalSigns :: Num a => [a] -> [a] +pentagonalSigns = zipWith (*) (cycle [1, 1, -1, -1]) + +-- | Copied from @Math.NumberTheory.Recurrencies.Pentagonal@ to test the +-- reference implementation of @partition@. +pents :: (Enum a, Num a) => [a] +pents = interleave (scanl (\acc n -> acc + 3 * n - 1) 0 [1..]) + (scanl (\acc n -> acc + 3 * n - 2) 1 [2..]) + where + interleave :: [a] -> [a] -> [a] + interleave (n : ns) (m : ms) = n : m : interleave ns ms + interleave _ _ = [] + +-- | Check that @p(n) = p(n-1) + p(n-2) - p(n-5) - p(n-7) + p(n-11) + ...@, +-- where @p(x) = 0@ for any negative integer and @p(0) = 1@. +partitionProperty1 :: Positive Int -> Bool +partitionProperty1 (Positive n) = + partition' n == (sum . + pentagonalSigns . + map (\m -> partition' (n - m)) . + takeWhile (\m -> n - m >= 0) . + tail $ pents) + +-- | Check that +-- @partition :: [Math.NumberTheory.Moduli.Mod n] == map (`mod` n) partition@. +partitionProperty2 :: NonNegative Integer -> Positive Natural -> Bool +partitionProperty2 (NonNegative m) + n@(someNatVal . getPositive -> (SomeNat (Proxy :: Proxy n))) = + (take m' . map getVal $ (partition :: [Mod n])) == + map helper (take m' partition :: [Integer]) + where + m' = fromIntegral m + n' = fromIntegral n + helper x = x `mod` n' + +testSuite :: TestTree +testSuite = testGroup "Pentagonal" + [ testGroup "partition" + [ testSmallAndQuick "matches definition" partitionProperty1 + , testSmallAndQuick "mapping residue modulus 'n' is the same as giving\ + \'partition' type '[Mod n]'" partitionProperty2 + , testCase "first 20 elements of partition are correct" + partitionSpecialCase20 + ] + , testGroup "Generalized pentagonal numbers" + [ testSmallAndQuick "matches definition" pentagonalNumbersProperty1 + ] + ] diff --git a/test-suite/Math/NumberTheory/SmoothNumbersTests.hs b/test-suite/Math/NumberTheory/SmoothNumbersTests.hs new file mode 100644 --- /dev/null +++ b/test-suite/Math/NumberTheory/SmoothNumbersTests.hs @@ -0,0 +1,68 @@ +-- | +-- Module: Math.NumberTheory.SmoothNumbersTests +-- Copyright: (c) 2018 Andrew Lelechenko +-- Licence: MIT +-- Maintainer: Andrew Lelechenko +-- Stability: Provisional +-- +-- Tests for Math.NumberTheory.SmoothNumbersTests +-- + +{-# OPTIONS_GHC -fno-warn-type-defaults #-} + +module Math.NumberTheory.SmoothNumbersTests + ( testSuite + ) where + +import Prelude hiding (mod) +import Test.Tasty + +import Data.Coerce +import Data.List (genericDrop, sort) +import qualified Data.Set as S +import Numeric.Natural + +import Math.NumberTheory.Euclidean +import Math.NumberTheory.SmoothNumbers +import Math.NumberTheory.TestUtils + +fromSetListProperty :: (Euclidean a, Ord a) => [a] -> Bool +fromSetListProperty xs = fromSet (S.fromList xs) == fromList (sort xs) + +fromSmoothUpperBoundProperty :: Integral a => Positive a -> Bool +fromSmoothUpperBoundProperty (Positive n') = case fromSmoothUpperBound n of + Nothing -> n < 2 + Just sb -> head (genericDrop (n - 1) (smoothOver (coerce sb))) == n + where + n = WrappedIntegral n' `mod` 5000 + +smoothOverInRangeProperty :: Integral a => SmoothBasis a -> Positive a -> Positive a -> Bool +smoothOverInRangeProperty s (Positive lo') (Positive diff') + = xs == ys + where + lo = WrappedIntegral lo' `mod` 2^18 + diff = WrappedIntegral diff' `mod` 2^18 + hi = lo + diff + xs = smoothOverInRange (coerce s) lo hi + ys = smoothOverInRangeBF (coerce s) lo hi + +testSuite :: TestTree +testSuite = testGroup "SmoothNumbers" + [ testGroup "fromSet == fromList" + [ testSmallAndQuick "Int" (fromSetListProperty :: [Int] -> Bool) + , testSmallAndQuick "Word" (fromSetListProperty :: [Word] -> Bool) + , testSmallAndQuick "Integer" (fromSetListProperty :: [Integer] -> Bool) + , testSmallAndQuick "Natural" (fromSetListProperty :: [Natural] -> Bool) + ] + , testIntegralProperty "fromSmoothUpperBound" fromSmoothUpperBoundProperty + , testGroup "smoothOverInRange == smoothOverInRangeBF" + [ testSmallAndQuick "Int" + (smoothOverInRangeProperty :: SmoothBasis Int -> Positive Int -> Positive Int -> Bool) + , testSmallAndQuick "Word" + (smoothOverInRangeProperty :: SmoothBasis Word -> Positive Word -> Positive Word -> Bool) + , testSmallAndQuick "Integer" + (smoothOverInRangeProperty :: SmoothBasis Integer -> Positive Integer -> Positive Integer -> Bool) + , testSmallAndQuick "Natural" + (smoothOverInRangeProperty :: SmoothBasis Natural -> Positive Natural -> Positive Natural -> Bool) + ] + ] diff --git a/test-suite/Math/NumberTheory/TestUtils.hs b/test-suite/Math/NumberTheory/TestUtils.hs --- a/test-suite/Math/NumberTheory/TestUtils.hs +++ b/test-suite/Math/NumberTheory/TestUtils.hs @@ -36,30 +36,33 @@ , module Math.NumberTheory.TestUtils.MyCompose , module Test.SmallCheck.Series , Large(..) + , NonZero(..) , testIntegralProperty , testSameIntegralProperty , testIntegral2Property , testSmallAndQuick + + -- * Export for @Zeta@ tests + , assertEqualUpToEps ) where import Test.SmallCheck.Series (cons2) import Test.Tasty +import Test.Tasty.HUnit (Assertion, assertBool) import Test.Tasty.SmallCheck as SC -import Test.Tasty.QuickCheck as QC hiding (Positive, NonNegative, generate, getNonNegative) +import Test.Tasty.QuickCheck as QC hiding (Positive, getPositive, NonNegative, generate, getNonNegative) import Test.SmallCheck.Series (Positive(..), NonNegative(..), Serial(..), Series, generate, (\/)) -#if !(MIN_VERSION_base(4,8,0)) -import Control.Applicative -import Data.Word -#endif - import Data.Bits import GHC.Exts import Numeric.Natural -import Math.NumberTheory.GaussianIntegers (GaussianInteger(..)) +import Math.NumberTheory.Euclidean +import qualified Math.NumberTheory.Quadratic.EisensteinIntegers as E (EisensteinInteger(..)) +import Math.NumberTheory.Quadratic.GaussianIntegers (GaussianInteger(..)) import Math.NumberTheory.Moduli.PrimitiveRoot (CyclicGroup(..)) +import qualified Math.NumberTheory.SmoothNumbers as SN import Math.NumberTheory.UniqueFactorisation (UniqueFactorisation, Prime, unPrime) import Math.NumberTheory.TestUtils.MyCompose @@ -69,23 +72,16 @@ arbitrary = fromInteger <$> (arbitrary `suchThat` (>= 0)) shrink = map fromInteger . filter (>= 0) . shrink . toInteger -instance Arbitrary GaussianInteger where - arbitrary = (:+) <$> arbitrary <*> arbitrary - shrink (x :+ y) = (:+) <$> shrink x <*> shrink y +instance Arbitrary E.EisensteinInteger where + arbitrary = (E.:+) <$> arbitrary <*> arbitrary + shrink (x E.:+ y) = map (x E.:+) (shrink y) ++ map (E.:+ y) (shrink x) -#if !(MIN_VERSION_smallcheck(1,1,3)) -instance Monad m => Serial m Word where - series = - generate (\d -> if d >= 0 then pure 0 else empty) <|> nats - where - nats = generate $ \d -> if d > 0 then [1 .. fromInteger (toInteger d)] else empty +instance Monad m => Serial m E.EisensteinInteger where + series = cons2 (E.:+) -instance Monad m => Serial m Natural where - series = - generate (\d -> if d >= 0 then pure 0 else empty) <|> nats - where - nats = generate $ \d -> if d > 0 then [1 .. fromInteger (toInteger d)] else empty -#endif +instance Arbitrary GaussianInteger where + arbitrary = (:+) <$> arbitrary <*> arbitrary + shrink (x :+ y) = map (x :+) (shrink y) ++ map (:+ y) (shrink x) instance Monad m => Serial m GaussianInteger where series = cons2 (:+) @@ -122,7 +118,16 @@ isOddPrime (PrimeWrapper p) = if (unPrime p :: a) == 2 then Nothing else Just p ------------------------------------------------------------------------------- +-- SmoothNumbers +instance (Ord a, Euclidean a, Arbitrary a) => Arbitrary (SN.SmoothBasis a) where + arbitrary = (fmap getPositive <$> arbitrary) `suchThatMap` SN.fromList + +instance (Ord a, Euclidean a, Serial m a) => Serial m (SN.SmoothBasis a) where + series = (fmap getPositive <$> series) `suchThatMapSerial` SN.fromList + +------------------------------------------------------------------------------- + -- https://www.cs.ox.ac.uk/projects/utgp/school/andres.pdf, p. 21 -- :k Compose = (k1 -> Constraint) -> (k2 -> k1) -> (k2 -> Constraint) class (f (g x)) => (f `Compose` g) x @@ -149,7 +154,7 @@ testIntegralProperty :: forall wrapper bool. (TestableIntegral wrapper, SC.Testable IO bool, QC.Testable bool) - => String -> (forall a. (Integral a, Bits a, UniqueFactorisation a, Show a) => wrapper a -> bool) -> TestTree + => String -> (forall a. (Euclidean a, Integral a, Bits a, UniqueFactorisation a, Show a) => wrapper a -> bool) -> TestTree testIntegralProperty name f = testGroup name [ SC.testProperty "smallcheck Int" (f :: wrapper Int -> bool) , SC.testProperty "smallcheck Word" (f :: wrapper Word -> bool) @@ -220,3 +225,10 @@ [ SC.testProperty "smallcheck" f , QC.testProperty "quickcheck" f ] + + +-- | Used in @Math.NumberTheory.Zeta.DirichletTests@ and +-- @Math.NumberTheory.Zeta.RiemannTests@. +assertEqualUpToEps :: String -> Double -> Double -> Double -> Assertion +assertEqualUpToEps msg eps expected actual + = assertBool msg (abs (expected - actual) < eps) diff --git a/test-suite/Math/NumberTheory/TestUtils/Wrappers.hs b/test-suite/Math/NumberTheory/TestUtils/Wrappers.hs --- a/test-suite/Math/NumberTheory/TestUtils/Wrappers.hs +++ b/test-suite/Math/NumberTheory/TestUtils/Wrappers.hs @@ -29,11 +29,6 @@ import Control.Applicative import Data.Functor.Classes -#if MIN_VERSION_base(4,8,0) -#else -import Data.Foldable (Foldable) -import Data.Traversable (Traversable) -#endif import Test.Tasty.QuickCheck as QC hiding (Positive, NonNegative, generate, getNonNegative, getPositive) import Test.SmallCheck.Series (Positive(..), NonNegative(..), Serial(..), Series) @@ -101,6 +96,12 @@ instance Show1 NonNegative where liftShowsPrec shw _ p (NonNegative a) = shw p a + +------------------------------------------------------------------------------- +-- NonZero from QuickCheck + +instance (Monad m, Num a, Eq a, Serial m a) => Serial m (NonZero a) where + series = NonZero <$> series `suchThatSerial` (/= 0) ------------------------------------------------------------------------------- -- Huge diff --git a/test-suite/Math/NumberTheory/UniqueFactorisationTests.hs b/test-suite/Math/NumberTheory/UniqueFactorisationTests.hs --- a/test-suite/Math/NumberTheory/UniqueFactorisationTests.hs +++ b/test-suite/Math/NumberTheory/UniqueFactorisationTests.hs @@ -19,12 +19,7 @@ import Test.Tasty -#if MIN_VERSION_base(4,8,0) -#else -import Data.Word -#endif - -import Math.NumberTheory.GaussianIntegers hiding (factorise) +import Math.NumberTheory.Quadratic.GaussianIntegers hiding (factorise) import Math.NumberTheory.UniqueFactorisation import Math.NumberTheory.TestUtils diff --git a/test-suite/Math/NumberTheory/Zeta/DirichletTests.hs b/test-suite/Math/NumberTheory/Zeta/DirichletTests.hs new file mode 100644 --- /dev/null +++ b/test-suite/Math/NumberTheory/Zeta/DirichletTests.hs @@ -0,0 +1,115 @@ +-- | +-- Module: Math.NumberTheory.Zeta.DirichletTests +-- Copyright: (c) 2018 Alexandre Rodrigues Baldé +-- Licence: MIT +-- Maintainer: Alexandre Rodrigues Baldé +-- Stability: Provisional +-- +-- Tests for Math.NumberTheory.Zeta.Dirichlet +-- + +{-# OPTIONS_GHC -fno-warn-type-defaults #-} + +module Math.NumberTheory.Zeta.DirichletTests + ( testSuite + ) where + +import Data.ExactPi (approximateValue) + +import Test.Tasty +import Test.Tasty.HUnit (Assertion, assertEqual, testCase) + +import Math.NumberTheory.Zeta (betas, betasOdd) +import Math.NumberTheory.TestUtils + +epsilon :: Double +epsilon = 1e-14 + +betas' :: [Double] +betas' = betas epsilon + +betasOddSpecialCase1 :: Assertion +betasOddSpecialCase1 + = assertEqualUpToEps "beta(1) = pi/4" epsilon + (approximateValue $ betasOdd !! 0) + (pi / 4) + +betasOddSpecialCase2 :: Assertion +betasOddSpecialCase2 + = assertEqualUpToEps "beta(3) = pi^3/32" epsilon + (approximateValue $ betasOdd !! 1) + (pi^3 / 32) + +betasOddSpecialCase3 :: Assertion +betasOddSpecialCase3 + = assertEqualUpToEps "beta(5) = 5*pi^5/1536" epsilon + (approximateValue $ betasOdd !! 2) + ((5 * pi^5) / 1536) + +betasOddProperty1 :: Positive Int -> Bool +betasOddProperty1 (Positive m) + = betaM < 1 + || betaM < betaM1 + where + betaM = approximateValue (betasOdd !! m) + betaM1 = approximateValue (betasOdd !! (m + 1)) + +betasOddProperty2 :: NonNegative Int -> Bool +betasOddProperty2 (NonNegative m) + = abs (betaM - betaM') < epsilon + where + betaM = approximateValue (betasOdd !! m) + betaM' = betas' !! ((2 * m) + 1) + +betasSpecialCase1 :: Assertion +betasSpecialCase1 + = assertEqual "beta(0) = 1/2" + (betas' !! 0) + (1 / 2) + +betasSpecialCase2 :: Assertion +betasSpecialCase2 + = assertEqualUpToEps "beta(2) = 0.9159655" epsilon + (betas' !! 2) + (0.9159655941772190150546035149323841107) + +betasSpecialCase3 :: Assertion +betasSpecialCase3 + = assertEqualUpToEps "beta(4) = 0.9889445" epsilon + (betas' !! 4) + (0.9889445517411053361084226332283778213) + +betasProperty1 :: Positive Int -> Bool +betasProperty1 (Positive m) + = betaM <= betaM1 + && betaM1 <= 1 + where + betaM = betas' !! m + betaM1 = betas' !! (m + 1) + +betasProperty2 :: NonNegative Int -> NonNegative Int -> Bool +betasProperty2 (NonNegative e1) (NonNegative e2) + = maximum (take 10 $ drop 2 $ zipWith ((abs .) . (-)) (betas eps1) (betas eps2)) <= eps1 + eps2 + where + eps1, eps2 :: Double + eps1 = (1.0 / 2) ^ e1 + eps2 = (1.0 / 2) ^ e2 + + +testSuite :: TestTree +testSuite = testGroup "Beta" + [ testGroup "betasOdd" + [ testCase "beta(1)" betasOddSpecialCase1 + , testCase "beta(3)" betasOddSpecialCase2 + , testCase "beta(5)" betasOddSpecialCase3 + , testSmallAndQuick "beta(2n-1) < beta(2n+1)" betasOddProperty1 + , testSmallAndQuick "betasOdd matches betas" betasOddProperty2 + ] + , testGroup "betas" + [ testCase "beta(0)" betasSpecialCase1 + , testCase "beta(2)" betasSpecialCase2 + , testCase "beta(4)" betasSpecialCase3 + , testSmallAndQuick "beta(n) < beta(n+1)" betasProperty1 + , testSmallAndQuick "precision" betasProperty2 + ] + ] diff --git a/test-suite/Math/NumberTheory/Zeta/RiemannTests.hs b/test-suite/Math/NumberTheory/Zeta/RiemannTests.hs new file mode 100644 --- /dev/null +++ b/test-suite/Math/NumberTheory/Zeta/RiemannTests.hs @@ -0,0 +1,118 @@ +-- | +-- Module: Math.NumberTheory.Zeta.RiemannTests +-- Copyright: (c) 2016 Andrew Lelechenko +-- Licence: MIT +-- Maintainer: Andrew Lelechenko +-- Stability: Provisional +-- +-- Tests for Math.NumberTheory.Zeta.Riemann +-- + +{-# OPTIONS_GHC -fno-warn-type-defaults #-} + +module Math.NumberTheory.Zeta.RiemannTests + ( testSuite + ) where + +import Data.ExactPi (approximateValue) + +import Test.Tasty +import Test.Tasty.HUnit (Assertion, assertEqual, testCase) + +import Math.NumberTheory.Zeta +import Math.NumberTheory.TestUtils + +epsilon :: Double +epsilon = 1e-14 + +zetasEvenSpecialCase1 :: Assertion +zetasEvenSpecialCase1 + = assertEqual "zeta(0) = -1/2" + (approximateValue $ zetasEven !! 0) + (-1 / 2) + +zetasEvenSpecialCase2 :: Assertion +zetasEvenSpecialCase2 + = assertEqualUpToEps "zeta(2) = pi^2/6" epsilon + (approximateValue $ zetasEven !! 1) + (pi * pi / 6) + +zetasEvenSpecialCase3 :: Assertion +zetasEvenSpecialCase3 + = assertEqualUpToEps "zeta(4) = pi^4/90" epsilon + (approximateValue $ zetasEven !! 2) + (pi ^ 4 / 90) + +zetasEvenProperty1 :: Positive Int -> Bool +zetasEvenProperty1 (Positive m) + = zetaM < 1 + || zetaM > zetaM1 + where + zetaM = approximateValue (zetasEven !! m) + zetaM1 = approximateValue (zetasEven !! (m + 1)) + +zetasEvenProperty2 :: Positive Int -> Bool +zetasEvenProperty2 (Positive m) + = abs (zetaM - zetaM') < epsilon + where + zetaM = approximateValue (zetasEven !! m) + zetaM' = zetas' !! (2 * m) + +zetas' :: [Double] +zetas' = zetas epsilon + +zetasSpecialCase1 :: Assertion +zetasSpecialCase1 + = assertEqual "zeta(1) = Infinity" + (zetas' !! 1) + (1 / 0) + +zetasSpecialCase2 :: Assertion +zetasSpecialCase2 + = assertEqualUpToEps "zeta(3) = 1.2020569" epsilon + (zetas' !! 3) + 1.2020569031595942853997381615114499908 + +zetasSpecialCase3 :: Assertion +zetasSpecialCase3 + = assertEqualUpToEps "zeta(5) = 1.0369277" epsilon + (zetas' !! 5) + 1.0369277551433699263313654864570341681 + +zetasProperty1 :: Positive Int -> Bool +zetasProperty1 (Positive m) + = zetaM >= zetaM1 + && zetaM1 >= 1 + where + zetaM = zetas' !! m + zetaM1 = zetas' !! (m + 1) + +-- | Let z1 be an approximation of z with precision eps1, +-- and z2 be an approximation of the same value with precision eps2. +-- Then (independently of the true value of z) +-- abs (z1 - z2) < eps1 + eps2. +zetasProperty2 :: NonNegative Int -> NonNegative Int -> Bool +zetasProperty2 (NonNegative e1) (NonNegative e2) + = maximum (take 25 $ drop 2 $ zipWith ((abs .) . (-)) (zetas eps1) (zetas eps2)) < eps1 + eps2 + where + eps1, eps2 :: Double + eps1 = 1.0 / 2 ^ e1 + eps2 = 1.0 / 2 ^ e2 + +testSuite :: TestTree +testSuite = testGroup "Zeta" + [ testGroup "zetasEven" + [ testCase "zeta(0)" zetasEvenSpecialCase1 + , testCase "zeta(2)" zetasEvenSpecialCase2 + , testCase "zeta(4)" zetasEvenSpecialCase3 + , testSmallAndQuick "zeta(2n) > zeta(2n+2)" zetasEvenProperty1 + , testSmallAndQuick "zetasEven matches zetas" zetasEvenProperty2 + ] + , testGroup "zetas" + [ testCase "zeta(1)" zetasSpecialCase1 + , testCase "zeta(3)" zetasSpecialCase2 + , testCase "zeta(5)" zetasSpecialCase3 + , testSmallAndQuick "zeta(n) > zeta(n+1)" zetasProperty1 + , testSmallAndQuick "precision" zetasProperty2 + ] + ] diff --git a/test-suite/Math/NumberTheory/ZetaTests.hs b/test-suite/Math/NumberTheory/ZetaTests.hs deleted file mode 100644 --- a/test-suite/Math/NumberTheory/ZetaTests.hs +++ /dev/null @@ -1,116 +0,0 @@ --- | --- Module: Math.NumberTheory.ZetaTests --- Copyright: (c) 2016 Andrew Lelechenko --- Licence: MIT --- Maintainer: Andrew Lelechenko --- Stability: Provisional --- --- Tests for Math.NumberTheory.Zeta --- - -{-# OPTIONS_GHC -fno-warn-type-defaults #-} - -module Math.NumberTheory.ZetaTests - ( testSuite - ) where - -import Test.Tasty -import Test.Tasty.HUnit - -import Math.NumberTheory.Zeta -import Math.NumberTheory.TestUtils - -assertEqualUpToEps :: String -> Double -> Double -> Double -> Assertion -assertEqualUpToEps msg eps expected actual - = assertBool msg (abs (expected - actual) < eps) - -epsilon :: Double -epsilon = 1e-14 - -zetasEvenSpecialCase1 :: Assertion -zetasEvenSpecialCase1 - = assertEqual "zeta(0) = -1/2" - (approximateValue $ zetasEven !! 0) - (-1 / 2) - -zetasEvenSpecialCase2 :: Assertion -zetasEvenSpecialCase2 - = assertEqualUpToEps "zeta(2) = pi^2/6" epsilon - (approximateValue $ zetasEven !! 1) - (pi * pi / 6) - -zetasEvenSpecialCase3 :: Assertion -zetasEvenSpecialCase3 - = assertEqualUpToEps "zeta(4) = pi^4/90" epsilon - (approximateValue $ zetasEven !! 2) - (pi ^ 4 / 90) - -zetasEvenProperty1 :: Positive Int -> Bool -zetasEvenProperty1 (Positive m) - = zetaM < 1 - || zetaM > zetaM1 - where - zetaM = approximateValue (zetasEven !! m) - zetaM1 = approximateValue (zetasEven !! (m + 1)) - -zetasEvenProperty2 :: Positive Int -> Bool -zetasEvenProperty2 (Positive m) - = abs (zetaM - zetaM') < epsilon - where - zetaM = approximateValue (zetasEven !! m) - zetaM' = zetas' !! (2 * m) - -zetas' :: [Double] -zetas' = zetas epsilon - -zetasSpecialCase1 :: Assertion -zetasSpecialCase1 - = assertEqual "zeta(1) = Infinity" - (zetas' !! 1) - (1 / 0) - -zetasSpecialCase2 :: Assertion -zetasSpecialCase2 - = assertEqualUpToEps "zeta(3) = 1.2020569" epsilon - (zetas' !! 3) - 1.2020569031595942853997381615114499908 - -zetasSpecialCase3 :: Assertion -zetasSpecialCase3 - = assertEqualUpToEps "zeta(5) = 1.0369277" epsilon - (zetas' !! 5) - 1.0369277551433699263313654864570341681 - -zetasProperty1 :: Positive Int -> Bool -zetasProperty1 (Positive m) - = zetaM >= zetaM1 - && zetaM1 >= 1 - where - zetaM = zetas' !! m - zetaM1 = zetas' !! (m + 1) - -zetasProperty2 :: NonNegative Int -> NonNegative Int -> Bool -zetasProperty2 (NonNegative e1) (NonNegative e2) - = maximum (take 25 $ drop 2 $ zipWith ((abs .) . (-)) (zetas eps1) (zetas eps2)) < eps1 + eps2 - where - eps1, eps2 :: Double - eps1 = 1.0 / 2 ^ e1 - eps2 = 1.0 / 2 ^ e2 - -testSuite :: TestTree -testSuite = testGroup "Zeta" - [ testGroup "zetasEven" - [ testCase "zeta(0)" zetasEvenSpecialCase1 - , testCase "zeta(2)" zetasEvenSpecialCase2 - , testCase "zeta(4)" zetasEvenSpecialCase3 - , testSmallAndQuick "zeta(2n) > zeta(2n+2)" zetasEvenProperty1 - , testSmallAndQuick "zetasEven matches zetas" zetasEvenProperty2 - ] - , testGroup "zetas" - [ testCase "zeta(1)" zetasSpecialCase1 - , testCase "zeta(3)" zetasSpecialCase2 - , testCase "zeta(5)" zetasSpecialCase3 - , testSmallAndQuick "zeta(n) > zeta(n+1)" zetasProperty1 - , testSmallAndQuick "precision" zetasProperty2 - ] - ] diff --git a/test-suite/Test.hs b/test-suite/Test.hs --- a/test-suite/Test.hs +++ b/test-suite/Test.hs @@ -1,13 +1,15 @@ import Test.Tasty import qualified Math.NumberTheory.GCDTests as GCD -import qualified Math.NumberTheory.GCD.LowLevelTests as GCDLowLevel +import qualified Math.NumberTheory.Recurrencies.PentagonalTests as RecurrenciesPentagonal import qualified Math.NumberTheory.Recurrencies.BilinearTests as RecurrenciesBilinear import qualified Math.NumberTheory.Recurrencies.LinearTests as RecurrenciesLinear import qualified Math.NumberTheory.Moduli.ChineseTests as ModuliChinese import qualified Math.NumberTheory.Moduli.ClassTests as ModuliClass +import qualified Math.NumberTheory.Moduli.DiscreteLogarithmTests as ModuliDiscreteLogarithm +import qualified Math.NumberTheory.Moduli.EquationsTests as ModuliEquations import qualified Math.NumberTheory.Moduli.JacobiTests as ModuliJacobi import qualified Math.NumberTheory.Moduli.PrimitiveRootTests as ModuliPrimitiveRoot import qualified Math.NumberTheory.Moduli.SqrtTests as ModuliSqrt @@ -29,15 +31,20 @@ import qualified Math.NumberTheory.Primes.SieveTests as Sieve import qualified Math.NumberTheory.Primes.TestingTests as Testing +import qualified Math.NumberTheory.EisensteinIntegersTests as Eisenstein + import qualified Math.NumberTheory.GaussianIntegersTests as Gaussian import qualified Math.NumberTheory.ArithmeticFunctionsTests as ArithmeticFunctions import qualified Math.NumberTheory.ArithmeticFunctions.MertensTests as Mertens import qualified Math.NumberTheory.ArithmeticFunctions.SieveBlockTests as SieveBlock import qualified Math.NumberTheory.UniqueFactorisationTests as UniqueFactorisation -import qualified Math.NumberTheory.ZetaTests as Zeta import qualified Math.NumberTheory.CurvesTests as Curves +import qualified Math.NumberTheory.SmoothNumbersTests as SmoothNumbers +import qualified Math.NumberTheory.Zeta.RiemannTests as Riemann +import qualified Math.NumberTheory.Zeta.DirichletTests as Dirichlet + main :: IO () main = defaultMain tests @@ -50,17 +57,17 @@ , Modular.testSuite , Squares.testSuite ] - , testGroup "GCD" - [ GCD.testSuite - , GCDLowLevel.testSuite - ] + , GCD.testSuite , testGroup "Recurrencies" - [ RecurrenciesLinear.testSuite + [ RecurrenciesPentagonal.testSuite + , RecurrenciesLinear.testSuite , RecurrenciesBilinear.testSuite ] , testGroup "Moduli" [ ModuliChinese.testSuite , ModuliClass.testSuite + , ModuliDiscreteLogarithm.testSuite + , ModuliEquations.testSuite , ModuliJacobi.testSuite , ModuliPrimitiveRoot.testSuite , ModuliSqrt.testSuite @@ -69,9 +76,7 @@ [ MoebiusInversion.testSuite , MoebiusInversionInt.testSuite ] - , testGroup "Prefactored" - [ Prefactored.testSuite - ] + , Prefactored.testSuite , testGroup "Primes" [ Primes.testSuite , Counting.testSuite @@ -79,21 +84,19 @@ , Sieve.testSuite , Testing.testSuite ] - , testGroup "Gaussian" - [ Gaussian.testSuite - ] + , Eisenstein.testSuite + , Gaussian.testSuite , testGroup "ArithmeticFunctions" [ ArithmeticFunctions.testSuite , Mertens.testSuite , SieveBlock.testSuite ] - , testGroup "UniqueFactorisation" - [ UniqueFactorisation.testSuite - ] + , UniqueFactorisation.testSuite + , Curves.testSuite + , SmoothNumbers.testSuite + , testGroup "Zeta" - [ Zeta.testSuite - ] - , testGroup "Curves" - [ Curves.testSuite + [ Riemann.testSuite + , Dirichlet.testSuite ] ]