packages feed

arithmoi 0.6.0.1 → 0.13.4.0

raw patch · 154 files changed

Files

− Changes 
@@ -1,150 +0,0 @@-0.6.0.1:-    Switch to smallcheck 1.1.3.--0.6.0.0:-    This release supports GHC 7.8, 7.10, 8.0 and 8.2.--    Breaking changes:--        'Math.NumberTheory.Moduli' was split into-        'Math.NumberTheory.Moduli.{Chinese,Class,Jacobi,Sqrt}'.--        Functions 'jacobi' and 'jacobi'' return 'JacobiSymbol'-        instead of 'Int'.--        Functions 'invertMod', 'powerMod' and 'powerModInteger' were removed,-        as well as their unchecked counterparts. Use new interface to-        modular computations, provided by 'Math.NumberTheory.Moduli.Class'.--    New functions:--        Brand new 'Math.NumberTheory.Moduli.Class' (#56), providing-        flexible and type safe modular arithmetic. Due to use of GMP built-ins-        it is also significantly faster.--        New function 'divisorsList', which is lazier than 'divisors' and-        does not require 'Ord' constraint (#64). Thus, it can be used-        for 'GaussianInteger'.--    Improvements:--        Speed up factorisation over elliptic curve up to 15x (#65).--        Polymorphic 'fibonacci' and 'lucas' functions, which previously-        were restricted to 'Integer' only (#63). This is especially useful-        for modular computations, e. g., 'map fibonacci [1..10] :: [Mod 7]'.--        Make 'totientSum' more robust and idiomatic (#58).--0.5.0.1:-    Switch to QuickCheck 2.10.--0.5.0.0:-    This release supports GHC 7.8, 7.10 and 8.0. GHC 7.6 is no longer supported.--    Breaking changes:--        Remove deprecated interface to arithmetic functions (divisors, tau,-        sigma, totient, jordan, moebius, liouville, smallOmega, bigOmega,-        carmichael, expMangoldt). New interface is exposed via-        Math.NumberTheory.ArithmeticFunctions (#30).--        Deprecate integerPower and integerWordPower from-        Math.NumberTheory.Powers.Integer. Use (^) instead (#51).--        Math.NumberTheory.Logarithms has been moved to the separate package-        integer-logarithms (#51).--        Rename Math.NumberTheory.Lucas to Math.NumberTheory.Recurrencies.Linear.--    New functions:--        Add basic combinatorial sequences: binomial coefficients, Stirling-        numbers of both kinds, Eulerian numbers of both kinds, Bernoulli-        numbers (#39). E. g.,--        > take 10 $ Math.NumberTheory.Recurrencies.Bilinear.bernoulli-        [1 % 1,(-1) % 2,1 % 6,0 % 1,(-1) % 30,0 % 1,1 % 42,0 % 1,(-1) % 30,0 % 1]--        Add the Riemann zeta function on non-negative integer arguments (#44).-        E. g.,--        > take 5 $ Math.NumberTheory.Zeta.zetas 1e-15-        [-0.5,Infinity,1.6449340668482262,1.2020569031595945,1.0823232337111381]--    Improvements:--        Speed up isPrime twice; rework millerRabinV and isStrongFermatPP (#22, #25).--0.4.3.0:-    This release supports GHC 7.6, 7.8, 7.10 and 8.0.--    Add Math.NumberTheory.ArithmeticFunctions with brand-new machinery-    for arithmetic functions: divisors, tau, sigma, totient, jordan,-    moebius, liouville, smallOmega, bigOmega, carmichael, expMangoldt (#30).-    Old implementations (exposed via Math.NumberTheory.Primes.Factorisation-    and Math.NumberTheory.Powers.Integer) are deprecated and will be removed-    in the next major release.--    Add Karatsuba sqrt algorithm, improving performance on large integers (#6).--    Fix incorrect indexing of FactorSieve (#35).--0.4.2.0:-    This release supports GHC 7.6, 7.8, 7.10 and 8.0.--    Add new cabal flag check-bounds, which replaces all unsafe array functions with safe ones.--    Add basic functions on Gaussian integers.-    Add Moebius mu-function.--    Forbid non-positive moduli in Math.NumberTheory.Moduli.--    Fix out-of-bounds error in Math.NumberTheory.Primes.Heap, Math.NumberTheory.Primes.Sieve and Math.NumberTheory.MoebiusInversion.-    Fix 32-bit build.-    Fix binaryGCD on negative numbers.-    Fix highestPower (various issues).--0.4.1.0:-    Add integerLog10 variants at Bas van Dijk's request and expose-    Math.NumberTheory.Powers.Integer, with an added integerWordPower.-0.4.0.4:-    Update for GHC-7.8, the type of some primops changed, they return Int# now-    instead of Bool.-    Fixed bugs in modular square roots and factorisation.-0.4.0.3:-    Relaxed dependencies on mtl and containers-    Fixed warnings from GHC-7.5, Word(..) moved to GHC.Types-    Removed SPECIALISE pragma from inline function (warning from 7.5, probably-    pointless anyway)-0.4.0.2:-    Sped up factor sieves. They need more space now, but the speedup is worth it, IMO.-    Raised spec-constr limit in MoebiusInversion.Int-0.4.0.1:-    Fixed Haddock bug-0.4.0.0:-    Added generalised Moebius inversion, to be continued-0.3.0.0:-    Added modular square roots and Chinese remainder theorem-0.2.0.6:-    Performance tweaks for powerModInteger (~10%) and-    invertMod (~25%).-0.2.0.5:-    Fix bug in psieveFrom-0.2.0.4:-    Fix bug in nthPrime-0.2.0.3:-    Fix bug in powerMod-0.2.0.2:-    Relax bounds on array dependency for 7.4.*-0.2.0.1:-    Fix copy-pasto (only relevant for 7.3.*)-    Fix imports for ghc >= 7.3-0.2.0.0:-    Added certificates and certified testing/factorisation-0.1.0.2:-    Fixed doc bugs-0.1.0.1:-    Elaborate on overflow, work more on native Ints in Eratosthenes-0.1.0.0:-    First release
− GHC/TypeNats/Compat.hs 
@@ -1,36 +0,0 @@-{-# LANGUAGE CPP         #-}--{-# OPTIONS_HADDOCK hide #-}--#if MIN_VERSION_base(4,10,0)--module GHC.TypeNats.Compat-  ( module GHC.TypeNats-  ) where--import GHC.TypeNats--#else--module GHC.TypeNats.Compat-  ( Nat-  , KnownNat-  , SomeNat(..)-  , natVal-  , someNatVal-  , sameNat-  ) where--import GHC.TypeLits (Nat, KnownNat, SomeNat(..), sameNat)-import qualified GHC.TypeLits as TL-import Numeric.Natural--natVal :: KnownNat n => proxy n -> Natural-natVal = fromInteger . TL.natVal--someNatVal :: Natural -> SomeNat-someNatVal n = case TL.someNatVal (toInteger n) of-  Nothing -> error "someNatVal: impossible negative argument"-  Just sn -> sn--#endif
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2011 Daniel Fischer, 2016-2017 Andrew Lelechenko, Carter Schonwald+Copyright (c) 2011 Daniel Fischer, 2016-2017 Andrew Lelechenko, Carter Schonwald, Google Inc.  Permission is hereby granted, free of charge, to any person obtaining a copy of this software and  associated documentation files (the "Software"), to deal in the Software without restriction,
Math/NumberTheory/ArithmeticFunctions.hs view
@@ -3,8 +3,6 @@ -- Copyright:   (c) 2016 Andrew Lelechenko -- Licence:     MIT -- Maintainer:  Andrew Lelechenko <andrew.lelechenko@gmail.com>--- Stability:   Provisional--- Portability: Non-portable (GHC extensions) -- -- This module provides an interface for defining and manipulating -- arithmetic functions. It also defines several most widespreaded
Math/NumberTheory/ArithmeticFunctions/Class.hs view
@@ -3,32 +3,23 @@ -- Copyright:   (c) 2016 Andrew Lelechenko -- Licence:     MIT -- Maintainer:  Andrew Lelechenko <andrew.lelechenko@gmail.com>--- Stability:   Provisional--- Portability: Non-portable (GHC extensions) -- -- Generic type for arithmetic functions over arbitrary unique -- factorisation domains. -- -{-# LANGUAGE CPP                 #-} {-# LANGUAGE GADTs               #-} -{-# OPTIONS_HADDOCK hide #-}- module Math.NumberTheory.ArithmeticFunctions.Class   ( ArithmeticFunction(..)   , runFunction+  , runFunctionOnFactors   ) where  import Control.Applicative-import Data.Semigroup--#if MIN_VERSION_base(4,8,0)-#else-import Data.Word-#endif+import Prelude hiding (Applicative(..)) -import Math.NumberTheory.UniqueFactorisation+import Math.NumberTheory.Primes  -- | A typical arithmetic function operates on the canonical factorisation of -- a number into prime's powers and consists of two rules. The first one@@ -37,8 +28,8 @@ -- -- In the following definition the first argument is the function on prime's -- powers, the monoid instance determines a rule of combination (typically--- 'Product' or 'Sum'), and the second argument is convenient for unwrapping--- (typically, 'getProduct' or 'getSum').+-- 'Data.Semigroup.Product' or 'Data.Semigroup.Sum'), and the second argument is convenient for unwrapping+-- (typically, 'Data.Semigroup.getProduct' or 'Data.Semigroup.getSum'). data ArithmeticFunction n a where   ArithmeticFunction     :: Monoid m@@ -46,13 +37,16 @@     -> (m -> a)     -> ArithmeticFunction n a --- | Convert to function. The value on 0 is undefined.+-- | Convert to a function. The value on 0 is undefined. runFunction :: UniqueFactorisation n => ArithmeticFunction n a -> n -> a-runFunction (ArithmeticFunction f g)+runFunction f = runFunctionOnFactors f . factorise++-- | Convert to a function on prime factorisation.+runFunctionOnFactors :: ArithmeticFunction n a -> [(Prime n, Word)] -> a+runFunctionOnFactors (ArithmeticFunction f g)   = g   . mconcat   . map (uncurry f)-  . factorise  instance Functor (ArithmeticFunction n) where   fmap f (ArithmeticFunction g h) = ArithmeticFunction g (f . h)@@ -62,13 +56,14 @@     = ArithmeticFunction (\_ _ -> ()) (const x)   (ArithmeticFunction f1 g1) <*> (ArithmeticFunction f2 g2)     = ArithmeticFunction (\p k -> (f1 p k, f2 p k)) (\(a1, a2) -> g1 a1 (g2 a2))+  liftA2 h (ArithmeticFunction f1 g1) (ArithmeticFunction f2 g2)+    = ArithmeticFunction (\p k -> (f1 p k, f2 p k)) (\(a1, a2) -> h (g1 a1) (g2 a2))  instance Semigroup a => Semigroup (ArithmeticFunction n a) where   (<>) = liftA2 (<>)  instance Monoid a => Monoid (ArithmeticFunction n a) where   mempty  = pure mempty-  mappend = liftA2 mappend  -- | Factorisation is expensive, so it is better to avoid doing it twice. -- Write 'runFunction (f + g) n' instead of 'runFunction f n + runFunction g n'.
+ Math/NumberTheory/ArithmeticFunctions/Inverse.hs view
@@ -0,0 +1,453 @@+-- |+-- Module:      Math.NumberTheory.ArithmeticFunctions.Inverse+-- Copyright:   (c) 2018 Andrew Lelechenko+-- Licence:     MIT+-- Maintainer:  Andrew Lelechenko <andrew.lelechenko@gmail.com>+--+-- Computing inverses of multiplicative functions.+-- The implementation is based on+-- <https://www.emis.de/journals/JIS/VOL19/Alekseyev/alek5.pdf Computing the Inverses, their Power Sums, and Extrema for Euler’s Totient and Other Multiplicative Functions>+-- by M. A. Alekseyev.++{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Math.NumberTheory.ArithmeticFunctions.Inverse+  ( inverseTotient+  , inverseJordan+  , inverseSigma+  , inverseSigmaK+  , -- * Wrappers+    MinWord(..)+  , MaxWord(..)+  , MinNatural(..)+  , MaxNatural(..)+  , -- * Utils+    asSetOfPreimages+  ) where++import Prelude hiding (rem, quot, Foldable(..))+import Data.Bits (Bits)+import Data.Euclidean+import Data.Foldable+import Data.List (partition, sortOn)+import Data.Map (Map)+import qualified Data.Map as M+import Data.Maybe+import Data.Ord (Down(..))+import Data.Semiring (Semiring(..), Mul(..))+import Data.Set (Set)+import qualified Data.Set as S+import Data.Traversable+import Numeric.Natural++import Math.NumberTheory.ArithmeticFunctions+import Math.NumberTheory.Logarithms+import Math.NumberTheory.Roots (exactRoot, integerRoot)+import Math.NumberTheory.Primes+import Math.NumberTheory.Utils.DirichletSeries (DirichletSeries)+import qualified Math.NumberTheory.Utils.DirichletSeries as DS+import Math.NumberTheory.Utils.FromIntegral++data PrimePowers a = PrimePowers+  { _ppPrime  :: Prime a+  , _ppPowers :: [Word] -- sorted list+  }++instance Show a => Show (PrimePowers a) where+  show (PrimePowers p xs) = "PP " ++ show (unPrime p) ++ " " ++ show xs++-- | Convert a list of powers of a prime into an atomic Dirichlet series+-- (Section 4, Step 2).+atomicSeries+  :: Num a+  => (a -> b)               -- ^ How to inject a number into a semiring+  -> ArithmeticFunction a c -- ^ Arithmetic function, which we aim to inverse+  -> PrimePowers a          -- ^ List of powers of a prime+  -> DirichletSeries c b    -- ^ Atomic Dirichlet series+atomicSeries point (ArithmeticFunction f g) (PrimePowers p ks) =+  DS.fromDistinctAscList (map (\k -> (g (f p k), point (unPrime p ^ k))) ks)++-- | See section 5.1 of the paper.+invJordan+  :: forall a. (Integral a, UniqueFactorisation a, Eq a)+  => Word+  -- ^ Value of k in 'jordan' k+  -> [(Prime a, Word)]+  -- ^ Factorisation of a value of the totient function+  -> [PrimePowers a]+  -- ^ Possible prime factors of an argument of the totient function+invJordan k fs = map (\p -> PrimePowers p (doPrime p)) ps+  where+    divs :: [a]+    divs = runFunctionOnFactors divisorsListA fs++    ps :: [Prime a]+    ps = mapMaybe (\d -> exactRoot k (d + 1) >>= isPrime) divs++    doPrime :: Prime a -> [Word]+    doPrime p = case lookup p fs of+      Nothing -> [1]+      Just w  -> [1 .. w+1]++-- | See section 5.2 of the paper.+invSigma+  :: forall a. (Euclidean a, Integral a, UniqueFactorisation a, Enum (Prime a), Bits a)+  => Word+  -- ^ Value of k in 'sigma' k+  -> [(Prime a, Word)]+  -- ^ Factorisation of a value of the sum-of-divisors function+  -> [PrimePowers a]+  -- ^ Possible prime factors of an argument of the sum-of-divisors function+invSigma k fs+  = map (\(x, ys) -> PrimePowers x (S.toList ys))+  $ M.assocs+  $ M.unionWith (<>) pksSmall pksLarge+  where+    numDivs :: a+    numDivs = runFunctionOnFactors tauA fs++    divs :: [a]+    divs = runFunctionOnFactors divisorsListA fs++    n :: a+    n = factorBack fs++    -- There are two possible strategies to find possible prime factors+    -- of an argument of the sum-of-divisors function.+    -- 1. Take each prime p and each power e such that p^e <= n,+    -- compute sigma(p^e) and check whether it is a divisor of n.+    -- (corresponds to 'pksSmall' below)+    -- 2. Take each divisor d of n and each power e such that e <= log_2 d,+    -- compute p = floor(e-th root of (d - 1)) and check whether sigma(p^e) = d+    -- and p is actually prime (correposnds to 'pksLarge' below).+    --+    -- Asymptotically the second strategy is beneficial, but computing+    -- exact e-th roots of huge integers (especially when they exceed MAX_DOUBLE)+    -- is very costly. That is why we employ the first strategy for primes+    -- below limit 'lim' and the second one for larger ones. This allows us+    -- to loop over e <= log_lim d which is much smaller than log_2 d.+    --+    -- The value of 'lim' below was chosen heuristically;+    -- it may be tuned in future in accordance with new experimental data.+    lim :: a+    lim = numDivs `max` 2++    pksSmall :: Map (Prime a) (Set Word)+    pksSmall = M.fromDistinctAscList+      [ (p, pows)+      | p <- [nextPrime 2 .. precPrime lim]+      , let pows = doPrime p+      , not (null pows)+      ]++    doPrime :: Prime a -> Set Word+    doPrime p' = let p = unPrime p' in S.fromDistinctAscList+      [ e+      | e <- [1 .. intToWord (integerLogBase (toInteger (p ^ k)) (toInteger n))]+      , n `rem` ((p ^ (k * (e + 1)) - 1) `quot` (p ^ k - 1)) == 0+      ]++    pksLarge :: Map (Prime a) (Set Word)+    pksLarge = M.unionsWith (<>)+      [ maybe mempty (`M.singleton` S.singleton e) (isPrime p)+      | d <- divs+      , e <- [1 .. intToWord (quot (integerLogBase (toInteger lim) (toInteger d)) (wordToInt k)) ]+      , let p = integerRoot (e * k) (d - 1)+      , p ^ (k * (e + 1)) - 1 == d * (p ^ k - 1)+      ]++-- | Instead of multiplying all atomic series and filtering out everything,+-- which is not divisible by @n@, we'd rather split all atomic series into+-- a couple of batches, each of which corresponds to a prime factor of @n@.+-- This allows us to crop resulting Dirichlet series (see 'filter' calls+-- in @invertFunction@ below) at the end of each batch, saving time and memory.+strategy+  :: forall a c. (GcdDomain c, Ord c)+  => ArithmeticFunction a c+  -- ^ Arithmetic function, which we aim to inverse+  -> [(Prime c, Word)]+  -- ^ Factorisation of a value of the arithmetic function+  -> [PrimePowers a]+  -- ^ Possible prime factors of an argument of the arithmetic function+  -> [(Maybe (Prime c, Word), [PrimePowers a])]+  -- ^ Batches, corresponding to each element of the factorisation of a value+strategy (ArithmeticFunction f g) factors args = (Nothing, ret) : rets+  where+    (ret, rets)+      = mapAccumL go args+      $ sortOn (Down . fst) factors++    go+      :: [PrimePowers a]+      -> (Prime c, Word)+      -> ([PrimePowers a], (Maybe (Prime c, Word), [PrimePowers a]))+    go ts (p, k) = (rs, (Just (p, k), qs))+      where+        predicate (PrimePowers q ls) = any (\l -> isJust $ g (f q l) `divide` unPrime p) ls+        (qs, rs) = partition predicate ts++-- | Main workhorse.+invertFunction+  :: forall a b c.+     (Num a, Semiring b, Euclidean c, UniqueFactorisation c, Ord c)+  => (a -> b)+  -- ^ How to inject a number into a semiring+  -> ArithmeticFunction a c+  -- ^ Arithmetic function, which we aim to inverse+  -> ([(Prime c, Word)] -> [PrimePowers a])+  -- ^ How to find possible prime factors of the argument+  -> c+  -- ^ Value of the arithmetic function, which we aim to inverse+  -> b+  -- ^ Semiring element, representing preimages+invertFunction point f invF n+  = DS.lookup n+  $ foldl' (flip (uncurry processBatch)) (DS.fromDistinctAscList []) batches+  where+    factors = factorise n+    batches = strategy f factors $ invF factors++    processBatch+      :: Maybe (Prime c, Word)+      -> [PrimePowers a]+      -> DirichletSeries c b+      -> DirichletSeries c b+    processBatch Nothing xs acc+      = foldl' (DS.timesAndCrop n) acc+      $ map (atomicSeries point f) xs++    -- This is equivalent to the next, general case, but is faster,+    -- since it avoids construction of many intermediate series.+    processBatch (Just (p, 1)) xs acc+      = DS.filter (\a -> a `rem` unPrime p == 0)+      $ foldl' (DS.timesAndCrop n) acc'+      $ map (atomicSeries point f) xs2+      where+        (xs1, xs2) = partition (\(PrimePowers _ ts) -> length ts == 1) xs+        vs = DS.unions $ map (atomicSeries point f) xs1+        (ys, zs) = DS.partition (\a -> a `rem` unPrime p == 0) acc+        acc' = ys `DS.union` DS.timesAndCrop n zs vs++    processBatch (Just pk) xs acc+      = (\(p, k) -> DS.filter (\a -> a `rem` (unPrime p ^ k) == 0)) pk+      $ foldl' (DS.timesAndCrop n) acc+      $ map (atomicSeries point f) xs++{-# SPECIALISE invertFunction :: Semiring b => (Int -> b) -> ArithmeticFunction Int Int -> ([(Prime Int, Word)] -> [PrimePowers Int]) -> Int -> b #-}+{-# SPECIALISE invertFunction :: Semiring b => (Word -> b) -> ArithmeticFunction Word Word -> ([(Prime Word, Word)] -> [PrimePowers Word]) -> Word -> b #-}+{-# SPECIALISE invertFunction :: Semiring b => (Integer -> b) -> ArithmeticFunction Integer Integer -> ([(Prime Integer, Word)] -> [PrimePowers Integer]) -> Integer -> b #-}+{-# SPECIALISE invertFunction :: Semiring b => (Natural -> b) -> ArithmeticFunction Natural Natural -> ([(Prime Natural, Word)] -> [PrimePowers Natural]) -> Natural -> b #-}++-- | The inverse for 'totient' function.+--+-- The return value is parameterized by a 'Semiring', which allows+-- various applications by providing different (multiplicative) embeddings.+-- E. g., list all preimages (see a helper 'asSetOfPreimages'):+--+-- >>> import qualified Data.Set as S+-- >>> import Data.Semigroup+-- >>> S.mapMonotonic getProduct (inverseTotient (S.singleton . Product) 120)+-- fromList [143,155,175,183,225,231,244,248,286,308,310,350,366,372,396,450,462]+--+-- Count preimages:+--+-- >>> inverseTotient (const 1) 120+-- 17+--+-- Sum preimages:+--+-- >>> inverseTotient id 120+-- 4904+--+-- Find minimal and maximal preimages:+--+-- >>> unMinWord (inverseTotient MinWord 120)+-- 143+-- >>> unMaxWord (inverseTotient MaxWord 120)+-- 462+inverseTotient+  :: (Semiring b, Integral a, Euclidean a, UniqueFactorisation a)+  => (a -> b)+  -> a+  -> b+inverseTotient = inverseJordan 1+{-# SPECIALISE inverseTotient :: Semiring b => (Int -> b) -> Int -> b #-}+{-# SPECIALISE inverseTotient :: Semiring b => (Word -> b) -> Word -> b #-}+{-# SPECIALISE inverseTotient :: Semiring b => (Integer -> b) -> Integer -> b #-}+{-# SPECIALISE inverseTotient :: Semiring b => (Natural -> b) -> Natural -> b #-}++-- | The inverse for 'jordan' function.+--+-- Generalizes the 'inverseTotient' function, which is 'inverseJordan' 1.+--+-- The return value is parameterized by a 'Semiring', which allows+-- various applications by providing different (multiplicative) embeddings.+-- E. g., list all preimages (see a helper 'asSetOfPreimages'):+--+-- >>> import qualified Data.Set as S+-- >>> import Data.Semigroup+-- >>> S.mapMonotonic getProduct (inverseJordan 2 (S.singleton . Product) 192)+-- fromList [15,16]+--+-- Similarly to 'inverseTotient', it is possible to count and sum preimages, or+-- get the maximum/minimum preimage.+--+-- Note: it is the __user's responsibility__ to use an appropriate type for+-- 'inverseSigmaK'. Even low values of k with 'Int' or 'Word' will return+-- invalid results due to over/underflow, or throw exceptions (i.e. division by+-- zero).+--+-- >>> asSetOfPreimages (inverseJordan 15) (jordan 15 19) :: S.Set Int+-- fromList []+--+-- >>> asSetOfPreimages (inverseJordan 15) (jordan 15 19) :: S.Set Integer+-- fromList [19]+inverseJordan+  :: (Semiring b, Integral a, Euclidean a, UniqueFactorisation a)+  => Word+  -> (a -> b)+  -> a+  -> b+inverseJordan k point = invertFunction point (jordanA k) (invJordan k)+{-# SPECIALISE inverseJordan :: Semiring b => Word -> (Int -> b) -> Int -> b #-}+{-# SPECIALISE inverseJordan :: Semiring b => Word -> (Word -> b) -> Word -> b #-}+{-# SPECIALISE inverseJordan :: Semiring b => Word -> (Integer -> b) -> Integer -> b #-}+{-# SPECIALISE inverseJordan :: Semiring b => Word -> (Natural -> b) -> Natural -> b #-}++-- | The inverse for 'sigma' 1 function.+--+-- The return value is parameterized by a 'Semiring', which allows+-- various applications by providing different (multiplicative) embeddings.+-- E. g., list all preimages (see a helper 'asSetOfPreimages'):+--+-- >>> import qualified Data.Set as S+-- >>> import Data.Semigroup+-- >>> :set -XFlexibleContexts+-- >>> S.mapMonotonic getProduct (inverseSigma (S.singleton . Product) 120)+-- fromList [54,56,87,95]+--+-- Count preimages:+--+-- >>> inverseSigma (const 1) 120+-- 4+--+-- Sum preimages:+--+-- >>> inverseSigma id 120+-- 292+--+-- Find minimal and maximal preimages:+--+-- >>> unMinWord (inverseSigma MinWord 120)+-- 54+-- >>> unMaxWord (inverseSigma MaxWord 120)+-- 95+inverseSigma+  :: (Semiring b, Euclidean a, UniqueFactorisation a, Integral a, Enum (Prime a), Bits a)+  => (a -> b)+  -> a+  -> b+inverseSigma = inverseSigmaK 1+{-# SPECIALISE inverseSigma :: Semiring b => (Int -> b) -> Int -> b #-}+{-# SPECIALISE inverseSigma :: Semiring b => (Word -> b) -> Word -> b #-}+{-# SPECIALISE inverseSigma :: Semiring b => (Integer -> b) -> Integer -> b #-}+{-# SPECIALISE inverseSigma :: Semiring b => (Natural -> b) -> Natural -> b #-}++-- | The inverse for 'sigma' function.+--+-- Generalizes the 'inverseSigma' function, which is 'inverseSigmaK' 1.+--+-- The return value is parameterized by a 'Semiring', which allows+-- various applications by providing different (multiplicative) embeddings.+-- E. g., list all preimages (see a helper 'asSetOfPreimages'):+--+-- >>> import qualified Data.Set as S+-- >>> import Data.Semigroup+-- >>> :set -XFlexibleContexts+-- >>> S.mapMonotonic getProduct (inverseSigmaK 2 (S.singleton . Product) 850)+-- fromList [24,26]+--+-- Similarly to 'inverseSigma', it is possible to count and sum preimages, or+-- get the maximum/minimum preimage.+--+-- Note: it is the __user's responsibility__ to use an appropriate type for+-- 'inverseSigmaK'. Even low values of k with 'Int' or 'Word' will return+-- invalid results due to over/underflow, or throw exceptions (i.e. division by+-- zero).+--+-- >>> asSetOfPreimages (inverseSigmaK 17) (sigma 17 13) :: S.Set Int+-- fromList *** Exception: divide by zero+inverseSigmaK+  :: (Semiring b, Euclidean a, UniqueFactorisation a, Integral a, Enum (Prime a), Bits a)+  => Word+  -> (a -> b)+  -> a+  -> b+inverseSigmaK k point = invertFunction point (sigmaA k) (invSigma k)+{-# SPECIALISE inverseSigmaK :: Semiring b => Word -> (Int -> b) -> Int -> b #-}+{-# SPECIALISE inverseSigmaK :: Semiring b => Word -> (Word -> b) -> Word -> b #-}+{-# SPECIALISE inverseSigmaK :: Semiring b => Word -> (Integer -> b) -> Integer -> b #-}+{-# SPECIALISE inverseSigmaK :: Semiring b => Word -> (Natural -> b) -> Natural -> b #-}++--------------------------------------------------------------------------------+-- Wrappers++-- | Wrapper to use in conjunction with 'inverseTotient' and 'inverseSigma'.+-- Extracts the maximal preimage of function.+newtype MaxWord = MaxWord { unMaxWord :: Word }+  deriving (Eq, Ord, Show)++instance Semiring MaxWord where+  zero = MaxWord minBound+  one  = MaxWord 1+  plus  (MaxWord a) (MaxWord b) = MaxWord (a `max` b)+  times (MaxWord a) (MaxWord b) = MaxWord (a * b)++-- | Wrapper to use in conjunction with 'inverseTotient' and 'inverseSigma'.+-- Extracts the minimal preimage of function.+newtype MinWord = MinWord { unMinWord :: Word }+  deriving (Eq, Ord, Show)++instance Semiring MinWord where+  zero = MinWord maxBound+  one  = MinWord 1+  plus  (MinWord a) (MinWord b) = MinWord (a `min` b)+  times (MinWord a) (MinWord b) = MinWord (a * b)++-- | Wrapper to use in conjunction with 'inverseTotient' and 'inverseSigma'.+-- Extracts the maximal preimage of function.+newtype MaxNatural = MaxNatural { unMaxNatural :: Natural }+  deriving (Eq, Ord, Show)++instance Semiring MaxNatural where+  zero = MaxNatural 0+  one  = MaxNatural 1+  plus  (MaxNatural a) (MaxNatural b) = MaxNatural (a `max` b)+  times (MaxNatural a) (MaxNatural b) = MaxNatural (a * b)++-- | Wrapper to use in conjunction with 'inverseTotient' and 'inverseSigma'.+-- Extracts the minimal preimage of function.+data MinNatural+  = MinNatural { unMinNatural :: !Natural }+  | Infinity+  deriving (Eq, Ord, Show)++instance Semiring MinNatural where+  zero = Infinity+  one  = MinNatural 1++  plus a b = a `min` b++  times Infinity _ = Infinity+  times _ Infinity = Infinity+  times (MinNatural a) (MinNatural b) = MinNatural (a * b)++-- | Helper to extract a set of preimages for 'inverseTotient' or 'inverseSigma'.+asSetOfPreimages+  :: (Ord a, Semiring a)+  => (forall b. Semiring b => (a -> b) -> a -> b)+  -> a+  -> S.Set a+asSetOfPreimages f = S.mapMonotonic getMul . f (S.singleton . Mul)
+ Math/NumberTheory/ArithmeticFunctions/Mertens.hs view
@@ -0,0 +1,72 @@+-- |+-- Module:      Math.NumberTheory.ArithmeticFunctions.Mertens+-- Copyright:   (c) 2018 Andrew Lelechenko+-- Licence:     MIT+-- Maintainer:  Andrew Lelechenko <andrew.lelechenko@gmail.com>+--+-- Values of <https://en.wikipedia.org/wiki/Mertens_function Mertens function>.+--++{-# LANGUAGE LambdaCase #-}++module Math.NumberTheory.ArithmeticFunctions.Mertens+  ( mertens+  ) where++import qualified Data.Vector.Unboxed as U++import Math.NumberTheory.Roots+import Math.NumberTheory.ArithmeticFunctions.Moebius+import Math.NumberTheory.Utils.FromIntegral++-- | 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]+--+-- The implementation follows Theorem 3.1 from <https://arxiv.org/pdf/1610.08551.pdf Computations of the Mertens function and improved bounds on the Mertens conjecture> by G. Hurst, excluding segmentation of sieves.+mertens :: Word -> Int+mertens 0 = 0+mertens 1 = 1+mertens x = sumMultMoebius lookupMus (\n -> sfunc (x `quot` n)) [1 .. x `quot` u]+  where+    u = (integerSquareRoot x + 1) `max` (integerCubeRoot x ^ (2 :: Word) `quot` 2)++    sfunc :: Word -> Int+    sfunc y+      = 1+      - sum [ U.unsafeIndex mes (wordToInt $ y `quot` n) |  n <- [y `quot` u + 1 .. kappa] ]+      + wordToInt kappa * U.unsafeIndex mes (wordToInt nu)+      - sumMultMoebius lookupMus (\n -> wordToInt $ y `quot` n) [1 .. nu]+      where+        nu = integerSquareRoot y+        kappa = y `quot` (nu + 1)++    -- cacheSize ~ u+    cacheSize :: Word+    cacheSize = u `max` (x `quot` u) `max` integerSquareRoot x++    -- 1-based index+    mus :: U.Vector Moebius+    mus = sieveBlockMoebius 1 cacheSize++    lookupMus :: Word -> Moebius+    lookupMus i = U.unsafeIndex mus (wordToInt (i - 1))++    -- 0-based index+    mes :: U.Vector Int+    mes = U.scanl' go 0 mus+      where+        go acc = \case+          MoebiusN -> acc - 1+          MoebiusZ -> acc+          MoebiusP -> acc + 1++-- | Compute sum (map (\x -> runMoebius (mu x) * f x))+sumMultMoebius :: (Word -> Moebius) -> (Word -> Int) -> [Word] -> Int+sumMultMoebius mu f = foldl go 0+  where+    go acc i = case mu i of+      MoebiusN -> acc - f i+      MoebiusZ -> acc+      MoebiusP -> acc + f i
+ Math/NumberTheory/ArithmeticFunctions/Moebius.hs view
@@ -0,0 +1,169 @@+-- |+-- Module:      Math.NumberTheory.ArithmeticFunctions.Moebius+-- Copyright:   (c) 2018 Andrew Lelechenko+-- Licence:     MIT+-- Maintainer:  Andrew Lelechenko <andrew.lelechenko@gmail.com>+--+-- Values of <https://en.wikipedia.org/wiki/Möbius_function Möbius function>.+--++{-# LANGUAGE BangPatterns          #-}+{-# LANGUAGE MagicHash             #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies          #-}++module Math.NumberTheory.ArithmeticFunctions.Moebius+  ( Moebius(..)+  , runMoebius+  , sieveBlockMoebius+  ) where++import Control.Monad (forM_)+import Control.Monad.ST (runST)+import Data.Bits+import Data.Int+import Data.Word+import qualified Data.Vector.Generic         as G+import qualified Data.Vector.Generic.Mutable as M+import qualified Data.Vector.Primitive as P+import qualified Data.Vector.Unboxed         as U+import qualified Data.Vector.Unboxed.Mutable as MU+import GHC.Exts+import GHC.Num.Integer+import Unsafe.Coerce++import Math.NumberTheory.Roots (integerSquareRoot)+import Math.NumberTheory.Primes+import Math.NumberTheory.Utils.FromIntegral++import Math.NumberTheory.Logarithms++-- | Represents three possible values of <https://en.wikipedia.org/wiki/Möbius_function Möbius function>.+data Moebius+  = MoebiusN -- ^ \-1+  | MoebiusZ -- ^  0+  | MoebiusP -- ^  1+  deriving (Eq, Ord, Show)++-- | Convert to any numeric type.+runMoebius :: Num a => Moebius -> a+runMoebius m = fromInteger (IS (dataToTag# m -# 1#))++fromMoebius :: Moebius -> Int8+fromMoebius m = intToInt8 $ I# (dataToTag# m)+{-# INLINE fromMoebius #-}++toMoebius :: Int8 -> Moebius+toMoebius i = let !(I# i#) = int8ToInt i in tagToEnum# i#+{-# INLINE toMoebius #-}++newtype instance U.MVector s Moebius = MV_Moebius (P.MVector s Int8)+newtype instance U.Vector    Moebius = V_Moebius  (P.Vector    Int8)++instance U.Unbox Moebius++instance M.MVector U.MVector Moebius where+  {-# INLINE basicLength #-}+  {-# INLINE basicUnsafeSlice #-}+  {-# INLINE basicOverlaps #-}+  {-# INLINE basicUnsafeNew #-}+  {-# INLINE basicInitialize #-}+  {-# INLINE basicUnsafeReplicate #-}+  {-# INLINE basicUnsafeRead #-}+  {-# INLINE basicUnsafeWrite #-}+  {-# INLINE basicClear #-}+  {-# INLINE basicSet #-}+  {-# INLINE basicUnsafeCopy #-}+  {-# INLINE basicUnsafeGrow #-}+  basicLength (MV_Moebius v) = M.basicLength v+  basicUnsafeSlice i n (MV_Moebius v) = MV_Moebius $ M.basicUnsafeSlice i n v+  basicOverlaps (MV_Moebius v1) (MV_Moebius v2) = M.basicOverlaps v1 v2+  basicUnsafeNew n = MV_Moebius <$> M.basicUnsafeNew n+  basicInitialize (MV_Moebius v) = M.basicInitialize v+  basicUnsafeReplicate n x = MV_Moebius <$> M.basicUnsafeReplicate n (fromMoebius x)+  basicUnsafeRead (MV_Moebius v) i = toMoebius <$> M.basicUnsafeRead v i+  basicUnsafeWrite (MV_Moebius v) i x = M.basicUnsafeWrite v i (fromMoebius x)+  basicClear (MV_Moebius v) = M.basicClear v+  basicSet (MV_Moebius v) x = M.basicSet v (fromMoebius x)+  basicUnsafeCopy (MV_Moebius v1) (MV_Moebius v2) = M.basicUnsafeCopy v1 v2+  basicUnsafeMove (MV_Moebius v1) (MV_Moebius v2) = M.basicUnsafeMove v1 v2+  basicUnsafeGrow (MV_Moebius v) n = MV_Moebius <$> M.basicUnsafeGrow v n++instance G.Vector U.Vector Moebius where+  {-# INLINE basicUnsafeFreeze #-}+  {-# INLINE basicUnsafeThaw #-}+  {-# INLINE basicLength #-}+  {-# INLINE basicUnsafeSlice #-}+  {-# INLINE basicUnsafeIndexM #-}+  {-# INLINE elemseq #-}+  basicUnsafeFreeze (MV_Moebius v) = V_Moebius <$> G.basicUnsafeFreeze v+  basicUnsafeThaw (V_Moebius v) = MV_Moebius <$> G.basicUnsafeThaw v+  basicLength (V_Moebius v) = G.basicLength v+  basicUnsafeSlice i n (V_Moebius v) = V_Moebius $ G.basicUnsafeSlice i n v+  basicUnsafeIndexM (V_Moebius v) i = toMoebius <$> G.basicUnsafeIndexM v i+  basicUnsafeCopy (MV_Moebius mv) (V_Moebius v) = G.basicUnsafeCopy mv v+  elemseq _ = seq++instance Semigroup Moebius where+  MoebiusZ <> _ = MoebiusZ+  _ <> MoebiusZ = MoebiusZ+  MoebiusP <> a = a+  a <> MoebiusP = a+  _ <> _ = MoebiusP++instance Monoid Moebius where+  mempty  = MoebiusP++-- | Evaluate the Möbius function over a block.+-- Value of @f@ at 0, if zero falls into block, is undefined.+--+-- Based on the sieving algorithm from p. 3 of <https://arxiv.org/pdf/1610.08551.pdf Computations of the Mertens function and improved bounds on the Mertens conjecture> 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+  :: Word+  -> Word+  -> U.Vector Moebius+sieveBlockMoebius _ 0 = U.empty+sieveBlockMoebius lowIndex' len'+  = (unsafeCoerce :: U.Vector Word8 -> U.Vector Moebius) $ runST $ do+    as <- MU.replicate len (0x80 :: Word8)+    forM_ ps $ \p -> do+      let offset  = negate lowIndex `mod` p+          offset2 = negate lowIndex `mod` (p * p)+          l :: Word8+          l = intToWord8 $ intLog2 p .|. 1+      forM_ [offset, offset + p .. len - 1] $+        MU.unsafeModify as (+ l)+      forM_ [offset2, offset2 + p * p .. len - 1] $ \ix ->+        MU.unsafeWrite as ix 0+    forM_ [0 .. len - 1] $ \ix ->+      MU.unsafeModify as (mapper ix) ix+    U.unsafeFreeze as++  where+    lowIndex :: Int+    lowIndex = wordToInt lowIndex'++    len :: Int+    len = wordToInt len'++    highIndex :: Int+    highIndex = lowIndex + len - 1++    -- Bit fiddling in 'mapper' is correct only+    -- if all sufficiently small (<= 191) primes has been sieved out.+    ps :: [Int]+    ps = map unPrime [nextPrime 2 .. precPrime (191 `max` integerSquareRoot highIndex)]++    mapper :: Int -> Word8 -> Word8+    mapper ix val+      | val .&. 0x80 == 0x00+      = 1+      | word8ToInt (val .&. 0x7F) < intLog2 (ix + lowIndex) - 5+        - (if ix + lowIndex >= 0x100000   then 2 else 0)+        - (if ix + lowIndex >= 0x10000000 then 1 else 0)+      = (val .&. 1) `shiftL` 1+      | otherwise+      = ((val .&. 1) `xor` 1) `shiftL` 1
+ Math/NumberTheory/ArithmeticFunctions/NFreedom.hs view
@@ -0,0 +1,161 @@+-- |+-- Module:      Math.NumberTheory.ArithmeticFunctions.NFreedom+-- Copyright:   (c) 2018 Alexandre Rodrigues Baldé+-- Licence:     MIT+-- Maintainer:  Alexandre Rodrigues Baldé <alexandrer_b@outlook.com>+--+-- N-free number generation.+--++{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Math.NumberTheory.ArithmeticFunctions.NFreedom+  ( nFrees+  , nFreesBlock+  , sieveBlockNFree+  ) where++import Control.Monad                         (forM_)+import Control.Monad.ST                      (runST)+import Data.Bits (Bits)+import Data.List                             (scanl')+import qualified Data.Vector.Unboxed         as U+import qualified Data.Vector.Unboxed.Mutable as MU++import Math.NumberTheory.Roots+import Math.NumberTheory.Primes+import Math.NumberTheory.Utils.FromIntegral++-- | Evaluate the `Math.NumberTheory.ArithmeticFunctions.isNFree` function over a block.+-- Value at @0@, if zero falls into block, is undefined.+--+-- This function should __**not**__ be used with a negative lower bound.+-- If it is, the result is undefined.+-- Furthermore, do not:+--+-- * use a block length greater than @maxBound :: Int@.+-- * use a power that is either of @0, 1@.+--+-- None of these preconditions are checked, and if any occurs, the result is+-- undefined, __if__ the function terminates.+--+-- >>> sieveBlockNFree 2 1 10+-- [True,True,True,False,True,True,True,False,False,True]+sieveBlockNFree+  :: forall a. (Integral a, Enum (Prime a), Bits a, UniqueFactorisation a)+  => Word+  -- ^ Power whose @n@-freedom will be checked.+  -> a+  -- ^ Lower index of the block.+  -> Word+  -- ^ Length of the block.+  -> U.Vector Bool+  -- ^ Vector of flags, where @True@ at index @i@ means the @i@-th element of+  -- the block is @n@-free.+sieveBlockNFree _ _ 0 = U.empty+sieveBlockNFree n lowIndex len'+  = runST $ do+    as <- MU.replicate (wordToInt len') True+    forM_ ps $ \p -> do+      let pPow :: a+          pPow = p ^ n+          offset :: a+          offset = negate lowIndex `mod` pPow+          -- The second argument in @Data.Vector.Unboxed.Mutable.write@ is an+          -- @Int@, so to avoid segmentation faults or out-of-bounds errors,+          -- the enumeration's higher bound must always be less than+          -- @maxBound :: Int@.+          -- As mentioned above, this is not checked when using this function+          -- by itself, but is carefully managed when this function is called+          -- by @nFrees@, see the comments in it.+          indices :: [a]+          indices = [offset, offset + pPow .. len - 1]+      forM_ indices $ \ix ->+          MU.write as (fromIntegral ix) False+    U.freeze as++  where+    len :: a+    len = fromIntegral len'++    highIndex :: a+    highIndex = lowIndex + len - 1++    ps :: [a]+    ps = if highIndex < 4 then [] else map unPrime [nextPrime 2 .. precPrime (integerSquareRoot highIndex)]++-- | For a given nonnegative integer power @n@, generate all @n@-free+-- numbers in ascending order, starting at @1@.+--+-- When @n@ is @0@ or @1@, the resulting list is @[1]@.+nFrees+    :: forall a. (Integral a, Bits a, UniqueFactorisation a, Enum (Prime a))+    => Word+    -- ^ Power @n@ to be used to generate @n@-free numbers.+    -> [a]+    -- ^ Generated infinite list of @n@-free numbers.+nFrees 0 = [1]+nFrees 1 = [1]+nFrees n = concatMap (uncurry (nFreesBlock n)) $ zip bounds strides+  where+    -- The 56th element of @iterate (2 *) 256@ is @2^64 :: Word == 0@, so to+    -- avoid overflow only the first 55 elements of this list are used.+    -- After those, since @maxBound :: Int@ is the largest a vector can be,+    -- this value is just repeated. This means after a few dozen iterations,+    -- the sieve will stop increasing in size.+    strides :: [Word]+    strides = take 55 (iterate (2 *) 256) ++ repeat (intToWord (maxBound :: Int))++    -- Infinite list of lower bounds at which @sieveBlockNFree@ will be+    -- applied. This has type @Integral a => a@ instead of @Word@ because+    -- unlike the sizes of the sieve that eventually stop increasing (see+    -- above comment), the lower bound at which @sieveBlockNFree@ is called does not.+    bounds :: [a]+    bounds = scanl' (+) 1 $ map fromIntegral strides++-- | Generate @n@-free numbers in a block starting at a certain value.+-- The length of the list is determined by the value passed in as the third+-- argument. It will be lesser than or equal to this value.+--+-- This function should not be used with a negative lower bound. If it is,+-- the result is undefined.+--+-- The block length cannot exceed @maxBound :: Int@, this precondition is not+-- checked.+--+-- As with @nFrees@, passing @n = 0, 1@ results in an empty list.+nFreesBlock+    :: forall a . (Integral a, Bits a, UniqueFactorisation a, Enum (Prime a))+    => Word+    -- ^ Power @n@ to be used to generate @n@-free numbers.+    -> a+    -- ^ Starting number in the block.+    -> Word+    -- ^ Maximum length of the block to be generated.+    -> [a]+    -- ^ Generated list of @n@-free numbers.+nFreesBlock 0 lo _ = help lo+nFreesBlock 1 lo _ = help lo+nFreesBlock n lowIndex len =+    let -- When indexing the array of flags @bs@, the index has to be an+        -- @Int@. As such, it's necessary to cast @strd@ twice.+        -- * Once, immediately below, to create the range of values whose+        -- @n@-freedom will be tested. Since @nFrees@ has return type+        -- @[a]@, this cannot be avoided as @strides@ has type @[Word]@.+        len' :: Int+        len' = wordToInt len+        -- * Twice, immediately below, to create the range of indices with+        -- which to query @bs@.+        len'' :: a+        len'' = fromIntegral len+        bs  = sieveBlockNFree n lowIndex len+    in map snd .+       filter ((bs U.!) . fst) .+       zip [0 .. len' - 1] $ [lowIndex .. lowIndex + len'']+{-# INLINE nFreesBlock #-}++help :: Integral a => a -> [a]+help 1 = [1]+help _ = []+{-# INLINE help #-}
+ Math/NumberTheory/ArithmeticFunctions/SieveBlock.hs view
@@ -0,0 +1,214 @@+-- |+-- Module:      Math.NumberTheory.ArithmeticFunctions.SieveBlock+-- Copyright:   (c) 2017 Andrew Lelechenko+-- Licence:     MIT+-- Maintainer:  Andrew Lelechenko <andrew.lelechenko@gmail.com>+--+-- Bulk evaluation of arithmetic functions over continuous intervals+-- without factorisation.+--++{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE MagicHash           #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Math.NumberTheory.ArithmeticFunctions.SieveBlock+  ( runFunctionOverBlock+  , SieveBlockConfig(..)+  , multiplicativeSieveBlockConfig+  , additiveSieveBlockConfig+  , sieveBlock+  , sieveBlockUnboxed+  , sieveBlockMoebius+  ) where++import Control.Monad (forM_, when)+import Control.Monad.ST (runST)+import Data.Bits+import Data.Coerce+import qualified Data.Vector.Generic as G+import qualified Data.Vector.Generic.Mutable as MG+import qualified Data.Vector as V+import qualified Data.Vector.Unboxed as U+import qualified Data.Vector.Unboxed.Mutable as MU+import GHC.Exts++import Math.NumberTheory.ArithmeticFunctions.Class+import Math.NumberTheory.ArithmeticFunctions.Moebius (Moebius, sieveBlockMoebius)+import Math.NumberTheory.Logarithms (wordLog2, integerLogBase')+import Math.NumberTheory.Primes+import Math.NumberTheory.Primes.Types+import Math.NumberTheory.Roots (integerSquareRoot)+import Math.NumberTheory.Utils.FromIntegral (wordToInt, intToWord)++-- | A record, which specifies a function to evaluate over a block.+--+-- For example, here is a configuration for the totient function:+--+-- > SieveBlockConfig+-- >   { sbcEmpty                = 1+-- >   , sbcFunctionOnPrimePower = \p a -> (unPrime p - 1) * unPrime p ^ (a - 1)+-- >   , sbcAppend               = (*)+-- >   }+data SieveBlockConfig a = SieveBlockConfig+  { sbcEmpty                :: a+    -- ^ value of a function on 1+  , sbcFunctionOnPrimePower :: Prime Word -> Word -> a+    -- ^ how to evaluate a function on prime powers+  , sbcAppend               :: a -> a -> a+    -- ^ how to combine values of a function on coprime arguments+  }++-- | Create a config for a multiplicative function from its definition on prime powers.+multiplicativeSieveBlockConfig :: Num a => (Prime Word -> Word -> a) -> SieveBlockConfig a+multiplicativeSieveBlockConfig f = SieveBlockConfig+  { sbcEmpty                = 1+  , sbcFunctionOnPrimePower = f+  , sbcAppend               = (*)+  }++-- | Create a config for an additive function from its definition on prime powers.+additiveSieveBlockConfig :: Num a => (Prime Word -> Word -> a) -> SieveBlockConfig a+additiveSieveBlockConfig f = SieveBlockConfig+  { sbcEmpty                = 0+  , sbcFunctionOnPrimePower = f+  , sbcAppend               = (+)+  }++-- | 'runFunctionOverBlock' @f@ @x@ @l@ evaluates an arithmetic function+-- for integers between @x@ and @x+l-1@ and returns a vector of length @l@.+-- It completely avoids factorisation, so it is asymptotically faster than+-- pointwise evaluation of @f@.+--+-- Value of @f@ at 0, if zero falls into block, is undefined.+--+-- Beware that for underlying non-commutative monoids the results may potentially+-- differ from pointwise application via 'runFunction'.+--+-- This is a thin wrapper over 'sieveBlock', read more details there.+--+-- >>> import Math.NumberTheory.ArithmeticFunctions+-- >>> runFunctionOverBlock carmichaelA 1 10+-- [1,1,2,2,4,2,6,2,6,4]+runFunctionOverBlock+  :: ArithmeticFunction Word a+  -> Word+  -> Word+  -> V.Vector a+runFunctionOverBlock (ArithmeticFunction f g) = (G.map g .) . sieveBlock SieveBlockConfig+  { sbcEmpty                = mempty+  , sbcAppend               = (<>)+  , sbcFunctionOnPrimePower = coerce f+  }++-- | Evaluate a function over a block in accordance to provided configuration.+-- Value of @f@ at 0, if zero falls into block, is undefined.+--+-- Based on Algorithm M of <https://arxiv.org/pdf/1305.1639.pdf Parity of the number of primes in a given interval and algorithms of the sublinear summation> by A. V. Lelechenko. See Lemma 2 on p. 5 on its algorithmic complexity. For the majority of use-cases its time complexity is O(x^(1+ε)).+--+-- For example, following code lists smallest prime factors:+--+-- >>> sieveBlock (SieveBlockConfig maxBound (\p _ -> unPrime p) min) 2 10 :: Data.Vector.Vector Word+-- [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 -> [(unPrime p, k)]) (++)) 2 10 :: Data.Vector.Vector [(Word, Word)]+-- [[(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+  :: forall v a.+     G.Vector v a+  => SieveBlockConfig a+  -> Word+  -> Word+  -> v a+sieveBlock _ _ 0 = G.empty+sieveBlock (SieveBlockConfig empty f append) !lowIndex' len' = runST $ do++    let lowIndex :: Int+        lowIndex = wordToInt lowIndex'++        len :: Int+        len = wordToInt len'++        highIndex :: Int+        highIndex = lowIndex + len - 1++        highIndex' :: Word+        highIndex' = intToWord highIndex++        ps :: [Int]+        ps = if highIndex < 4 then [] else map unPrime [nextPrime 2 .. precPrime (integerSquareRoot highIndex)]++    as <- MU.replicate len 1+    bs <- MG.replicate len empty++    let doPrime 2 = do+          let fs = V.generate (wordLog2 highIndex')+                (\k -> f (Prime 2) (intToWord k + 1))+              npLow  = (lowIndex' + 1) `shiftR` 1+              npHigh = highIndex'      `shiftR` 1+          forM_ [npLow .. npHigh] $ \np@(W# np#) -> do+            let ix = wordToInt (np `shiftL` 1) - lowIndex :: Int+                -- Calling ctz# assumes that np /= 0, otherwise you get 64+                -- and can have an out-of-bounds read from 'fs'.+                tz = if np == 0 then 0 else I# (word2Int# (ctz# np#))+            MU.unsafeModify as (\x -> x `shiftL` (tz + 1)) ix+            MG.unsafeModify bs (\y -> y `append` V.unsafeIndex fs tz) ix++        doPrime p = do+          let p' = intToWord p+              f0 = f (Prime p') 1+              logp = integerLogBase' (toInteger p) (toInteger highIndex) - 1+              fs = V.generate logp (\k -> f (Prime p') (intToWord k + 2))+              npLow  = (lowIndex + p - 1) `quot` p+              npHigh = highIndex          `quot` p++          forM_ [npLow .. npHigh] $ \np -> do+            let !(I# ix#) = np * p - lowIndex+                (q, r) = np `quotRem` p+            if r /= 0+            then do+              MU.unsafeModify as (* p')        (I# ix#)+              MG.unsafeModify bs (`append` f0) (I# ix#)+            else do+              let pow = highestPowerDividing p q+              MU.unsafeModify as (\x -> x * p' ^ (pow + 2))                          (I# ix#)+              MG.unsafeModify bs (\y -> y `append` V.unsafeIndex fs (wordToInt pow)) (I# ix#)++    forM_ ps doPrime++    forM_ [0 .. len - 1] $ \k -> do+      a <- MU.unsafeRead as k+      let a' = intToWord (k + lowIndex)+      when (a /= a') $+        MG.unsafeModify bs (\b -> b `append` f (Prime $ a' `quot` a) 1) k++    G.unsafeFreeze bs++-- This is a variant of 'Math.NumberTheory.Utils.splitOff',+-- specialized for better performance.+highestPowerDividing :: Int -> Int -> Word+highestPowerDividing !_ 0 = 0+highestPowerDividing p n = go 0 n+  where+    go !k m = case m `quotRem` p of+      (q, 0) -> go (k + 1) q+      _      -> k++-- | This is 'sieveBlock' specialized to unboxed vectors.+--+-- >>> sieveBlockUnboxed (SieveBlockConfig 1 (\_ a -> a + 1) (*)) 1 10+-- [1,2,2,3,2,4,2,4,3,4]+sieveBlockUnboxed+  :: U.Unbox a+  => SieveBlockConfig a+  -> Word+  -> Word+  -> U.Vector a+sieveBlockUnboxed = sieveBlock++{-# SPECIALIZE sieveBlockUnboxed :: SieveBlockConfig Int  -> Word -> Word -> U.Vector Int  #-}+{-# SPECIALIZE sieveBlockUnboxed :: SieveBlockConfig Word -> Word -> Word -> U.Vector Word #-}+{-# SPECIALIZE sieveBlockUnboxed :: SieveBlockConfig Bool -> Word -> Word -> U.Vector Bool #-}+{-# SPECIALIZE sieveBlockUnboxed :: SieveBlockConfig Moebius -> Word -> Word -> U.Vector Moebius #-}
Math/NumberTheory/ArithmeticFunctions/Standard.hs view
@@ -3,30 +3,26 @@ -- Copyright:   (c) 2016 Andrew Lelechenko -- Licence:     MIT -- Maintainer:  Andrew Lelechenko <andrew.lelechenko@gmail.com>--- Stability:   Provisional--- Portability: Non-portable (GHC extensions) -- -- Textbook arithmetic functions. -- -{-# LANGUAGE CPP                 #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies        #-}-{-# LANGUAGE ViewPatterns        #-} -{-# OPTIONS_HADDOCK hide #-}- module Math.NumberTheory.ArithmeticFunctions.Standard-  ( -- * Multiplicative functions-    multiplicative-  , divisors, divisorsA+  ( -- * List divisors+    divisors, divisorsA   , divisorsList, divisorsListA   , divisorsSmall, divisorsSmallA-  , tau, tauA+  , divisorsTo, divisorsToA+    -- * Multiplicative functions+  , multiplicative+  , divisorCount, tau, tauA   , sigma, sigmaA   , totient, totientA   , jordan, jordanA-  , moebius, moebiusA+  , ramanujan, ramanujanA+  , moebius, moebiusA, Moebius(..), runMoebius   , liouville, liouvilleA     -- * Additive functions   , additive@@ -35,41 +31,39 @@     -- * Misc   , carmichael, carmichaelA   , expMangoldt, expMangoldtA+  , isNFree, isNFreeA, nFrees, nFreesBlock   ) where  import Data.Coerce+import Data.Euclidean (GcdDomain(divide)) import Data.IntSet (IntSet) import qualified Data.IntSet as IS+import Data.Maybe import Data.Set (Set) import qualified Data.Set as S import Data.Semigroup  import Math.NumberTheory.ArithmeticFunctions.Class-import Math.NumberTheory.UniqueFactorisation+import Math.NumberTheory.ArithmeticFunctions.Moebius+import Math.NumberTheory.ArithmeticFunctions.NFreedom (nFrees, nFreesBlock)+import Math.NumberTheory.Primes+import Math.NumberTheory.Utils.FromIntegral  import Numeric.Natural -#if MIN_VERSION_base(4,8,0)-#else-import Data.Foldable-import Data.Word-#endif--wordToInt :: Word -> Int-wordToInt = fromIntegral- -- | 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 -divisors :: (UniqueFactorisation n, Num n, Ord n) => n -> Set n+-- | See 'divisorsA'.+divisors :: (UniqueFactorisation n, Ord n) => n -> Set n divisors = runFunction divisorsA {-# SPECIALIZE divisors :: Natural -> Set Natural #-} {-# SPECIALIZE divisors :: Integer -> Set Integer #-}  -- | The set of all (positive) divisors of an argument.-divisorsA :: forall n. (UniqueFactorisation n, Num n, Ord n) => ArithmeticFunction n (Set n)-divisorsA = ArithmeticFunction (\((unPrime :: Prime n -> n) -> p) k -> SetProduct $ divisorsHelper p k) (S.insert 1 . getSetProduct)+divisorsA :: (Ord n, Num n) => ArithmeticFunction n (Set n)+divisorsA = ArithmeticFunction (\p -> SetProduct . divisorsHelper (unPrime p)) (S.insert 1 . getSetProduct)  divisorsHelper :: Num n => n -> Word -> Set n divisorsHelper _ 0 = S.empty@@ -77,12 +71,13 @@ divisorsHelper p a = S.fromDistinctAscList $ p : p * p : map (p ^) [3 .. wordToInt a] {-# INLINE divisorsHelper #-} -divisorsList :: (UniqueFactorisation n, Num n) => n -> [n]+-- | See 'divisorsListA'.+divisorsList :: UniqueFactorisation n => n -> [n] divisorsList = runFunction divisorsListA  -- | The unsorted list of all (positive) divisors of an argument, produced in lazy fashion.-divisorsListA :: forall n. (UniqueFactorisation n, Num n) => ArithmeticFunction n [n]-divisorsListA = ArithmeticFunction (\((unPrime :: Prime n -> n) -> p) k -> ListProduct $ divisorsListHelper p k) ((1 :) . getListProduct)+divisorsListA :: Num n => ArithmeticFunction n [n]+divisorsListA = ArithmeticFunction (\p -> ListProduct . divisorsListHelper (unPrime p)) ((1 :) . getListProduct)  divisorsListHelper :: Num n => n -> Word -> [n] divisorsListHelper _ 0 = []@@ -90,12 +85,13 @@ divisorsListHelper p a = p : p * p : map (p ^) [3 .. wordToInt a] {-# INLINE divisorsListHelper #-} -divisorsSmall :: (UniqueFactorisation n, Prime n ~ Prime Int) => n -> IntSet+-- | See 'divisorsSmallA'.+divisorsSmall :: Int -> IntSet divisorsSmall = runFunction divisorsSmallA  -- | Same as 'divisors', but with better performance on cost of type restriction.-divisorsSmallA :: forall n. (Prime n ~ Prime Int) => ArithmeticFunction n IntSet-divisorsSmallA = ArithmeticFunction (\p k -> IntSetProduct $ divisorsHelperSmall (unPrime p) k) (IS.insert 1 . getIntSetProduct)+divisorsSmallA :: ArithmeticFunction Int IntSet+divisorsSmallA = ArithmeticFunction (\p -> IntSetProduct . divisorsHelperSmall (unPrime p)) (IS.insert 1 . getIntSetProduct)  divisorsHelperSmall :: Int -> Word -> IntSet divisorsHelperSmall _ 0 = IS.empty@@ -103,6 +99,31 @@ divisorsHelperSmall p a = IS.fromDistinctAscList $ p : p * p : map (p ^) [3 .. wordToInt a] {-# INLINE divisorsHelperSmall #-} +-- | See 'divisorsToA'.+divisorsTo :: (UniqueFactorisation n, Integral n) => n -> n -> Set n+divisorsTo to = runFunction (divisorsToA to)++-- | The set of all (positive) divisors up to an inclusive bound.+divisorsToA :: (UniqueFactorisation n, Integral n) => n -> ArithmeticFunction n (Set n)+divisorsToA to = ArithmeticFunction f unwrap+  where f p k = BoundedSetProduct (\bound -> divisorsToHelper bound (unPrime p) k)+        unwrap (BoundedSetProduct res) = if 1 <= to then S.insert 1 (res to) else res to++-- | Generate at most @a@ powers of @p@ up to an inclusive bound @b@.+divisorsToHelper :: (Ord n, Num n) => n -> n -> Word -> Set n+divisorsToHelper _ _ 0 = S.empty+divisorsToHelper b p 1 = if p <= b then S.singleton p else S.empty+divisorsToHelper b p a = S.fromDistinctAscList $ take (wordToInt a) $ takeWhile (<=b) $ iterate (p*) p+{-# INLINE divisorsToHelper #-}++-- | Synonym for 'tau'.+--+-- >>> map divisorCount [1..10]+-- [1,2,2,3,2,4,2,4,3,4]+divisorCount :: (UniqueFactorisation n, Num a) => n -> a+divisorCount = tau++-- | See 'tauA'. tau :: (UniqueFactorisation n, Num a) => n -> a tau = runFunction tauA @@ -112,61 +133,92 @@ tauA :: Num a => ArithmeticFunction n a tauA = multiplicative $ const (fromIntegral . succ) -sigma :: (UniqueFactorisation n, Integral n) => Word -> n -> n+-- | See 'sigmaA'.+sigma :: (UniqueFactorisation n, Integral n, Num a, GcdDomain a) => Word -> n -> a sigma = runFunction . sigmaA+{-# INLINABLE sigma #-}  -- | The sum of the @k@-th powers of (positive) divisors of an argument. -- -- > sigmaA = multiplicative (\p k -> sum $ map (p ^) [0..k]) -- > sigmaA 0 = tauA-sigmaA :: forall n. (UniqueFactorisation n, Integral n) => Word -> ArithmeticFunction n n+sigmaA :: (Integral n, Num a, GcdDomain a) => Word -> ArithmeticFunction n a sigmaA 0 = tauA-sigmaA 1 = multiplicative $ \((unPrime :: Prime n -> n) -> p) -> sigmaHelper p-sigmaA a = multiplicative $ \((unPrime :: Prime n -> n) -> p) -> sigmaHelper (p ^ wordToInt a)+sigmaA 1 = multiplicative $ sigmaHelper . fromIntegral' . unPrime+sigmaA a = multiplicative $ sigmaHelper . (^ wordToInt a) . fromIntegral' . unPrime+{-# INLINABLE sigmaA #-} -sigmaHelper :: Integral n => n -> Word -> n+sigmaHelper :: (Num a, GcdDomain a) => a -> Word -> a sigmaHelper pa 1 = pa + 1 sigmaHelper pa 2 = pa * pa + pa + 1-sigmaHelper pa k = (pa ^ wordToInt (k + 1) - 1) `quot` (pa - 1)+sigmaHelper pa k = fromJust ((pa ^ wordToInt (k + 1) - 1) `divide` (pa - 1)) {-# INLINE sigmaHelper #-} -totient :: (UniqueFactorisation n, Integral n) => n -> n+-- | See 'totientA'.+totient :: UniqueFactorisation n => n -> n totient = runFunction totientA+{-# INLINABLE totient #-}  -- | Calculates the totient of a positive number @n@, i.e. --   the number of @k@ with @1 <= k <= n@ and @'gcd' n k == 1@, --   in other words, the order of the group of units in @&#8484;/(n)@.-totientA :: forall n. (UniqueFactorisation n, Integral n) => ArithmeticFunction n n-totientA = multiplicative $ \((unPrime :: Prime n -> n) -> p) -> jordanHelper p+totientA :: Num n => ArithmeticFunction n n+totientA = multiplicative $ jordanHelper . unPrime+{-# INLINABLE totientA #-} -jordan :: (UniqueFactorisation n, Integral n) => Word -> n -> n+-- | See 'jordanA'.+jordan :: UniqueFactorisation n => Word -> n -> n jordan = runFunction . jordanA  -- | Calculates the k-th Jordan function of an argument. -- -- > jordanA 1 = totientA-jordanA :: forall n. (UniqueFactorisation n, Integral n) => Word -> ArithmeticFunction n n+jordanA :: Num n => Word -> ArithmeticFunction n n jordanA 0 = multiplicative $ \_ _ -> 0 jordanA 1 = totientA-jordanA a = multiplicative $ \((unPrime :: Prime n -> n) -> p) -> jordanHelper (p ^ wordToInt a)+jordanA a = multiplicative $ jordanHelper . (^ wordToInt a) . unPrime -jordanHelper :: Integral n => n -> Word -> n+jordanHelper :: Num n => n -> Word -> n jordanHelper pa 1 = pa - 1 jordanHelper pa 2 = (pa - 1) * pa jordanHelper pa k = (pa - 1) * pa ^ wordToInt (k - 1) {-# INLINE jordanHelper #-} -moebius :: (UniqueFactorisation n, Num a) => n -> a+-- | See 'ramanujanA'.+ramanujan :: Integer -> Integer+ramanujan = runFunction ramanujanA++-- | Calculates the <https://en.wikipedia.org/wiki/Ramanujan_tau_function Ramanujan tau function>+--   of a positive number @n@, using formulas given <http://www.numbertheory.org/php/tau.html here>+ramanujanA :: ArithmeticFunction Integer Integer+ramanujanA = multiplicative $ ramanujanHelper . unPrime++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' = wordToInteger k+        tpPowers = reverse $ take (length binomials) $ iterate (* tp^(2::Int)) (if even k then 1 else tp)+{-# INLINE ramanujanHelper #-}++-- | See 'moebiusA'.+moebius :: UniqueFactorisation n => n -> Moebius moebius = runFunction moebiusA --- | Calculates the Moebius function of an argument.-moebiusA :: Num a => ArithmeticFunction n a-moebiusA = ArithmeticFunction (const f) runMoebius+-- | Calculates the Möbius function of an argument.+moebiusA :: ArithmeticFunction n Moebius+moebiusA = ArithmeticFunction (const f) id   where     f 1 = MoebiusN     f 0 = MoebiusP     f _ = MoebiusZ +-- | See 'liouvilleA'. liouville :: (UniqueFactorisation n, Num a) => n -> a liouville = runFunction liouvilleA @@ -174,16 +226,18 @@ liouvilleA :: Num a => ArithmeticFunction n a liouvilleA = ArithmeticFunction (const $ Xor . odd) runXor +-- | See 'carmichaelA'. carmichael :: (UniqueFactorisation n, Integral n) => n -> n carmichael = runFunction carmichaelA-{- The specializations reflects available specializations of lcm. -}-{-# SPECIALIZE carmichael :: Int -> Int #-}+{-# SPECIALIZE carmichael :: Int     -> Int #-}+{-# SPECIALIZE carmichael :: Word    -> Word #-} {-# SPECIALIZE carmichael :: Integer -> Integer #-}+{-# SPECIALIZE carmichael :: Natural -> Natural #-}  -- | Calculates the Carmichael function for a positive integer, that is, --   the (smallest) exponent of the group of units in @&#8484;/(n)@.-carmichaelA :: forall n. (UniqueFactorisation n, Integral n) => ArithmeticFunction n n-carmichaelA = ArithmeticFunction (\((unPrime :: Prime n -> n) -> p) k -> LCM $ f p k) getLCM+carmichaelA :: Integral n => ArithmeticFunction n n+carmichaelA = ArithmeticFunction (\p -> LCM . f (unPrime p)) getLCM   where     f 2 1 = 1     f 2 2 = 2@@ -196,6 +250,7 @@ additive :: Num a => (Prime n -> Word -> a) -> ArithmeticFunction n a additive f = ArithmeticFunction ((Sum .) . f) getSum +-- | See 'smallOmegaA'. smallOmega :: (UniqueFactorisation n, Num a) => n -> a smallOmega = runFunction smallOmegaA @@ -203,8 +258,9 @@ -- -- > smallOmegaA = additive (\_ _ -> 1) smallOmegaA :: Num a => ArithmeticFunction n a-smallOmegaA = additive (\_ _ -> 1)+smallOmegaA = additive $ const $ const 1 +-- | See 'bigOmegaA'. bigOmega :: UniqueFactorisation n => n -> Word bigOmega = runFunction bigOmegaA @@ -214,34 +270,13 @@ bigOmegaA :: ArithmeticFunction n Word bigOmegaA = additive $ const id -expMangoldt :: (UniqueFactorisation n, Num n) => n -> n+-- | See 'expMangoldtA'.+expMangoldt :: UniqueFactorisation n => n -> n expMangoldt = runFunction expMangoldtA  -- | The exponent of von Mangoldt function. Use @log expMangoldtA@ to recover von Mangoldt function itself.-expMangoldtA :: forall n. (UniqueFactorisation n, Num n) => ArithmeticFunction n n-expMangoldtA = ArithmeticFunction (\((unPrime :: Prime n -> n) -> p) _ -> MangoldtOne p) runMangoldt--data Moebius-  = MoebiusZ-  | MoebiusP-  | MoebiusN--runMoebius :: Num a => Moebius -> a-runMoebius m = case m of-  MoebiusZ ->  0-  MoebiusP ->  1-  MoebiusN -> -1--instance Semigroup Moebius where-  MoebiusZ <> _ = MoebiusZ-  _ <> MoebiusZ = MoebiusZ-  MoebiusP <> a = a-  a <> MoebiusP = a-  _ <> _ = MoebiusP--instance Monoid Moebius where-  mempty = MoebiusP-  mappend = (<>)+expMangoldtA :: Num n => ArithmeticFunction n n+expMangoldtA = ArithmeticFunction (const . MangoldtOne . unPrime) runMangoldt  data Mangoldt a   = MangoldtZero@@ -261,8 +296,17 @@  instance Monoid (Mangoldt a) where   mempty  = MangoldtZero-  mappend = (<>) +-- | See 'isNFreeA'.+isNFree :: UniqueFactorisation n => Word -> n -> Bool+isNFree n = runFunction (isNFreeA n)++-- | Check if an integer is @n@-free. An integer @x@ is @n@-free if in its+-- factorisation into prime factors, no factor has an exponent larger than or+-- equal to @n@.+isNFreeA :: Word -> ArithmeticFunction n Bool+isNFreeA n = ArithmeticFunction (\_ pow -> All $ pow < n) getAll+ newtype LCM a = LCM { getLCM :: a }  instance Integral a => Semigroup (LCM a) where@@ -270,7 +314,6 @@  instance Integral a => Monoid (LCM a) where   mempty  = LCM 1-  mappend = (<>)  newtype Xor = Xor { _getXor :: Bool } @@ -284,7 +327,6 @@  instance Monoid Xor where   mempty  = Xor False-  mappend = (<>)  newtype SetProduct a = SetProduct { getSetProduct :: Set a } @@ -293,7 +335,6 @@  instance (Num a, Ord a) => Monoid (SetProduct a) where   mempty  = SetProduct mempty-  mappend = (<>)  newtype ListProduct a = ListProduct { getListProduct :: [a] } @@ -302,8 +343,23 @@  instance Num a => Monoid (ListProduct a) where   mempty  = ListProduct mempty-  mappend = (<>) +-- Represent as a Reader monad+newtype BoundedSetProduct a = BoundedSetProduct { _getBoundedSetProduct :: a -> Set a }++takeWhileLE :: Ord a => a -> Set a -> Set a+takeWhileLE b xs = if m then S.insert b ls else ls+  where (ls, m, _) = S.splitMember b xs++instance (Ord a, Num a) => Semigroup (BoundedSetProduct a) where+  BoundedSetProduct f1 <> BoundedSetProduct f2 = BoundedSetProduct f+    where f b = s1 <> s2 <> foldMap (\n -> takeWhileLE b $ S.mapMonotonic (* n) s2) s1+            where s1 = f1 b+                  s2 = f2 b++instance (Ord a, Num a) => Monoid (BoundedSetProduct a) where+  mempty = BoundedSetProduct mempty+ newtype IntSetProduct = IntSetProduct { getIntSetProduct :: IntSet }  instance Semigroup IntSetProduct where@@ -311,4 +367,3 @@  instance Monoid IntSetProduct where   mempty  = IntSetProduct mempty-  mappend = (<>)
Math/NumberTheory/Curves/Montgomery.hs view
@@ -3,10 +3,9 @@ -- Copyright:   (c) 2017 Andrew Lelechenko -- Licence:     MIT -- Maintainer:  Andrew Lelechenko <andrew.lelechenko@gmail.com>--- Stability:   Provisional--- Portability: Non-portable (GHC extensions) ----- Arithmetic on Montgomery elliptic curve.+-- Arithmetic on Montgomery elliptic curves.+-- This is an internal module, exposed only for purposes of testing. --  {-# LANGUAGE BangPatterns        #-}@@ -17,6 +16,7 @@ {-# LANGUAGE ScopedTypeVariables #-}  {-# OPTIONS_GHC -fno-warn-type-defaults #-}+{-# OPTIONS_HADDOCK hide #-}  module Math.NumberTheory.Curves.Montgomery   ( Point@@ -33,10 +33,11 @@  import Data.Proxy import GHC.Exts-import GHC.Integer.GMP.Internals import GHC.Integer.Logarithms-import GHC.TypeNats.Compat+import GHC.TypeNats (KnownNat, SomeNat(..), Nat, natVal, someNatVal) +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 <http://www.ams.org/journals/mcom/1987-48-177/S0025-5718-1987-0866113-7/S0025-5718-1987-0866113-7.pdf Speeding the Pollard and Elliptic Curve Methods of Factorization> by P. L. Montgomery.@@ -55,9 +56,11 @@   , pointZ :: !Integer -- ^ Extract z-coordinate.   } +-- | Extract (a + 2) \/ 4, where a is a coefficient in curve's equation. pointA24 :: forall a24 n. KnownNat a24 => Point a24 n -> Integer pointA24 _ = toInteger $ natVal (Proxy :: Proxy a24) +-- | Extract modulo of the curve. pointN :: forall a24 n. KnownNat n => Point a24 n -> Integer pointN _ = toInteger $ natVal (Proxy :: Proxy n) @@ -67,7 +70,7 @@   Point _ 0 == Point _ 0 = True   Point _ 0 == _         = False   _         == Point _ 0 = False-  p@(Point x1 z1) == Point x2 z2 = let n = pointN p in x1 * z2 `mod` n == x2 * z1 `mod` n+  p@(Point x1 z1) == Point x2 z2 = let n = pointN p in (x1 * z2 - x2 * z1) `rem` n == 0  -- | For debugging. instance (KnownNat a24, KnownNat n) => Show (Point a24 n) where@@ -90,9 +93,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
+ Math/NumberTheory/Diophantine.hs view
@@ -0,0 +1,83 @@+-- Module for Diophantine Equations and related functions++module Math.NumberTheory.Diophantine+  ( cornacchiaPrimitive+  , cornacchia+  )+where++import Data.List.Infinite (Infinite(..))+import qualified Data.List.Infinite as Inf++import           Math.NumberTheory.Moduli.Sqrt  ( sqrtsModFactorisation )+import           Math.NumberTheory.Primes       ( factorise+                                                , unPrime+                                                , UniqueFactorisation+                                                )+import           Math.NumberTheory.Roots        ( integerSquareRoot )+import           Math.NumberTheory.Utils.FromIntegral++-- | See `cornacchiaPrimitive`, this is the internal algorithm implementation+-- as described at https://en.wikipedia.org/wiki/Cornacchia%27s_algorithm+cornacchiaPrimitive' :: Integer -> Integer -> [(Integer, Integer)]+cornacchiaPrimitive' d m = concatMap+  (findSolution . Inf.head . Inf.dropWhile (\r -> r * r >= m) . gcdSeq m)+  roots+ where+  roots :: [Integer]+  roots = filter (<= m `div` 2) $ sqrtsModFactorisation (m - d) (factorise m)++  gcdSeq :: Integer -> Integer -> Infinite Integer+  gcdSeq a b = a :< gcdSeq b (mod a b)++  -- If s = sqrt((m - r*r) / d) is an integer then (r, s) is a solution+  findSolution :: Integer -> [(Integer, Integer)]+  findSolution r = [ (r, s) | rem1 == 0 && s * s == s2 ]+   where+    (s2, rem1) = divMod (m - r * r) d+    s          = integerSquareRoot s2++-- | @cornacchiaPrimitive d m@ finds all primitive solutions \((x, y)\) (i.e. with \(\gcd(x, y) = 1\))+-- to the Diophantine equation+-- \[ x^2 + d \cdot y^2 = m \]+-- Preconditions: \(1 \le d < m\) and \(\gcd(d, m) = 1\).+--+-- Throws error if the preconditions are not met.+--+-- When \(m\) is square-free these are all the positive integer solutions;+-- use 'cornacchia' to find all solutions for arbitrary \(m\).+cornacchiaPrimitive :: Integer -> Integer -> [(Integer, Integer)]+cornacchiaPrimitive d m+  | not (1 <= d && d < m) = error "precondition failed: 1 <= d < m"+  | gcd d m /= 1          = error "precondition failed: d and m coprime"+  |+  -- If d=1 then the algorithm doesn't generate symmetrical pairs+    d == 1                = concatMap genPairs solutions+  | otherwise             = solutions+ where+  solutions = cornacchiaPrimitive' d m+  genPairs (x, y) = if x == y then [(x, y)] else [(x, y), (y, x)]++-- Find numbers whose square is a factor of the input+squareFactors :: UniqueFactorisation a => a -> [a]+squareFactors = foldl squareProducts [1] . factorise+ where+  squareProducts acc f = [ a * b | a <- acc, b <- squarePowers f ]+  squarePowers (p, a) = map (unPrime p ^) [0 .. wordToInt a `div` 2]++-- | @cornacchia d m@ finds all positive integer solutions \((x, y)\) to the Diophantine equation+-- \[ x^2 + d \cdot y^2 = m \]+-- Preconditions: \(1 \le d < m\) and \(\gcd(d, m) = 1\).+--+-- Throws error if the preconditions are not met.+--+-- Unlike 'cornacchiaPrimitive', this also finds non-primitive solutions (where \(\gcd(x, y) > 1\))+-- by solving the equation for each square divisor of \(m\) and scaling the results.+cornacchia :: Integer -> Integer -> [(Integer, Integer)]+cornacchia d m+  | not (1 <= d && d < m) = error "precondition failed: 1 <= d < m"+  | gcd d m /= 1 = error "precondition failed: d and m coprime"+  | otherwise = concatMap solve $ filter ((> d) . snd) candidates+ where+  candidates = map (\sf -> (sf, m `div` (sf * sf))) (squareFactors m)+  solve (sf, m') = map (\(x, y) -> (x * sf, y * sf)) (cornacchiaPrimitive d m')
+ Math/NumberTheory/DirichletCharacters.hs view
@@ -0,0 +1,560 @@+-- |+-- Module:      Math.NumberTheory.DirichletCharacters+-- Copyright:   (c) 2018 Bhavik Mehta+-- Licence:     MIT+-- Maintainer:  Bhavik Mehta <bhavikmehta8@gmail.com>+--+-- Implementation and enumeration of Dirichlet characters.+--++{-# LANGUAGE DataKinds                  #-}+{-# LANGUAGE GADTs                      #-}+{-# LANGUAGE KindSignatures             #-}+{-# LANGUAGE LambdaCase                 #-}+{-# LANGUAGE PatternSynonyms            #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE ViewPatterns               #-}++{-# OPTIONS_GHC -Wno-unrecognised-warning-flags -Wno-pattern-namespace-specifier #-}++module Math.NumberTheory.DirichletCharacters+  (+  -- * An absorbing semigroup+  OrZero, pattern Zero, pattern NonZero+  , orZeroToNum+  -- * Dirichlet characters+  , DirichletCharacter+  -- ** Construction+  , indexToChar+  , indicesToChars+  , characterNumber+  , allChars+  , fromTable+  -- ** Evaluation+  , eval+  , evalGeneral+  , evalAll+  -- ** Special Dirichlet characters+  , principalChar+  , isPrincipal+  , orderChar+  -- ** Real Dirichlet characters+  , RealCharacter+  , isRealCharacter+  , getRealChar+  , toRealFunction+  , jacobiCharacter+  -- ** Primitive characters+  , PrimitiveCharacter+  , isPrimitive+  , getPrimitiveChar+  , induced+  , makePrimitive+  , WithNat(..)+  -- * Roots of unity+  , RootOfUnity(..)+  , toRootOfUnity+  , toComplex+  -- * Debugging+  , validChar+  ) where++import Data.Bits                                           (Bits(..))+import Data.Constraint+import Data.Foldable+import Data.Functor.Identity                               (Identity(..))+import Data.Kind+import Data.List                                           (sort, unfoldr)+import Data.Maybe                                          (mapMaybe, fromJust, fromMaybe)+import Data.Mod+import Data.Monoid                                         (Ap(..))+import Data.Proxy                                          (Proxy(..))+import Data.Ratio                                          ((%), numerator, denominator)+import Data.Semigroup                                      (Semigroup(..),Product(..))+import Data.Traversable+import qualified Data.Vector as V+import qualified Data.Vector.Mutable as MV+import Data.Vector                                         (Vector, (!))+import GHC.TypeNats                                        (KnownNat, Nat, SomeNat(..), natVal, someNatVal)+import Numeric.Natural                                     (Natural)++import Math.NumberTheory.ArithmeticFunctions               (totient)+import Math.NumberTheory.Moduli.Chinese+import Math.NumberTheory.Moduli.Internal                   (discreteLogarithmPP)+import Math.NumberTheory.Moduli.Multiplicative+import Math.NumberTheory.Moduli.Singleton+import Math.NumberTheory.Primes+import Math.NumberTheory.RootsOfUnity+import Math.NumberTheory.Utils+import Math.NumberTheory.Utils.FromIntegral++-- | A Dirichlet character mod \(n\) is a group homomorphism from \((\mathbb{Z}/n\mathbb{Z})^*\)+-- to \(\mathbb{C}^*\), represented abstractly by `DirichletCharacter`. In particular, they take+-- values at roots of unity and can be evaluated using `eval`.+-- A Dirichlet character can be extended to a completely multiplicative function on \(\mathbb{Z}\)+-- by assigning the value 0 for \(a\) sharing a common factor with \(n\), using `evalGeneral`.+--+-- There are finitely many possible Dirichlet characters for a given modulus, in particular there+-- are \(\phi(n)\) characters modulo \(n\), where \(\phi\) refers to Euler's `totient` function.+-- This gives rise to `Enum` and `Bounded` instances.+newtype DirichletCharacter (n :: Nat) = Generated [DirichletFactor]++-- | The group (Z/nZ)^* decomposes to a product (Z/2^k0 Z)^* x (Z/p1^k1 Z)^* x ... x (Z/pi^ki Z)^*+-- where n = 2^k0 p1^k1 ... pi^ki, and the pj are odd primes, k0 possibly 0. Thus, a group+-- homomorphism from (Z/nZ)^* is characterised by group homomorphisms from each of these factor+-- groups. Furthermore, for odd p, we have (Z/p^k Z)^* isomorphic to Z / p^(k-1)*(p-1) Z, an+-- additive group, where an isomorphism is specified by a choice of primitive root.+-- Similarly, for k >= 2, (Z/2^k Z)^* is isomorphic to Z/2Z * (Z / 2^(k-2) Z) (and for k < 2+-- it is trivial).  (See @lambda@ for this isomorphism).+-- Thus, to specify a Dirichlet character, it suffices to specify the value of generators+-- of each of these cyclic groups, when primitive roots are given. This data is given by a+-- DirichletFactor.+-- We have the invariant that the factors must be given in strictly increasing order, and the+-- generator is as given by @generator@, and are each non-trivial. These conditions are verified+-- using `validChar`.+data DirichletFactor = OddPrime { _getPrime :: Prime Natural+                                , _getPower :: Word+                                , _getGenerator :: Natural+                                , _getValue :: RootOfUnity+                                }+                     | TwoPower { _getPower2 :: Int -- this ought to be Word, but many applications+                                                    -- needed to use wordToInt, so Int is cleaner+                                                    -- Required to be >= 2+                                , _getFirstValue :: RootOfUnity+                                , _getSecondValue :: RootOfUnity+                                }+                     | Two++instance Eq (DirichletCharacter n) where+  Generated a == Generated b = a == b++instance Eq DirichletFactor where+  TwoPower _ x1 x2 == TwoPower _ y1 y2 = x1 == y1 && x2 == y2+  OddPrime _ _ _ x == OddPrime _ _ _ y = x == y+  Two              == Two              = True+  _ == _ = False++-- | For primes, define the canonical primitive root as the smallest such.+generator :: Prime Natural -> Word -> Natural+generator p k = case cyclicGroupFromFactors [(p, k)] of+  Nothing -> error "illegal"+  Just (Some cg) -> case proofFromCyclicGroup cg of+    Sub Dict -> case mapMaybe (isPrimitiveRoot cg) [2..maxBound] of+      [] -> error "illegal"+      hd : _ -> unMod $ multElement $ unPrimitiveRoot hd++-- | Implement the function \(\lambda\) from page 5 of+-- https://www2.eecs.berkeley.edu/Pubs/TechRpts/1984/CSD-84-186.pdf+lambda :: Integer -> Int -> Integer+lambda x e = ((xPower - 1) `shiftR` (e+1)) .&. (modulus - 1)+  where+    modulus  = 1 `shiftL` (e - 2)+    largeMod = 1 `shiftL` (2 * e - 1)+    xPower = case someNatVal largeMod of+      SomeNat (_ :: Proxy largeMod) ->+        toInteger (unMod (fromInteger x ^ (2 * modulus) :: Mod largeMod))+++-- | For elements of the multiplicative group \((\mathbb{Z}/n\mathbb{Z})^*\), a Dirichlet+-- character evaluates to a root of unity.+eval :: DirichletCharacter n -> MultMod n -> RootOfUnity+eval (Generated ds) m = foldMap (evalFactor m') ds+  where+    m' = toInteger $ unMod $ multElement m++-- | Evaluate each factor of the Dirichlet character.+evalFactor :: Integer -> DirichletFactor -> RootOfUnity+evalFactor m =+  \case+    OddPrime (toInteger . unPrime -> p) k (toInteger -> a) b ->+      discreteLogarithmPP p k a (m `rem` p^k) `stimes` b+    TwoPower k s b -> (if testBit m 1 then s else mempty)+                   <> lambda (thingy k m) k `stimes` b+    Two -> mempty++thingy :: (Bits p, Num p) => Int -> p -> p+thingy k m = if testBit m 1+                then bit k - m'+                else m'+  where m' = m .&. (bit k - 1)++-- | A character can evaluate to a root of unity or zero: represented by @Nothing@.+evalGeneral :: KnownNat n => DirichletCharacter n -> Mod n -> OrZero RootOfUnity+evalGeneral chi t = case isMultElement t of+                      Nothing -> Zero+                      Just x -> NonZero $ eval chi x++-- | Give the principal character for this modulus: a principal character mod \(n\) is 1 for+-- \(a\) coprime to \(n\), and 0 otherwise.+principalChar :: KnownNat n => DirichletCharacter n+principalChar = minBound++mulChars :: DirichletCharacter n -> DirichletCharacter n -> DirichletCharacter n+mulChars (Generated x) (Generated y) = Generated (zipWith combine x y)+  where combine :: DirichletFactor -> DirichletFactor -> DirichletFactor+        combine Two Two = Two+        combine (OddPrime p k g n) (OddPrime _ _ _ m) =+          OddPrime p k g (n <> m)+        combine (TwoPower k a n) (TwoPower _ b m) =+          TwoPower k (a <> b) (n <> m)+        combine _ _ = error "internal error: malformed DirichletCharacter"++-- | This Semigroup is in fact a group, so @stimes@ can be called with a negative first argument.+instance Semigroup (DirichletCharacter n) where+  (<>) = mulChars+  stimes = stimesChar++instance KnownNat n => Monoid (DirichletCharacter n) where+  mempty = principalChar++stimesChar :: Integral a => a -> DirichletCharacter n -> DirichletCharacter n+stimesChar s (Generated xs) = Generated (map mult xs)+  where mult :: DirichletFactor -> DirichletFactor+        mult (OddPrime p k g n) = OddPrime p k g (s `stimes` n)+        mult (TwoPower k a b) = TwoPower k (s `stimes` a) (s `stimes` b)+        mult Two = Two++-- | We define `succ` and `pred` with more efficient implementations than+-- @`toEnum` . (+1) . `fromEnum`@.+instance KnownNat n => Enum (DirichletCharacter n) where+  toEnum = indexToChar . intToNatural+  fromEnum = integerToInt . characterNumber+  succ x = makeChar x (characterNumber x + 1)+  pred x = makeChar x (characterNumber x - 1)++  enumFromTo x y       = bulkMakeChars x [fromEnum x..fromEnum y]+  enumFrom x           = bulkMakeChars x [fromEnum x..]+  enumFromThenTo x y z = bulkMakeChars x [fromEnum x, fromEnum y..fromEnum z]+  enumFromThen x y     = bulkMakeChars x [fromEnum x, fromEnum y..]++instance KnownNat n => Bounded (DirichletCharacter n) where+  minBound = indexToChar 0+  maxBound = indexToChar (totient n - 1)+    where n = natVal (Proxy :: Proxy n)++-- | We have a (non-canonical) enumeration of dirichlet characters.+characterNumber :: DirichletCharacter n -> Integer+characterNumber (Generated y) = foldl' go 0 y+  where go x (OddPrime p k _ a) = x * m + numerator (fromRootOfUnity a * (m % 1))+          where p' = naturalToInteger (unPrime p)+                m = p'^(k-1)*(p'-1)+        go x (TwoPower k a b)   = x' * 2 + numerator (fromRootOfUnity a * 2)+          where m = bit (k-2) :: Integer+                x' = x `shiftL` (k-2) + numerator (fromRootOfUnity b * (m % 1))+        go x Two = x++-- | Give the dirichlet character from its number.+-- Inverse of `characterNumber`.+indexToChar :: forall n. KnownNat n => Natural -> DirichletCharacter n+indexToChar = runIdentity . indicesToChars . Identity++-- | Give a collection of dirichlet characters from their numbers. This may be more efficient than+-- `indexToChar` for multiple characters, as it prevents some internal recalculations.+indicesToChars :: forall n f. (KnownNat n, Functor f) => f Natural -> f (DirichletCharacter n)+indicesToChars = fmap (Generated . unroll t . (`mod` m))+  where n = natVal (Proxy :: Proxy n)+        (Product m, t) = mkTemplate n++-- | List all characters for the modulus. This is preferred to using @[minBound..maxBound]@.+allChars :: forall n. KnownNat n => [DirichletCharacter n]+allChars = indicesToChars [0..m-1]+  where m = totient $ natVal (Proxy :: Proxy n)++-- | The same as `indexToChar`, but if we're given a character we can create others more efficiently.+makeChar :: Integral a => DirichletCharacter n -> a -> DirichletCharacter n+makeChar x = runIdentity . bulkMakeChars x . Identity++-- | Use one character to make many more: better than indicesToChars since it avoids recalculating+-- some primitive roots+bulkMakeChars :: (Integral a, Functor f) => DirichletCharacter n -> f a -> f (DirichletCharacter n)+bulkMakeChars x = fmap (Generated . unroll t . (`mod` m) . fromIntegral')+  where (Product m, t) = templateFromCharacter x++-- We assign each natural a unique Template, which can be decorated (eg in `unroll`) to+-- form a DirichletCharacter. A Template effectively holds the information carried around+-- in a DirichletFactor which depends only on the modulus of the character.+data Template = OddTemplate { _getPrime'     :: Prime Natural+                            , _getPower'     :: Word+                            , _getGenerator' :: !Natural+                            , _getModulus'   :: !Natural+                            }+              | TwoPTemplate { _getPower2'    :: Int+                             , _getModulus'   :: !Natural+                             } -- the modulus is derivable from the other values, but calculation+                               -- may be expensive, so we pre-calculate it+                               -- morally getModulus should be a prefactored but seems to be+                               -- pointless here+              | TwoTemplate++templateFromCharacter :: DirichletCharacter n -> (Product Natural, [Template])+templateFromCharacter (Generated t) = traverse go t+  where go (OddPrime p k g _) = (Product m, OddTemplate p k g m)+          where p' = unPrime p+                m = p'^(k-1)*(p'-1)+        go (TwoPower k _ _) = (Product (2*m), TwoPTemplate k m)+          where m = bit (k-2)+        go Two = (Product 1, TwoTemplate)++mkTemplate :: Natural -> (Product Natural, [Template])+mkTemplate = go . sort . factorise+  where go :: [(Prime Natural, Word)] -> (Product Natural, [Template])+        go ((unPrime -> 2, 1): xs) = (Product 1, [TwoTemplate]) <> traverse odds xs+        go ((unPrime -> 2, wordToInt -> k): xs) = (Product (2*m), [TwoPTemplate k m]) <> traverse odds xs+          where m = bit (k-2)+        go xs = traverse odds xs+        odds :: (Prime Natural, Word) -> (Product Natural, Template)+        odds (p, k) = (Product m, OddTemplate p k (generator p k) m)+          where p' = unPrime p+                m = p'^(k-1)*(p'-1)++-- the validity of the produced dirichletfactor list here requires the template to be valid+unroll :: [Template] -> Natural -> [DirichletFactor]+unroll t m = snd (mapAccumL func m t)+  where func :: Natural -> Template -> (Natural, DirichletFactor)+        func a (OddTemplate p k g n) = (a1, OddPrime p k g (toRootOfUnity $ toInteger a2 % toInteger n))+          where (a1,a2) = quotRem a n+        func a (TwoPTemplate k n) = (b1, TwoPower k (toRootOfUnity $ toInteger a2 % 2) (toRootOfUnity $ toInteger b2 % toInteger n))+          where (a1,a2) = quotRem a 2+                (b1,b2) = quotRem a1 n+        func a TwoTemplate = (a, Two)++-- | Test if a given Dirichlet character is prinicpal for its modulus: a principal character mod+-- \(n\) is 1 for \(a\) coprime to \(n\), and 0 otherwise.+isPrincipal :: DirichletCharacter n -> Bool+isPrincipal chi = characterNumber chi == 0++-- | Induce a Dirichlet character to a higher modulus. If \(d \mid n\), then \(a \bmod{n}\) can be+-- reduced to \(a \bmod{d}\). Thus, the multiplicative function on \(\mathbb{Z}/d\mathbb{Z}\)+-- induces a multiplicative function on \(\mathbb{Z}/n\mathbb{Z}\).+--+-- >>> :set -XTypeApplications -XDataKinds+-- >>> chi = indexToChar 5 :: DirichletCharacter 45+-- >>> chi2 = induced @135 chi :: Maybe (DirichletCharacter 135)+induced :: forall n d. (KnownNat d, KnownNat n) => DirichletCharacter d -> Maybe (DirichletCharacter n)+induced (Generated start) = if n `rem` d == 0+                            then Just (Generated (combine (snd $ mkTemplate n) start))+                            else Nothing+  where n = natVal (Proxy :: Proxy n)+        d = natVal (Proxy :: Proxy d)+        combine :: [Template] -> [DirichletFactor] -> [DirichletFactor]+        combine [] _ = []+        combine ts [] = map newFactor ts+        combine (t:xs) (y:ys) = case (t,y) of+                                  (TwoTemplate, Two) -> Two: combine xs ys+                                  (TwoTemplate, _) -> Two: combine xs (y:ys)+                                  (TwoPTemplate k _, Two) -> TwoPower k mempty mempty: combine xs ys+                                  (TwoPTemplate k _, TwoPower _ a b) -> TwoPower k a b: combine xs ys+                                  (TwoPTemplate k _, _) -> TwoPower k mempty mempty: combine xs (y:ys)+                                  (OddTemplate p k _ _, OddPrime q _ g a) | p == q -> OddPrime p k g a: combine xs ys+                                  (OddTemplate p k g _, OddPrime q _ _ _) | p < q -> OddPrime p k g mempty: combine xs (y:ys)+                                  _ -> error "internal error in induced: please report this as a bug"+        newFactor :: Template -> DirichletFactor+        newFactor TwoTemplate = Two+        newFactor (TwoPTemplate k _) = TwoPower k mempty mempty+        newFactor (OddTemplate p k g _) = OddPrime p k g mempty++-- | The <https://en.wikipedia.org/wiki/Jacobi_symbol Jacobi symbol> gives a real Dirichlet+-- character for odd moduli.+jacobiCharacter :: forall n. KnownNat n => Maybe (RealCharacter n)+jacobiCharacter = if odd n+                     then Just $ RealChar $ Generated $ map go $ snd $ mkTemplate n+                     else Nothing+  where n = natVal (Proxy :: Proxy n)+        go :: Template -> DirichletFactor+        go (OddTemplate p k g _) = OddPrime p k g $ toRootOfUnity (toInteger k % 2)+          -- jacobi symbol of a primitive root mod p over p is always -1+        go _ = error "internal error in jacobiCharacter: please report this as a bug"+          -- every factor of n should be odd++-- | A Dirichlet character is real if it is real-valued.+newtype RealCharacter n = RealChar { -- | Extract the character itself from a `RealCharacter`.+                                     getRealChar :: DirichletCharacter n+                                   }+                                   deriving Eq++-- | Test if a given `DirichletCharacter` is real, and if so give a `RealCharacter`.+isRealCharacter :: DirichletCharacter n -> Maybe (RealCharacter n)+isRealCharacter t@(Generated xs) = if all real xs then Just (RealChar t) else Nothing+  where real :: DirichletFactor -> Bool+        real (OddPrime _ _ _ a) = a <> a == mempty+        real (TwoPower _ _ b) = b <> b == mempty+        real Two = True++-- TODO: it should be possible to calculate this without eval/evalGeneral+-- and thus avoid using discrete log calculations: consider the order of m+-- inside each of the factor groups?+-- | Evaluate a real Dirichlet character, which can only take values \(-1,0,1\).+toRealFunction :: KnownNat n => RealCharacter n -> Mod n -> Int+toRealFunction (RealChar chi) m = case evalGeneral chi m of+                                    Zero -> 0+                                    NonZero t | t == mempty -> 1+                                    NonZero t | t == RootOfUnity (1 % 2) -> -1+                                    _ -> error "internal error in toRealFunction: please report this as a bug"+                                      -- A real character should not be able to evaluate to+                                      -- anything other than {-1,0,1}, so should not reach this branch++-- | Test if the internal DirichletCharacter structure is valid.+validChar :: forall n. KnownNat n => DirichletCharacter n -> Bool+validChar (Generated xs) = correctDecomposition && all correctPrimitiveRoot xs && all validValued xs+  where correctDecomposition = sort (factorise n) == map getPP xs+        getPP (TwoPower k _ _) = (two, intToWord k)+        getPP (OddPrime p k _ _) = (p, k)+        getPP Two = (two,1)+        correctPrimitiveRoot (OddPrime p k g _) = g == generator p k+        correctPrimitiveRoot _ = True+        validValued (TwoPower k a b) = a <> a == mempty && (bit (k-2) :: Integer) `stimes` b == mempty+        validValued (OddPrime (unPrime -> p) k _ a) = (p^(k-1)*(p-1)) `stimes` a == mempty+        validValued Two = True+        n = natVal (Proxy :: Proxy n)+        two = nextPrime 2++-- | Get the order of the Dirichlet Character.+orderChar :: DirichletCharacter n -> Integer+orderChar (Generated xs) = foldl' lcm 1 $ map orderFactor xs+  where orderFactor (TwoPower _ (RootOfUnity a) (RootOfUnity b)) = denominator a `lcm` denominator b+        orderFactor (OddPrime _ _ _ (RootOfUnity a)) = denominator a+        orderFactor Two = 1++-- | Test if a Dirichlet character is <https://en.wikipedia.org/wiki/Dirichlet_character#Primitive_characters_and_conductor primitive>.+isPrimitive :: DirichletCharacter n -> Maybe (PrimitiveCharacter n)+isPrimitive t@(Generated xs) = if all primitive xs then Just (PrimitiveCharacter t) else Nothing+  where primitive :: DirichletFactor -> Bool+        primitive Two = False+        -- for odd p, we're testing if phi(p^(k-1)) `stimes` a is 1, since this means the+        -- character can come from some the smaller modulus p^(k-1)+        primitive (OddPrime _ 1 _ a) = a /= mempty+        primitive (OddPrime (unPrime -> p) k _ a) = (p^(k-2)*(p-1)) `stimes` a /= mempty+        primitive (TwoPower 2 a _) = a /= mempty+        primitive (TwoPower k _ b) = (bit (k-3) :: Integer) `stimes` b /= mempty++-- | A Dirichlet character is primitive if cannot be 'induced' from any character with+-- strictly smaller modulus.+newtype PrimitiveCharacter n = PrimitiveCharacter { -- | Extract the character itself from a `PrimitiveCharacter`.+                                                    getPrimitiveChar :: DirichletCharacter n+                                                    }+                                                    deriving Eq++-- | Wrapper to hide an unknown type-level natural.+data WithNat (a :: Nat -> Type) where+  WithNat :: KnownNat m => a m -> WithNat a++-- | This function also provides access to the new modulus on type level, with a KnownNat instance+makePrimitive :: DirichletCharacter n -> WithNat PrimitiveCharacter+makePrimitive (Generated xs) =+  case someNatVal (product mods) of+    SomeNat (Proxy :: Proxy m) -> WithNat (PrimitiveCharacter (Generated ys) :: PrimitiveCharacter m)+  where (mods,ys) = unzip (mapMaybe prim xs)+        prim :: DirichletFactor -> Maybe (Natural, DirichletFactor)+        prim Two = Nothing+        prim (OddPrime p' k g a) = case find works options of+                                     Nothing -> error "invalid character"+                                     Just (0,_) -> Nothing+                                     Just (i,_) -> Just (p^i, OddPrime p' i g a)+          where options = (0,1): [(i,p^(i-1)*(p-1)) | i <- [1..k]]+                works (_,phi) = phi `stimes` a == mempty+                p = unPrime p'+        prim (TwoPower k a b) = case find worksb options of+                                  Nothing -> error "invalid character"+                                  Just (2,_) | a == mempty -> Nothing+                                  Just (i,_) -> Just (bit i :: Natural, TwoPower i a b)+          where options = [(i, bit (i-2) :: Natural) | i <- [2..k]]+                worksb (_,phi) = phi `stimes` b == mempty++-- | Similar to Maybe, but with different Semigroup and Monoid instances.+type OrZero a = Ap Maybe a++-- | 'Ap' 'Nothing'+pattern Zero :: OrZero a+pattern Zero = Ap Nothing++-- | 'Ap' ('Just' x)+pattern NonZero :: a -> OrZero a+pattern NonZero x = Ap (Just x)++{-# COMPLETE Zero, NonZero #-}++-- | Interpret an `OrZero` as a number, taking the `Zero` case to be 0.+orZeroToNum :: Num a => (b -> a) -> OrZero b -> a+orZeroToNum _ Zero = 0+orZeroToNum f (NonZero x) = f x++-- | In general, evaluating a DirichletCharacter at a point involves solving the discrete logarithm+-- problem, which can be hard: the implementations here are around O(sqrt n).+-- However, evaluating a dirichlet character at every point amounts to solving the discrete+-- logarithm problem at every point also, which can be done together in O(n) time, better than+-- using a complex algorithm at each point separately. Thus, if a large number of evaluations+-- of a dirichlet character are required, `evalAll` will be better than `evalGeneral`, since+-- computations can be shared.+evalAll :: forall n. KnownNat n => DirichletCharacter n -> Vector (OrZero RootOfUnity)+evalAll (Generated xs) = V.generate (naturalToInt n) func+  where n = natVal (Proxy :: Proxy n)+        vectors = map mkVector xs+        func :: Int -> OrZero RootOfUnity+        func m = foldMap go vectors+          where go :: (Int, Vector (OrZero RootOfUnity)) -> OrZero RootOfUnity+                go (modulus,v) = v ! (m `mod` modulus)+        mkVector :: DirichletFactor -> (Int, Vector (OrZero RootOfUnity))+        mkVector Two = (2, V.fromList [Zero, mempty])+        mkVector (OddPrime p k (naturalToInt -> g) a) = (modulus, w)+          where+            p' = unPrime p+            modulus = naturalToInt (p'^k) :: Int+            w = V.create $ do+              v <- MV.replicate modulus Zero+              -- TODO: we're in the ST monad here anyway, could be better to use STRefs to manage+              -- this loop, the current implementation probably doesn't fuse well+              let powers = iterateMaybe go (1,mempty)+                  go (m,x) = if m' > 1+                                then Just (m', x<>a)+                                else Nothing+                    where m' = m*g `mod` modulus+              for_ powers $ \(m,x) -> MV.unsafeWrite v m (NonZero x)+              -- don't bother with bounds check since m was reduced mod p^k+              return v+        -- for powers of two we use lambda directly instead, since the generators of the cyclic+        -- groups aren't obvious; it's possible to get them though:+        -- 5^(lambda(5)^{-1} mod 2^(p-2)) mod 2^p+        mkVector (TwoPower k a b) = (modulus, w)+          where+            modulus = bit k+            w = V.generate modulus f+            f m+              | even m = Zero+              | otherwise = NonZero ((if testBit m 1 then a else mempty) <> lambda (toInteger m'') k `stimes` b)+              where m'' = thingy k m++-- somewhere between unfoldr and iterate+iterateMaybe :: (a -> Maybe a) -> a -> [a]+iterateMaybe f x = unfoldr (fmap (\t -> (t, f t))) (Just x)++-- | Attempt to construct a character from its table of values.+-- An inverse to `evalAll`, defined only on its image.+fromTable :: forall n. KnownNat n => Vector (OrZero RootOfUnity) -> Maybe (DirichletCharacter n)+fromTable v = if length v == naturalToInt n+                 then traverse makeFactor tmpl >>= check . Generated+                 else Nothing+  where n = natVal (Proxy :: Proxy n)+        n' = naturalToInteger n :: Integer+        tmpl = snd (mkTemplate n)+        check :: DirichletCharacter n -> Maybe (DirichletCharacter n)+        check chi = if evalAll chi == v then Just chi else Nothing+        makeFactor :: Template -> Maybe DirichletFactor+        makeFactor TwoTemplate = Just Two+        makeFactor (TwoPTemplate k _) = TwoPower k <$> getValue (-1,bit k) <*> getValue (exp4 k, bit k)+        makeFactor (OddTemplate p k g _) = OddPrime p k g <$> getValue (toInteger g, toInteger (unPrime p)^k)+        getValue :: (Integer, Integer) -> Maybe RootOfUnity+        getValue (g, m) = getAp (v ! fromInteger (fst (fromJust (chinese (g, m) (1, n' `quot` m))) `mod` n'))++exp4terms :: [Rational]+exp4terms = [4^k % product [1..k] | k <- [0..]]++-- For reasons that aren't clear to me, `exp4` gives the inverse of 1 under lambda, so it gives the generator+-- This is the same as https://oeis.org/A320814+-- In particular, lambda (exp4 n) n == 1 (for n >= 3)+-- I've verified this for 3 <= n <= 2000, so the reasoning in fromTable should be accurate for moduli below 2^2000+exp4 :: Int -> Integer+exp4 n+  = (`mod` bit n)+  $ sum+  $ map (\q -> (numerator q * fromMaybe (error "error in exp4") (recipMod (denominator q) (bit n))) `mod` bit n)+  $ take n exp4terms
+ Math/NumberTheory/Euclidean/Coprimes.hs view
@@ -0,0 +1,138 @@+-- |+-- Module:      Math.NumberTheory.Euclidean.Coprimes+-- Copyright:   (c) 2017-2018 Andrew Lelechenko+-- Licence:     MIT+-- Maintainer:  Andrew Lelechenko <andrew.lelechenko@gmail.com>+--+-- Container for pairwise coprime numbers.++{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections       #-}++module Math.NumberTheory.Euclidean.Coprimes+  ( splitIntoCoprimes+  , Coprimes+  , unCoprimes+  , singleton+  , insert+  ) where++import Prelude hiding (gcd, quot, rem)+import Data.Coerce+import Data.Euclidean+import Data.List (tails)+import Data.Maybe+import Data.Semiring (Semiring(..), isZero)+import Data.Traversable++-- | A list of pairwise coprime numbers+-- with their multiplicities.+newtype Coprimes a b = Coprimes {+  unCoprimes :: [(a, b)] -- ^ Unwrap.+  }+  deriving (Eq, Show)++unsafeDivide :: GcdDomain a => a -> a -> a+unsafeDivide x y = case x `divide` y of+  Nothing -> error "violated prerequisite of unsafeDivide"+  Just z  -> z++-- | Check whether an element is a unit of the ring.+isUnit :: (Eq a, GcdDomain a) => a -> Bool+isUnit x = not (isZero x) && isJust (one `divide` x)++doPair :: (Eq a, GcdDomain a, Eq b, Num b) => a -> b -> a -> b -> (a, a, [(a, b)])+doPair x xm y ym+  | isUnit g  = (x, y, [])+  | otherwise = (x', y', concat rests)+    where+      g = gcd x y++      (x', g', xgs) = doPair (x `unsafeDivide` g) xm g (xm + ym)+      xgs' = if isUnit g' then xgs else (g', xm + ym) : xgs++      (y', rests) = mapAccumL go (y `unsafeDivide` g) xgs'+      go w (t, tm) = (w', if isUnit t' || tm == 0 then acc else (t', tm) : acc)+        where+          (w', t', acc) = doPair w ym t tm++_propDoPair :: (Eq a, Num a, GcdDomain a, Integral b) => a -> b -> a -> b -> Bool+_propDoPair x xm y ym+  =  isJust (x `divide` x')+  && isJust (y `divide` y')+  && coprime x' y'+  && all (coprime x' . fst) rest+  && all (coprime y' . fst) rest+  && not (any (isUnit . fst) rest)+  && and [ coprime s t | (s, _) : ts <- tails rest, (t, _) <- ts ]+  && abs ((x ^ xm) * (y ^ ym)) == abs ((x' ^ xm) * (y' ^ ym) * product (map (uncurry (^)) rest))+  where+    (x', y', rest) = doPair x xm y ym++insertInternal+  :: forall a b.+     (Eq a, GcdDomain a, Eq b, Num b)+  => a+  -> b+  -> Coprimes a b+  -> (Coprimes a b, Coprimes a b)+insertInternal xx xm+  | isZero xx && xm == 0 = (, Coprimes [])+  | isZero xx            = const (Coprimes [(zero, 1)], Coprimes [])+  | otherwise            = coerce (go ([], []) xx)+  where+    go :: ([(a, b)], [(a, b)]) -> a -> [(a, b)] -> ([(a, b)], [(a, b)])+    go (old, new) x rest+      | isUnit x = (rest ++ old, new)+    go (old, new) x [] = (old, (x, xm) : new)+    go _ _ ((x, _) : _)+      | isZero x = ([(zero, 1)], [])+    go (old, new) x ((y, ym) : rest)+      | isUnit y' = 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, GcdDomain a, Eq b, Num b) => a -> b -> Coprimes a b+singleton a b+  | isZero a && b == 0 = Coprimes []+  | isUnit a           = Coprimes []+  | otherwise          = 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 :: (Eq a, GcdDomain 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 (Eq a, GcdDomain 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 (Eq a, GcdDomain a, Eq b, Num b) => Monoid (Coprimes a b) where+  mempty  = Coprimes []++-- | 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 :: (Eq a, GcdDomain a, Eq b, Num b) => [(a, b)] -> Coprimes a b+splitIntoCoprimes = foldl (\acc (x, xm) -> insert x xm acc) mempty
− Math/NumberTheory/GCD.hs 
@@ -1,247 +0,0 @@--- |--- Module:      Math.NumberTheory.GCD--- Copyright:   (c) 2011 Daniel Fischer--- Licence:     MIT--- Maintainer:  Daniel Fischer <daniel.is.fischer@googlemail.com>--- Stability:   Provisional--- Portability: Non-portable (GHC extensions)------ This module exports GCD and coprimality test using the binary gcd algorithm--- and GCD with the extended Euclidean algorithm.------ Efficiently counting the number of trailing zeros, the binary gcd algorithm--- can perform considerably faster than the Euclidean algorithm on average.--- For 'Int', GHC has a rewrite rule to use GMP's fast gcd, depending on--- hardware and\/or GMP version, that can be faster or slower than the binary--- algorithm (on my 32-bit box, binary is faster, on my 64-bit box, GMP).--- For 'Word' and the sized @IntN\/WordN@ types, there is no rewrite rule (yet)--- in GHC, and the binary algorithm performs consistently (so far as my tests go)--- much better (if this module's rewrite rules fire).------ When using this module, always compile with optimisations turned on to--- benefit from GHC's primops and the rewrite rules.-{-# LANGUAGE CPP, BangPatterns, MagicHash #-}-module Math.NumberTheory.GCD-    ( binaryGCD-    , extendedGCD-    , coprime-    ) where--import Data.Bits-import GHC.Word-import GHC.Int--import Math.NumberTheory.GCD.LowLevel-import Math.NumberTheory.Utils--#include "MachDeps.h"--{-# RULES-"binaryGCD/Int"     binaryGCD = gcdInt-"binaryGCD/Word"    binaryGCD = gcdWord-"binaryGCD/Int8"    binaryGCD = gi8-"binaryGCD/Int16"   binaryGCD = gi16-"binaryGCD/Int32"   binaryGCD = gi32-"binaryGCD/Word8"   binaryGCD = gw8-"binaryGCD/Word16"  binaryGCD = gw16-"binaryGCD/Word32"  binaryGCD = gw32-  #-}-#if WORD_SIZE_IN_BITS == 64-gi64 :: Int64 -> Int64 -> Int64-gi64 (I64# x#) (I64# y#) = I64# (gcdInt# x# y#)--gw64 :: Word64 -> Word64 -> Word64-gw64 (W64# x#) (W64# y#) = W64# (gcdWord# x# y#)--{-# RULES-"binaryGCD/Int64"   binaryGCD = gi64-"binaryGCD/Word64"  binaryGCD = gw64-  #-}-#endif-{-# INLINE [1] binaryGCD #-}--- | Calculate the greatest common divisor using the binary gcd algorithm.---   Depending on type and hardware, that can be considerably faster than---   @'Prelude.gcd'@ but it may also be significantly slower.------   There are specialised functions for @'Int'@ and @'Word'@ and rewrite rules---   for those and @IntN@ and @WordN@, @N <= WORD_SIZE_IN_BITS@, to use the---   specialised variants. These types are worth benchmarking, others probably not.------   It is very slow for 'Integer' (and probably every type except the abovementioned),---   I recommend not using it for those.------   Relies on twos complement or sign and magnitude representaion for signed types.-binaryGCD :: (Integral a, Bits a) => a -> a -> a-binaryGCD = binaryGCDImpl--#if WORD_SIZE_IN_BITS < 64-{-# SPECIALISE binaryGCDImpl :: Word64 -> Word64 -> Word64,-                                Int64 -> Int64 -> Int64 #-}-#endif-{-# SPECIALISE binaryGCDImpl :: Integer -> Integer -> Integer #-}-binaryGCDImpl :: (Integral a, Bits a) => a -> a -> a-binaryGCDImpl a 0 = abs a-binaryGCDImpl 0 b = abs b-binaryGCDImpl a b =-    case shiftToOddCount a' of-      (!za, !oa) ->-        case shiftToOddCount b' of-          (!zb, !ob) -> gcdOdd (abs oa) (abs ob) `shiftL` min za zb-    where-      a' = abs a-      b' = abs b--{-# SPECIALISE extendedGCD :: Int -> Int -> (Int, Int, Int),-                              Word -> Word -> (Word, Word, Word),-                              Integer -> Integer -> (Integer, Integer, Integer)-  #-}--- | 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 :: Integral a => a -> a -> (a, a, a)-extendedGCD a b = (d, u, v)-  where-    (d, x, y) = eGCD 0 1 1 0 (abs a) (abs b)-    u | a < 0     = negate x-      | otherwise = x-    v | b < 0     = negate y-      | otherwise = y-    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--{-# RULES-"coprime/Int"       coprime = coprimeInt-"coprime/Word"      coprime = coprimeWord-"coprime/Int8"      coprime = ci8-"coprime/Int16"     coprime = ci16-"coprime/Int32"     coprime = ci32-"coprime/Word8"     coprime = cw8-"coprime/Word16"    coprime = cw16-"coprime/Word32"    coprime = cw32-  #-}-#if WORD_SIZE_IN_BITS == 64-ci64 :: Int64 -> Int64 -> Bool-ci64 (I64# x#) (I64# y#) = coprimeInt# x# y#--cw64 :: Word64 -> Word64 -> Bool-cw64 (W64# x#) (W64# y#) = coprimeWord# x# y#--{-# RULES-"coprime/Int64"     coprime = ci64-"coprime/Word64"    coprime = cw64-  #-}-#endif-{-# INLINE [1] coprime #-}--- | Test whether two numbers are coprime using an abbreviated binary gcd algorithm.---   A little bit faster than checking @binaryGCD a b == 1@ if one of the arguments---   is even, much faster if both are even.------   The remarks about performance at 'binaryGCD' apply here too, use this function---   only at the types with rewrite rules.------   Relies on twos complement or sign and magnitude representaion for signed types.-coprime :: (Integral a, Bits a) => a -> a -> Bool-coprime = coprimeImpl---- 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-#if WORD_SIZE_IN_BITS < 64-{-# SPECIALISE coprimeImpl :: Word64 -> Word64 -> Bool,-                              Int64 -> Int64 -> Bool #-}-#endif-{-# SPECIALISE coprimeImpl :: Integer -> Integer -> Bool #-}-coprimeImpl :: (Integral a, Bits a) => a -> a -> Bool-coprimeImpl a b =-  (a' == 1 || b' == 1)-  || (a' /= 0 && b' /= 0 && ((a .|. b) .&. 1) == 1-      && gcdOdd (abs (shiftToOdd a')) (abs (shiftToOdd b')) == 1)-    where-      a' = abs a-      b' = abs b---- Auxiliaries---- gcd of two odd numbers-{-# INLINE gcdOdd #-}-gcdOdd :: (Integral a, Bits a) => a -> a -> a-gcdOdd a b-  | a == 1 || b == 1    = 1-  | a < b               = oddGCD b a-  | a > b               = oddGCD a b-  | otherwise           = a--{-# SPECIALISE oddGCD :: Integer -> Integer -> Integer #-}-#if WORD_SIZE_IN_BITS < 64-{-# SPECIALISE oddGCD :: Int64 -> Int64 -> Int64,-                         Word64 -> Word64 -> Word64-  #-}-#endif-oddGCD :: (Integral a, Bits a) => a -> a -> a-oddGCD a b =-    case shiftToOdd (a-b) of-      1 -> 1-      c | c < b     -> oddGCD b c-        | c > b     -> oddGCD c b-        | otherwise -> c------------------------------------------------------------------------------------                Blech! Getting the rules to fire isn't easy.               ------------------------------------------------------------------------------------gi8 :: Int8 -> Int8 -> Int8-gi8 (I8# x#) (I8# y#) = I8# (gcdInt# x# y#)--gi16 :: Int16 -> Int16 -> Int16-gi16 (I16# x#) (I16# y#) = I16# (gcdInt# x# y#)--gi32 :: Int32 -> Int32 -> Int32-gi32 (I32# x#) (I32# y#) = I32# (gcdInt# x# y#)--gw8 :: Word8 -> Word8 -> Word8-gw8 (W8# x#) (W8# y#) = W8# (gcdWord# x# y#)--gw16 :: Word16 -> Word16 -> Word16-gw16 (W16# x#) (W16# y#) = W16# (gcdWord# x# y#)--gw32 :: Word32 -> Word32 -> Word32-gw32 (W32# x#) (W32# y#) = W32# (gcdWord# x# y#)--ci8 :: Int8 -> Int8 -> Bool-ci8 (I8# x#) (I8# y#) = coprimeInt# x# y#--ci16 :: Int16 -> Int16 -> Bool-ci16 (I16# x#) (I16# y#) = coprimeInt# x# y#--ci32 :: Int32 -> Int32 -> Bool-ci32 (I32# x#) (I32# y#) = coprimeInt# x# y#--cw8 :: Word8 -> Word8 -> Bool-cw8 (W8# x#) (W8# y#) = coprimeWord# x# y#--cw16 :: Word16 -> Word16 -> Bool-cw16 (W16# x#) (W16# y#) = coprimeWord# x# y#--cw32 :: Word32 -> Word32 -> Bool-cw32 (W32# x#) (W32# y#) = coprimeWord# x# y#
− Math/NumberTheory/GCD/LowLevel.hs 
@@ -1,101 +0,0 @@--- |--- Module:      Math.NumberTheory.GCD.LowLevel--- Copyright:   (c) 2011 Daniel Fischer--- Licence:     MIT--- Maintainer:  Daniel Fischer <daniel.is.fischer@googlemail.com>--- Stability:   Provisional--- Portability: Non-portable (GHC extensions)------ Low level gcd and coprimality functions using the binary gcd algorithm.--- Normally, accessing these via the higher level interface of "Math.NumberTheory.GCD"--- should be sufficient.----{-# LANGUAGE MagicHash     #-}-{-# LANGUAGE UnboxedTuples #-}-module Math.NumberTheory.GCD.LowLevel-  ( -- * Specialised GCDs-    gcdInt-  , gcdWord-    -- ** GCDs for unboxed types-  , gcdInt#-  , gcdWord#-    -- * Specialised tests for coprimality-  , coprimeInt-  , coprimeWord-    -- ** Coprimality tests for unboxed types-  , coprimeInt#-  , coprimeWord#-  ) where--import GHC.Base--import Math.NumberTheory.Utils---- | 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#)---- | Test whether two 'Int's are coprime, using an abbreviated binary gcd algorithm.-coprimeInt :: Int -> Int -> Bool-coprimeInt (I# a#) (I# b#) = coprimeInt# a# b#---- | Greatest common divisor of two 'Word's, calculated with the binary gcd algorithm.-gcdWord :: Word -> Word -> Word-gcdWord (W# a#) (W# b#) = W# (gcdWord# a# b#)---- | Test whether two 'Word's are coprime, using an abbreviated binary gcd algorithm.-coprimeWord :: Word -> Word -> Bool-coprimeWord (W# a#) (W# b#) = coprimeWord# a# b#---- | Greatest common divisor of two 'Int#'s, calculated with the binary gcd algorithm.-gcdInt# :: Int# -> Int# -> Int#-gcdInt# a# b# = word2Int# (gcdWord# (int2Word# (absInt# a#)) (int2Word# (absInt# b#)))----- | Test whether two 'Int#'s are coprime.-coprimeInt# :: Int# -> Int# -> Bool-coprimeInt# a# b# = coprimeWord# (int2Word# (absInt# a#)) (int2Word# (absInt# b#))---- | Greatest common divisor of two 'Word#'s, calculated with the binary gcd algorithm.-gcdWord# :: Word# -> Word# -> Word#-gcdWord# a# 0## = a#-gcdWord# 0## b# = b#-gcdWord# a# b#  =-    case shiftToOddCount# a# of-      (# za#, oa# #) ->-        case shiftToOddCount# b# of-          (# zb#, ob# #) -> gcdWordOdd# oa# ob# `uncheckedShiftL#` (if isTrue# (za# <# zb#) then za# else zb#)---- | Test whether two 'Word#'s are coprime.-coprimeWord# :: Word# -> Word# -> Bool-coprimeWord# a# b# =-  (isTrue# (a# `eqWord#` 1##) || isTrue# (b# `eqWord#` 1##))-  || (isTrue# (((a# `or#` b#) `and#` 1##) `eqWord#` 1##) -- not both even-      && ((isTrue# (a# `neWord#` 0##) && isTrue# (b# `neWord#` 0##)) -- neither is zero-      && isTrue# (gcdWordOdd# (shiftToOdd# a#) (shiftToOdd# b#) `eqWord#` 1##)))---- Various auxiliary functions---- calculate the gcd of two odd numbers-{-# INLINE gcdWordOdd# #-}-gcdWordOdd# :: Word# -> Word# -> Word#-gcdWordOdd# a# b#-  | isTrue# (a# `eqWord#` 1##) || isTrue# (b# `eqWord#` 1##)    = 1##-  | isTrue# (a# `eqWord#` b#)                                   = a#-  | isTrue# (a# `ltWord#` b#)                                   = oddGCD# b# a#-  | otherwise                                                   = oddGCD# a# b#---- calculate the gcd of two odd numbers using the binary gcd algorithm--- Precondition: first argument strictly larger than second (which should be greater than 1)-oddGCD# :: Word# -> Word# -> Word#-oddGCD# a# b# =-    case shiftToOdd# (a# `minusWord#` b#) of-      1## -> 1##-      c#  | isTrue# (c# `ltWord#` b#)   -> oddGCD# b# c#-          | isTrue# (c# `gtWord#` b#)   -> oddGCD# c# b#-          | otherwise                   -> c#--absInt# :: Int# -> Int#-absInt# i#-  | isTrue# (i# <# 0#)  = negateInt# i#-  | otherwise           = i#
− Math/NumberTheory/GaussianIntegers.hs 
@@ -1,239 +0,0 @@--- |--- Module:      Math.NumberTheory.GaussianIntegers--- Copyright:   (c) 2016 Chris Fredrickson--- Licence:     MIT--- Maintainer:  Chris Fredrickson <chris.p.fredrickson@gmail.com>--- Stability:   Provisional--- Portability: Non-portable (GHC extensions)------ This module exports functions for manipulating Gaussian integers, including--- 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-    | g == 0    = error "0 has no prime factorisation"-    | g == 1    = []-    | otherwise =-        let helper :: [(Integer, Int)] -> GaussianInteger -> [(GaussianInteger, Int)] -> [(GaussianInteger, Int)]-            helper [] g' fs = (if g' == 1 then [] else [(g', 1)]) ++ fs    -- include the unit, if it isn't 1-            helper ((!p, !e) : pt) g' fs-                | p `mod` 4 == 3 =-                    -- prime factors congruent to 3 mod 4 are simple.-                    let pow = div e 2-                        gp = fromInteger p-                    in helper pt (g' `divG` (gp .^ pow)) ((gp, pow) : fs)-                | otherwise      =-                    -- general case: for every prime factor of the magnitude-                    -- squared, find a Gaussian prime whose magnitude squared-                    -- is that prime. Then find out how many times the original-                    -- number is divisible by that Gaussian prime and its-                    -- conjugate. The order that the prime factors are-                    -- processed doesn't really matter, but it is reversed so-                    -- that the Gaussian primes will be in order of increasing-                    -- magnitude.-                    let gp = findPrime' p-                        (!gNext, !facs) = trialDivide g' [gp, abs $ conjugate gp] []-                    in helper pt gNext (facs ++ fs)-        in helper (reverse . Factorisation.factorise $ norm g) 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, Int)] -> (GaussianInteger, [(GaussianInteger, Int)])-trialDivide g [] fs = (g, fs)-trialDivide g (pf : pft) fs-    | g `modG` pf == 0 =-        let (cnt, g') = countEvenDivisions g pf-        in trialDivide g' pft ((pf, cnt) : fs)-    | otherwise    = trialDivide g pft fs---- 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')
Math/NumberTheory/Moduli.hs view
@@ -3,8 +3,6 @@ -- Copyright:   (c) 2011 Daniel Fischer -- Licence:     MIT -- Maintainer:  Daniel Fischer <daniel.is.fischer@googlemail.com>--- Stability:   Provisional--- Portability: Non-portable (GHC extensions) -- -- Miscellaneous functions related to modular arithmetic. --@@ -12,11 +10,13 @@ module Math.NumberTheory.Moduli   ( module Math.NumberTheory.Moduli.Class   , module Math.NumberTheory.Moduli.Chinese-  , module Math.NumberTheory.Moduli.Jacobi+  , module Math.NumberTheory.Moduli.Multiplicative+  , module Math.NumberTheory.Moduli.Singleton   , module Math.NumberTheory.Moduli.Sqrt   ) where  import Math.NumberTheory.Moduli.Chinese import Math.NumberTheory.Moduli.Class-import Math.NumberTheory.Moduli.Jacobi+import Math.NumberTheory.Moduli.Multiplicative+import Math.NumberTheory.Moduli.Singleton import Math.NumberTheory.Moduli.Sqrt
+ Math/NumberTheory/Moduli/Cbrt.hs view
@@ -0,0 +1,160 @@+-- |+-- Module:      Math.NumberTheory.Moduli.Cbrt+-- Copyright:   (c) 2020 Federico Bongiorno+-- Licence:     MIT+-- Maintainer:  Federico Bongiorno <federicobongiorno97@gmail.com>+--+-- <https://en.wikipedia.org/wiki/Cubic_reciprocity#Cubic_residue_character Cubic symbol>+-- of two Eisenstein Integers.++{-# LANGUAGE LambdaCase #-}++module Math.NumberTheory.Moduli.Cbrt+  ( CubicSymbol(..)+  , cubicSymbol+  , symbolToNum+  ) where++import Math.NumberTheory.Quadratic.EisensteinIntegers+import Math.NumberTheory.Utils.FromIntegral+import qualified Data.Euclidean as A+import Math.NumberTheory.Utils+import Data.Semigroup++-- | Represents the+-- <https://en.wikipedia.org/wiki/Cubic_reciprocity#Cubic_residue_character cubic residue character>+-- It is either @0@, @ω@, @ω²@ or @1@.+data CubicSymbol = Zero | Omega | OmegaSquare | One deriving (Eq)++-- | The set of cubic symbols form a semigroup. Note `stimes`+-- is allowed to take non-positive values. In other words, the set+-- of non-zero cubic symbols is regarded as a group.+--+-- >>> import Data.Semigroup+-- >>> stimes (-1) Omega+-- ω²+-- >>> stimes 0 Zero+-- 1+instance Semigroup CubicSymbol where+  Zero <> _                    = Zero+  _ <> Zero                    = Zero+  One <> y                     = y+  x <> One                     = x+  Omega <> Omega               = OmegaSquare+  Omega <> OmegaSquare         = One+  OmegaSquare <> Omega         = One+  OmegaSquare <> OmegaSquare   = Omega+  stimes k n = case (k `mod` 3, n) of+    (0, _)           -> One+    (1, symbol)       -> symbol+    (2, Omega)       -> OmegaSquare+    (2, OmegaSquare) -> Omega+    (2, symbol)      -> symbol+    _                -> error "Math.NumberTheory.Moduli.Cbrt: exponentiation undefined."++instance Show CubicSymbol where+  show = \case+    Zero         -> "0"+    Omega        -> "ω"+    OmegaSquare  -> "ω²"+    One          -> "1"++-- | Converts a+-- <https://en.wikipedia.org/wiki/Cubic_reciprocity#Cubic_residue_character cubic symbol>+-- to an Eisenstein Integer.+symbolToNum :: CubicSymbol -> EisensteinInteger+symbolToNum = \case+  Zero        -> 0+  Omega       -> ω+  OmegaSquare -> -1 - ω+  One         -> 1++-- The algorithm `cubicSymbol` is adapted from+-- <https://cs.au.dk/~gudmund/Documents/cubicres.pdf here>.+-- It is divided in the following steps.+--+-- (1) Check whether @beta@ is coprime to 3.+-- (2) Replace @alpha@ by the remainder of @alpha@ mod @beta@+--     This does not affect the cubic symbol.+-- (3) Replace @alpha@ and @beta@ by their associated primary+--     divisors and keep track of how their cubic residue changes.+-- (4) Check if any of the two numbers is a zero or a unit. In this+--     case, return their cubic residue.+-- (5) Otherwise, invoke cubic reciprocity by swapping @alpha@ and+--     @beta@. Note both numbers have to be primary.+--     Return to Step 2.++-- | <https://en.wikipedia.org/wiki/Cubic_reciprocity#Cubic_residue_character Cubic symbol>+-- of two Eisenstein Integers.+-- The first argument is the numerator and the second argument+-- is the denominator. The latter must be coprime to @3@.+-- This condition is checked.+--+-- If the arguments have a common factor, the result+-- is 'Zero', otherwise it is either 'Omega', 'OmegaSquare' or 'One'.+--+-- >>> cubicSymbol (45 + 23*ω) (11 - 30*ω)+-- 0+-- >>> cubicSymbol (31 - ω) (1 +10*ω)+-- ω+cubicSymbol :: EisensteinInteger -> EisensteinInteger -> CubicSymbol+cubicSymbol alpha beta = case beta `A.rem` (1 - ω) of+  -- This checks whether beta is coprime to 3, i.e. divisible by @1 - ω@+  -- In particular, it returns an error if @beta == 0@+  0 -> error "Math.NumberTheory.Moduli.Cbrt: denominator is not coprime to 3."+  _ -> cubicSymbolHelper alpha beta++cubicSymbolHelper :: EisensteinInteger -> EisensteinInteger -> CubicSymbol+cubicSymbolHelper alpha beta = cubicReciprocity primaryRemainder primaryBeta <> newSymbol+  where+    (primaryRemainder, primaryBeta, newSymbol) = extractPrimaryContributions remainder beta+    remainder = A.rem alpha beta++cubicReciprocity :: EisensteinInteger -> EisensteinInteger -> CubicSymbol+-- Note @cubicReciprocity 0 1 = One@. It is better to adopt this convention.+cubicReciprocity _ 1 = One+-- Checks if first argument is zero. Note the second argument is never zero.+cubicReciprocity 0 _ = Zero+-- This checks if the first argument is a unit. Because it's primary,+-- it is enough to pattern match with 1.+cubicReciprocity 1 _ = One+-- Otherwise, cubic reciprocity is called.+cubicReciprocity alpha beta = cubicSymbolHelper beta alpha++-- | This function takes two Eisenstein integers @alpha@ and @beta@ and returns+-- three arguments @(gamma, delta, newSymbol)@. @gamma@ and @delta@ are the+-- associated primary numbers of alpha and beta respectively. @newSymbol@+-- is the cubic symbol measuring the discrepancy between the cubic residue+-- of @alpha@ and @beta@, and the cubic residue of @gamma@ and @delta@.+extractPrimaryContributions :: EisensteinInteger -> EisensteinInteger -> (EisensteinInteger, EisensteinInteger, CubicSymbol)+extractPrimaryContributions alpha beta = (gamma, delta, newSymbol)+  where+    newSymbol = stimes (j * m) Omega <> stimes (- m - n) i+    m :+ n = A.quot (delta - 1) 3+    (i, gamma) = getPrimaryDecomposition alphaThreeFree+    (_, delta) = getPrimaryDecomposition beta+    j = wordToInteger jIntWord+    -- This function outputs data such that+    -- @(1 - ω)^jIntWord * alphaThreeFree = alpha@.+    (jIntWord, alphaThreeFree) = splitOff (1 - ω) alpha++-- | This function takes an Eisenstein number @e@ and returns @(symbol, delta)@+-- where @delta@ is its associated primary integer and @symbol@ is the+-- cubic symbol discrepancy between @e@ and @delta@. @delta@ is defined to be+-- the unique associated Eisenstein Integer to @e@ such that+-- \( \textrm{delta} \equiv 1 (\textrm{mod} 3) \).+-- Note that @delta@ exists if and only if @e@ is coprime to 3. In this+-- case, an error message is displayed.+getPrimaryDecomposition :: EisensteinInteger -> (CubicSymbol, EisensteinInteger)+-- This is the case where a common factor between @alpha@ and @beta@ is detected.+-- In this instance @cubicReciprocity@ will return `Zero`.+-- Strictly speaking, this is not a primary decomposition.+getPrimaryDecomposition 0 = (Zero, 0)+getPrimaryDecomposition e = case e `A.rem` 3 of+  1            -> (One, e)+  1 :+ 1       -> (OmegaSquare, -ω * e)+  0 :+ 1       -> (Omega, (-1 - ω) * e)+  (-1) :+ 0    -> (One, -e)+  (-1) :+ (-1) -> (OmegaSquare, ω * e)+  0 :+ (-1)    -> (Omega, (1 + ω) * e)+  _            -> error "Math.NumberTheory.Moduli.Cbrt: primary decomposition failed."
Math/NumberTheory/Moduli/Chinese.hs view
@@ -1,59 +1,92 @@ -- | -- Module:      Math.NumberTheory.Moduli.Chinese--- Copyright:   (c) 2011 Daniel Fischer+-- Copyright:   (c) 2011 Daniel Fischer, 2018 Andrew Lelechenko -- Licence:     MIT -- Maintainer:  Andrew Lelechenko <andrew.lelechenko@gmail.com>--- Stability:   Provisional--- Portability: Non-portable (GHC extensions) -- -- Chinese remainder theorem -- -{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE ScopedTypeVariables #-}  module Math.NumberTheory.Moduli.Chinese-  ( chineseRemainder-  , chineseRemainder2+  ( -- * Safe interface+    chinese+  , chineseSomeMod   ) where -import Control.Monad (foldM)-import GHC.Integer.GMP.Internals+import Prelude hiding ((^), (+), (-), (*), rem, mod, quot, gcd, lcm) -import Math.NumberTheory.GCD (extendedGCD)+import Data.Euclidean+import Data.Mod+import Data.Ratio+import Data.Semiring (Semiring(..), (+), (-), (*), Ring)+import GHC.TypeNats (KnownNat, natVal) --- | Given a list @[(r_1,m_1), ..., (r_n,m_n)]@ of @(residue,modulus)@---   pairs, @chineseRemainder@ calculates the solution to the simultaneous---   congruences------ >--- > r ≡ r_k (mod m_k)--- >+import Math.NumberTheory.Moduli.SomeMod++-- | 'chinese' @(n1, m1)@ @(n2, m2)@ returns @(n, lcm m1 m2)@ such that+-- @n \`mod\` m1 == n1@ and @n \`mod\` m2 == n2@, if exists.+-- Moduli @m1@ and @m2@ are allowed to have common factors. -----   if all moduli are positive and pairwise coprime. Otherwise---   the result is @Nothing@ regardless of whether---   a solution exists.-chineseRemainder :: [(Integer,Integer)] -> Maybe Integer-chineseRemainder remainders = foldM addRem 0 remainders+-- >>> chinese (1, 2) (2, 3)+-- Just (-1, 6)+-- >>> chinese (3, 4) (5, 6)+-- Just (-1, 12)+-- >>> chinese (3, 4) (2, 6)+-- Nothing+chinese :: forall a. (Eq a, Ring a, Euclidean a) => (a, a) -> (a, a) -> Maybe (a, a)+chinese (n1, m1) (n2, m2)+  | d == one+  = Just ((v * m2 * n1 + u * m1 * n2) `rem` m, m)+  | (n1 - n2) `rem` d == zero+  = Just ((v * (m2 `quot` d) * n1 + u * (m1 `quot` d) * n2) `rem` m, m)+  | otherwise+  = Nothing   where-    !modulus = product (map snd remainders)-    addRem acc (_,1) = Just acc-    addRem acc (r,m) = do-        let cf = modulus `quot` m-        inv <- recipMod cf m-        Just $! (acc + inv*cf*r) `mod` modulus+    (d, u, v) = extendedGCD m1 m2+    m = if d == one then m1 * m2 else (m1 `quot` d) * m2 --- | @chineseRemainder2 (r_1,m_1) (r_2,m_2)@ calculates the solution of------ >--- > r ≡ r_k (mod m_k)+{-# SPECIALISE chinese :: (Int, Int) -> (Int, Int) -> Maybe (Int, Int) #-}+{-# SPECIALISE chinese :: (Word, Word) -> (Word, Word) -> Maybe (Word, Word) #-}+{-# SPECIALISE chinese :: (Integer, Integer) -> (Integer, Integer) -> Maybe (Integer, Integer) #-}++isCompatible :: KnownNat m => Mod m -> Rational -> Bool+isCompatible n r = case invertMod (fromInteger (denominator r)) of+  Nothing -> False+  Just r' -> r' * fromInteger (numerator r) == n++-- | Same as 'chinese', but operates on residues. -----   if @m_1@ and @m_2@ are coprime.-chineseRemainder2 :: (Integer,Integer) -> (Integer,Integer) -> Integer-chineseRemainder2 (r1, md1) (r2,md2)-    = case extendedGCD md1 md2 of-        (_,u,v) -> ((1 - u*md1)*r1 + (1 - v*md2)*r2) `mod` (md1*md2)+-- >>> :set -XDataKinds+-- >>> import Data.Mod+-- >>> (1 `modulo` 2) `chineseSomeMod` (2 `modulo` 3)+-- Just (5 `modulo` 6)+-- >>> (3 `modulo` 4) `chineseSomeMod` (5 `modulo` 6)+-- Just (11 `modulo` 12)+-- >>> (3 `modulo` 4) `chineseSomeMod` (2 `modulo` 6)+-- Nothing+chineseSomeMod :: SomeMod -> SomeMod -> Maybe SomeMod+chineseSomeMod (SomeMod n1) (SomeMod n2)+  = (\(n, m) -> n `modulo` fromInteger m) <$> chinese+    (toInteger $ unMod n1, toInteger $ natVal n1)+    (toInteger $ unMod n2, toInteger $ natVal n2)+chineseSomeMod (SomeMod n) (InfMod r)+  | isCompatible n r = Just $ InfMod r+  | otherwise        = Nothing+chineseSomeMod (InfMod r) (SomeMod n)+  | isCompatible n r = Just $ InfMod r+  | otherwise        = Nothing+chineseSomeMod (InfMod r1) (InfMod r2)+  | r1 == r2  = Just $ InfMod r1+  | otherwise = Nothing -recipMod :: Integer -> Integer -> Maybe Integer-recipMod x m = case recipModInteger x m of-  0 -> Nothing-  y -> Just y+-------------------------------------------------------------------------------+-- Utils++extendedGCD :: (Eq a, Ring a, Euclidean a) => a -> a -> (a, a, a)+extendedGCD a b = (g, s, t)+  where+    (g, s) = gcdExt a b+    t = (g - a * s) `quot` b
Math/NumberTheory/Moduli/Class.hs view
@@ -3,20 +3,15 @@ -- Copyright:   (c) 2017 Andrew Lelechenko -- Licence:     MIT -- Maintainer:  Andrew Lelechenko <andrew.lelechenko@gmail.com>--- Stability:   Provisional--- Portability: Non-portable (GHC extensions) -- -- Safe modular arithmetic with modulo on type level. -- -{-# LANGUAGE CPP                 #-}-{-# LANGUAGE DataKinds           #-}-{-# LANGUAGE GADTs               #-}-{-# LANGUAGE KindSignatures      #-}-{-# LANGUAGE LambdaCase          #-}-{-# LANGUAGE RankNTypes          #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving  #-}+{-# LANGUAGE DataKinds                  #-}+{-# LANGUAGE GADTs                      #-}+{-# LANGUAGE KindSignatures             #-}+{-# LANGUAGE RankNTypes                 #-}+{-# LANGUAGE ScopedTypeVariables        #-}  module Math.NumberTheory.Moduli.Class   ( -- * Known modulo@@ -28,6 +23,11 @@   , invertMod   , powMod   , (^%)+  -- * Multiplicative group+  , MultMod+  , multElement+  , isMultElement+  , invertGroup   -- * Unknown modulo   , SomeMod(..)   , modulo@@ -37,74 +37,12 @@   , KnownNat   ) where -import Data.Proxy-import Data.Ratio-import Data.Type.Equality-#if __GLASGOW_HASKELL__ < 709-import Data.Word-#endif-import GHC.Integer.GMP.Internals-import GHC.TypeNats.Compat-import Numeric.Natural---- | Wrapper for residues modulo @m@.------ @Mod 3 :: Mod 10@ stands for the class of integers, congruent to 3 modulo 10 (…−17, −7, 3, 13, 23…).--- 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)------ Note that modulo cannot be negative.-newtype Mod (m :: Nat) = Mod Natural-  deriving (Eq, Ord)--instance KnownNat m => Show (Mod m) where-  show m = "(" ++ show (getVal m) ++ " `modulo` " ++ show (getMod m) ++ ")"--instance KnownNat m => Num (Mod m) where-  mx@(Mod x) + Mod y =-    Mod $ if xy >= m then xy - m else xy-    where-      xy = x + y-      m = getNatMod mx-  {-# INLINE (+) #-}-  mx@(Mod x) - Mod y =-    Mod $ if x >= y then x - y else m + x - y-    where-      m = getNatMod mx-  {-# INLINE (-) #-}-  negate mx@(Mod x) =-    Mod $ if x == 0 then 0 else getNatMod mx - x-  {-# INLINE negate #-}-  mx@(Mod x) * Mod y =-    Mod $ x * y `rem` getNatMod mx -- `rem` is slightly faster than `mod`-  {-# INLINE (*) #-}-  abs = id-  {-# INLINE abs #-}-  signum = const $ Mod 1-  {-# INLINE signum #-}-  fromInteger x = mx-    where-      mx = Mod $ fromInteger $ x `mod` getMod mx-  {-# INLINE fromInteger #-}+import Data.Mod+import GHC.Natural+import GHC.TypeNats (KnownNat, natVal) --- | Beware that division by residue, which is not coprime with the modulo,--- will result in runtime error. Consider using 'invertMod' instead.-instance KnownNat m => Fractional (Mod m) where-  fromRational r = case denominator r of-    1   -> num-    den -> num / fromInteger den-    where-      num = fromInteger (numerator r)-  {-# INLINE fromRational #-}-  recip mx = case invertMod mx of-    Nothing -> error $ "recip{Mod}: residue is not coprime with modulo"-    Just y  -> y-  {-# INLINE recip #-}+import Math.NumberTheory.Moduli.Multiplicative+import Math.NumberTheory.Moduli.SomeMod  -- | Linking type and value levels: extract modulo @m@ as a value. getMod :: KnownNat m => Mod m -> Integer@@ -116,191 +54,17 @@ getNatMod = natVal {-# INLINE getNatMod #-} --- | The canonical representative of the residue class, always between 0 and @m-1@ inclusively.-getVal :: KnownNat m => Mod m -> Integer-getVal (Mod x) = toInteger x+-- | The canonical representative of the residue class, always between 0 and m-1 inclusively.+getVal :: Mod m -> Integer+getVal = toInteger . unMod {-# INLINE getVal #-} --- | The canonical representative of the residue class, always between 0 and @m-1@ inclusively.-getNatVal :: KnownNat m => Mod m -> Natural-getNatVal (Mod x) = x+-- | The canonical representative of the residue class, always between 0 and m-1 inclusively.+getNatVal :: Mod m -> Natural+getNatVal = unMod {-# 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-invertMod :: KnownNat m => Mod m -> Maybe (Mod m)-invertMod mx-  = if y <= 0-    then Nothing-    else Just $ Mod $ fromInteger y-  where-    y = recipModInteger (getVal mx) (getMod mx)-{-# INLINABLE invertMod #-}---- | Drop-in replacement for '^', with much better performance.------ > > powMod (3 :: Mod 10) 4--- > (1 `modulo` 10)+-- | Synonym of '(^%)'. powMod :: (KnownNat m, Integral a) => Mod m -> a -> Mod m-powMod mx a-  | a < 0     = error $ "^{Mod}: negative exponent"-  | otherwise = Mod $ fromInteger $ powModInteger (getVal mx) (toInteger a) (getMod mx)-{-# INLINABLE [1] powMod #-}--{-# SPECIALISE [1] powMod ::-  KnownNat m => Mod m -> Integer -> Mod m,-  KnownNat m => Mod m -> Natural -> Mod m,-  KnownNat m => Mod m -> Int     -> Mod m,-  KnownNat m => Mod m -> Word    -> Mod m #-}--{-# RULES-"powMod/2/Integer"     forall x. powMod x (2 :: Integer) = let u = x in u*u-"powMod/3/Integer"     forall x. powMod x (3 :: Integer) = let u = x in u*u*u-"powMod/2/Int"         forall x. powMod x (2 :: Int)     = let u = x in u*u-"powMod/3/Int"         forall x. powMod x (3 :: Int)     = let u = x in u*u*u #-}---- | Infix synonym of 'powMod'.-(^%) :: (KnownNat m, Integral a) => Mod m -> a -> Mod m-(^%) = powMod-{-# INLINE (^%) #-}--infixr 8 ^%---- Unfortunately, such rule never fires due to technical details--- of type classes in Core.--- {-# RULES "^%Mod" forall (x :: KnownNat m => Mod m) p. x ^ p = x ^% p #-}---- | 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)------ If performance is crucial, it is recommended to extract @Mod m@ for further processing--- by pattern matching. E. g.,------ > case modulo n m of--- >   SomeMod k -> process k -- Here k has type Mod m--- >   InfMod{}  -> error "impossible"-data SomeMod where-  SomeMod :: KnownNat m => Mod m -> SomeMod-  InfMod  :: Rational -> SomeMod--instance Eq SomeMod where-  SomeMod mx == SomeMod my = getMod mx == getMod my && getVal mx == getVal my-  InfMod rx  == InfMod ry  = rx == ry-  _          == _          = False--instance Show SomeMod where-  show = \case-    SomeMod m -> show m-    InfMod  r -> show r---- | Create modular value by representative of residue class and modulo.--- One can use the result either directly (via functions from 'Num' and 'Fractional'),--- or deconstruct it by pattern matching. Note that 'modulo' never returns 'InfMod'.-modulo :: Integer -> Natural -> SomeMod-modulo n m = case someNatVal m of-  SomeNat (_ :: Proxy t) -> SomeMod (fromInteger n :: Mod t)-{-# INLINABLE modulo #-}-infixl 7 `modulo`--liftUnOp-  :: (forall k. KnownNat k => Mod k -> Mod k)-  -> (Rational -> Rational)-  -> SomeMod-  -> SomeMod-liftUnOp fm fr = \case-  SomeMod m -> SomeMod (fm m)-  InfMod  r -> InfMod  (fr r)-{-# INLINEABLE liftUnOp #-}--liftBinOpMod-  :: (KnownNat m, KnownNat n)-  => (forall k. KnownNat k => Mod k -> Mod k -> Mod k)-  -> Mod m-  -> Mod n-  -> SomeMod-liftBinOpMod f mx@(Mod x) my@(Mod y) = case someNatVal m of-  SomeNat (_ :: Proxy t) -> SomeMod (Mod (x `mod` m) `f` Mod (y `mod` m) :: Mod t)-  where-    m = natVal mx `gcd` natVal my--liftBinOp-  :: (forall k. KnownNat k => Mod k -> Mod k -> Mod k)-  -> (Rational -> Rational -> Rational)-  -> SomeMod-  -> SomeMod-  -> SomeMod-liftBinOp _ fr (InfMod rx)  (InfMod ry)  = InfMod  (rx `fr` ry)-liftBinOp fm _ (InfMod rx)  (SomeMod my) = SomeMod (fromRational rx `fm` my)-liftBinOp fm _ (SomeMod mx) (InfMod ry)  = SomeMod (mx `fm` fromRational ry)-liftBinOp fm _ (SomeMod (mx :: Mod m)) (SomeMod (my :: Mod n))-  = case (Proxy :: Proxy m) `sameNat` (Proxy :: Proxy n) of-    Nothing   -> liftBinOpMod fm mx my-    Just Refl -> SomeMod (mx `fm` my)--instance Num SomeMod where-  (+)    = liftBinOp (+) (+)-  (-)    = liftBinOp (-) (+)-  negate = liftUnOp negate negate-  {-# INLINE negate #-}-  (*)    = liftBinOp (*) (*)-  abs    = id-  {-# INLINE abs #-}-  signum = const 1-  {-# INLINE signum #-}-  fromInteger = InfMod . fromInteger-  {-# INLINE fromInteger #-}---- | Beware that division by residue, which is not coprime with the modulo,--- will result in runtime error. Consider using 'invertSomeMod' instead.-instance Fractional SomeMod where-  fromRational = InfMod-  {-# INLINE fromRational #-}-  recip x = case invertSomeMod x of-    Nothing -> error $ "recip{SomeMod}: residue is not coprime with modulo"-    Just y  -> y---- | 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 :: SomeMod -> Maybe SomeMod-invertSomeMod = \case-  SomeMod m -> fmap SomeMod (invertMod m)-  InfMod  r -> Just (InfMod (recip r))-{-# INLINABLE [1] invertSomeMod #-}--{-# SPECIALISE [1] powSomeMod ::-  SomeMod -> Integer -> SomeMod,-  SomeMod -> Natural -> SomeMod,-  SomeMod -> Int     -> SomeMod,-  SomeMod -> Word    -> SomeMod #-}---- | 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 :: Integral a => SomeMod -> a -> SomeMod-powSomeMod (SomeMod m) a = SomeMod (m ^% a)-powSomeMod (InfMod  r) a = InfMod  (r ^  a)-{-# INLINABLE [1] powSomeMod #-}--{-# RULES "^%SomeMod" forall x p. x ^ p = powSomeMod x p #-}+powMod = (^%)+{-# INLINE powMod #-}
+ Math/NumberTheory/Moduli/Equations.hs view
@@ -0,0 +1,140 @@+-- |+-- Module:      Math.NumberTheory.Moduli.Equations+-- Copyright:   (c) 2018 Andrew Lelechenko+-- Licence:     MIT+-- Maintainer:  Andrew Lelechenko <andrew.lelechenko@gmail.com>+--+-- Polynomial modular equations.+--++{-# LANGUAGE MagicHash           #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UnboxedSums         #-}+{-# LANGUAGE ViewPatterns        #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++module Math.NumberTheory.Moduli.Equations+  ( solveLinear+  , solveQuadratic+  ) where++import Data.Constraint+import Data.Maybe+import Data.Mod+import GHC.Num.Integer+import GHC.TypeNats (KnownNat, natVal)++import Math.NumberTheory.Moduli.Chinese+import Math.NumberTheory.Moduli.Singleton+import Math.NumberTheory.Moduli.Sqrt+import Math.NumberTheory.Primes+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' (toInteger (natVal a)) (toInteger (unMod a)) (toInteger (unMod 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 sfactors (1 :: Mod 32) 0 (-17) -- solving x² - 17 ≡ 0 (mod 32)+-- [(9 `modulo` 32),(25 `modulo` 32),(7 `modulo` 32),(23 `modulo` 32)]+solveQuadratic+  :: SFactors Integer m+  -> Mod m   -- ^ a+  -> Mod m   -- ^ b+  -> Mod m   -- ^ c+  -> [Mod m] -- ^ list of x+solveQuadratic sm a b c = case proofFromSFactors sm of+  Sub Dict ->+    map fromInteger+    $ fst+    $ combine+    $ map (\(p, n) -> (solveQuadraticPrimePower a' b' c' p n, unPrime p ^ n))+    $ unSFactors sm+  where+    a' = toInteger $ unMod a+    b' = toInteger $ unMod b+    c' = toInteger $ unMod c++    combine :: [([Integer], Integer)] -> ([Integer], Integer)+    combine = foldl+      (\(xs, xm) (ys, ym) -> ([ fst $ fromJust $ chinese (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 `rem` p' == 0+  = solveLinear' p' b c+  | otherwise+  = map (\n -> let (# t | #) = integerRecipMod# (2 * a) (fromInteger p') in (n - b) * toInteger t `mod` p')+  $ sqrtsModPrime (b * b - 4 * a * c) p+    where+      p' :: Integer+      p' = unPrime p
+ Math/NumberTheory/Moduli/Internal.hs view
@@ -0,0 +1,159 @@+-- |+-- Module:      Math.NumberTheory.Moduli.Internal+-- Copyright:   (c) 2020 Bhavik Mehta+-- Licence:     MIT+-- Maintainer:  Bhavik Mehta <bhavikmehta8@gmail.com>+--+-- Multiplicative groups of integers modulo m.+--++{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UnboxedTuples #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++module Math.NumberTheory.Moduli.Internal+  ( isPrimitiveRoot'+  , discreteLogarithmPP+  ) where++import qualified Data.Map as M+import Data.Maybe+import Data.Mod+import Data.Proxy+import GHC.TypeNats (SomeNat(..), someNatVal)+import GHC.Num.Integer+import Numeric.Natural++import Math.NumberTheory.Moduli.Chinese+import Math.NumberTheory.Moduli.Equations+import Math.NumberTheory.Moduli.Singleton+import Math.NumberTheory.Primes+import Math.NumberTheory.Roots+import Math.NumberTheory.Utils.FromIntegral++-- https://en.wikipedia.org/wiki/Primitive_root_modulo_n#Finding_primitive_roots+isPrimitiveRoot'+  :: (Integral a, UniqueFactorisation a)+  => CyclicGroup a m+  -> a+  -> Bool+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+    oddPrimePowerTest p 1 g       = oddPrimeTest p (g `mod` p)+    oddPrimePowerTest p _ g       = oddPrimeTest p (g `mod` p) && case someNatVal (fromIntegral' (p * p)) of+      SomeNat (_ :: Proxy pp) -> fromIntegral g ^ (p - 1) /= (1 :: Mod pp)++    doubleOddPrimePowerTest p k g = odd g && oddPrimePowerTest p k g++    oddPrimeTest p g = g /= 0 && gcd g p == 1 && case someNatVal (fromIntegral' p) of+      SomeNat (_ :: Proxy p) -> all (\x -> fromIntegral g ^ x /= (1 :: Mod p)) pows+      where+        pows = map (\(q, _) -> (p - 1) `quot` unPrime q) (factorise (p - 1))++-- 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 $ if result < 0 then result + pkMinusPk1 else 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          = (toInteger t * thetaB) `rem` pkMinusOne+      where+        (# t | #) = integerRecipMod# thetaA (fromInteger pkMinusOne)+    (result, pkMinusPk1) = fromJust $ chinese (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    = (toInteger t  - 1) `rem` p2kMinusOne+      where+        (# t | #) = integerPowMod# a (pk - pkMinusOne) (fromInteger 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 = intToNatural $ discreteLogarithmPrimeBSGS (fromInteger p) (fromInteger a) (fromInteger b)+  | otherwise     = discreteLogarithmPrimePollard p a b++discreteLogarithmPrimeBSGS :: Int -> Int -> Int -> Int+discreteLogarithmPrimeBSGS p a b =+  case [i*m + j | (v,i) <- zip giants [0..m-1], j <- maybeToList (M.lookup v table)] of+    [] -> error ("discreteLogarithmPrimeBSGS: failed, please report this as a bug. Inputs: " ++ show [p,a,b])+    hd : _ -> hd+  where+    m :: Int+    m        = integerSquareRoot (p - 2) + 1 -- simple way of ceiling (sqrt (p-1))++    babies :: [Int]+    babies   = iterate (.* a) 1++    table :: M.Map Int Int+    table    = M.fromList (zip babies [0..m-1])++    aInv :: Integer+    aInv     = fromIntegral ap+      where+        (# ap | #) = integerRecipMod# (toInteger a) (fromIntegral p)++    bigGiant :: Int+    bigGiant = fromIntegral aInvmp+      where+        (# aInvmp | #) = integerPowMod# aInv (toInteger m) (fromIntegral p)++    giants :: [Int]+    giants   = iterate (.* bigGiant) b++    (.*) :: Int -> Int -> Int+    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)  = (toInteger axn * toInteger byn `rem` n, x, y)+      where+        (# axn | #) = integerPowMod# a x (fromInteger n)+        (# byn | #) = integerPowMod# b y (fromInteger n)+    begin t           = go (step t) (step (step t))+    check t           = case integerPowMod# a t (fromInteger p) of+      (# atp | #) -> toInteger atp == b+      (# | _ #) -> False+    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 (toInteger . unMod) $ solveLinear (fromInteger (bi - b2i) :: Mod n) (fromInteger (ai - a2i))+      | xi == x2i                           = []+      | otherwise                           = go (step tort) (step (step hare))+    runPollard        = filter check . begin . initialise
− Math/NumberTheory/Moduli/Jacobi.hs 
@@ -1,150 +0,0 @@--- |--- Module:      Math.NumberTheory.Moduli.Jacobi--- Copyright:   (c) 2011 Daniel Fischer, 2017 Andrew Lelechenko--- Licence:     MIT--- Maintainer:  Andrew Lelechenko <andrew.lelechenko@gmail.com>--- Stability:   Provisional--- Portability: Non-portable (GHC extensions)------ Jacobi symbol.-----{-# LANGUAGE CPP        #-}-{-# LANGUAGE LambdaCase #-}--module Math.NumberTheory.Moduli.Jacobi-  ( JacobiSymbol(..)-  , jacobi-  , jacobi'-  ) where--import Data.Array.Unboxed-import Data.Bits-import Data.Semigroup-#if __GLASGOW_HASKELL__ < 709-import Data.Word-#endif--import Math.NumberTheory.Unsafe-import Math.NumberTheory.Utils---- | Type for result of 'jacobi'.-data JacobiSymbol = MinusOne | Zero | One-  deriving (Eq, Ord, Show)--instance Semigroup JacobiSymbol where-  (<>) = \case-    MinusOne -> negJS-    Zero     -> const Zero-    One      -> id--instance Monoid JacobiSymbol where-  mempty = One-  mappend = (<>)--negJS :: JacobiSymbol -> JacobiSymbol-negJS = \case-  MinusOne -> One-  Zero     -> Zero-  One      -> MinusOne---- | Jacobi symbol of two numbers.---   The \"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 &#177;1.-{-# SPECIALISE jacobi :: Integer -> Integer -> JacobiSymbol,-                         Int -> Int -> JacobiSymbol,-                         Word -> Word -> JacobiSymbol-  #-}-jacobi :: (Integral a, Bits a) => a -> a -> JacobiSymbol-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---- 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' 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---- 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---- 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---- 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--{-# SPECIALISE rem8 :: Integer -> Int,-                       Int -> Int,-                       Word -> Int-  #-}-rem8 :: Integral a => a -> Int-rem8 n = fromIntegral n .&. 7--jac2 :: UArray Int Int-jac2 = array (0,7) [(0,0),(1,1),(2,0),(3,-1),(4,0),(5,-1),(6,0),(7,1)]
+ Math/NumberTheory/Moduli/JacobiSymbol.hs view
@@ -0,0 +1,124 @@+-- |+-- Module:      Math.NumberTheory.Moduli.JacobiSymbol+-- Copyright:   (c) 2011 Daniel Fischer, 2017-2018 Andrew Lelechenko+-- Licence:     MIT+-- Maintainer:  Andrew Lelechenko <andrew.lelechenko@gmail.com>+-- Description: Deprecated+--+-- <https://en.wikipedia.org/wiki/Jacobi_symbol Jacobi symbol>+-- is a generalization of the Legendre symbol, useful for primality+-- testing and integer factorization.+--++{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE LambdaCase   #-}++module Math.NumberTheory.Moduli.JacobiSymbol+  ( JacobiSymbol(..)+  , jacobi+  , symbolToNum+  ) where++import Data.Bits+import Numeric.Natural++import Math.NumberTheory.Utils++-- | Represents three possible values of+-- <https://en.wikipedia.org/wiki/Jacobi_symbol Jacobi symbol>.+data JacobiSymbol = MinusOne | Zero | One+  deriving (Eq, Ord, Show)++instance Semigroup JacobiSymbol where+  (<>) = \case+    MinusOne -> negJS+    Zero     -> const Zero+    One      -> id++negJS :: JacobiSymbol -> JacobiSymbol+negJS = \case+  MinusOne -> One+  Zero     -> Zero+  One      -> MinusOne++-- | Convenience function to convert out of a Jacobi symbol+symbolToNum :: Num a => JacobiSymbol -> a+symbolToNum = \case+  Zero -> 0+  One -> 1+  MinusOne -> -1++{-# SPECIALISE symbolToNum :: JacobiSymbol -> Integer #-}+{-# SPECIALISE symbolToNum :: JacobiSymbol -> Int #-}+{-# SPECIALISE symbolToNum :: JacobiSymbol -> Word #-}+{-# SPECIALISE symbolToNum :: JacobiSymbol -> Natural #-}++-- | <https://en.wikipedia.org/wiki/Jacobi_symbol Jacobi symbol> of two arguments.+-- The lower argument (\"denominator\") must be odd and positive,+-- this condition is checked.+--+-- If arguments have a common factor, the result+-- is 'Zero', otherwise it is 'MinusOne' or 'One'.+--+-- >>> jacobi 1001 9911 -- arguments have a common factor 11+-- Zero+-- >>> jacobi 1001 9907+-- MinusOne+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"+  | otherwise = jacobi' a b   -- b odd, > 1++{-# SPECIALISE jacobi :: Integer -> Integer -> JacobiSymbol #-}+{-# SPECIALISE jacobi :: Natural -> Natural -> JacobiSymbol #-}+{-# SPECIALISE jacobi :: Int -> Int -> JacobiSymbol #-}+{-# SPECIALISE jacobi :: Word -> Word -> JacobiSymbol #-}++jacobi' :: (Integral a, Bits a) => a -> a -> JacobiSymbol+jacobi' 0 _ = Zero+jacobi' 1 _ = One+jacobi' a b+  | 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++-- numerator positive and smaller than denominator+jacPS :: (Integral a, Bits a) => JacobiSymbol -> a -> a -> JacobiSymbol+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+jacOL :: (Integral a, Bits a) => JacobiSymbol -> a -> a -> JacobiSymbol+jacOL !acc _ 1 = acc+jacOL !acc a b = case a `rem` b of+  0 -> Zero+  r -> jacPS acc r b++-- Utilities++-- Sadly, GHC do not optimise `Prelude.even` to a bit test automatically.+evenI :: Bits a => a -> Bool+evenI n = not (n `testBit` 0)++-- For an odd input @n@ test whether n `rem` 4 == 1+rem4is3 :: Bits a => a -> Bool+rem4is3 n = n `testBit` 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
+ Math/NumberTheory/Moduli/Multiplicative.hs view
@@ -0,0 +1,119 @@+-- |+-- Module:      Math.NumberTheory.Moduli.Multiplicative+-- Copyright:   (c) 2017 Andrew Lelechenko+-- Licence:     MIT+-- Maintainer:  Andrew Lelechenko <andrew.lelechenko@gmail.com>+--+-- Multiplicative groups of integers modulo m.+--++{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-}++module Math.NumberTheory.Moduli.Multiplicative+  ( -- * Multiplicative group+    MultMod+  , multElement+  , isMultElement+  , invertGroup+  -- * Primitive roots+  , PrimitiveRoot+  , unPrimitiveRoot+  , isPrimitiveRoot+  , discreteLogarithm+  ) where++import Control.Monad+import Data.Constraint+import Data.Mod+import Data.Semigroup+import GHC.TypeNats (KnownNat, natVal)+import Numeric.Natural++import Math.NumberTheory.Moduli.Internal+import Math.NumberTheory.Moduli.Singleton+import Math.NumberTheory.Primes++-- | This type represents elements of the multiplicative group mod m, i.e.+-- those elements which are coprime to m. Use @isMultElement@ to construct.+newtype MultMod m = MultMod {+  multElement :: Mod m -- ^ Unwrap a residue.+  } 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 (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++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 unMod a `gcd` natVal 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"++-- | 'PrimitiveRoot' m is a type which is only inhabited+-- by <https://en.wikipedia.org/wiki/Primitive_root_modulo_n primitive roots> of m.+newtype PrimitiveRoot m = PrimitiveRoot+  { unPrimitiveRoot :: MultMod m -- ^ Extract primitive root value.+  }+  deriving (Eq, Show)++-- | Check whether a given modular residue is+-- a <https://en.wikipedia.org/wiki/Primitive_root_modulo_n primitive root>.+--+-- >>> :set -XDataKinds+-- >>> import Data.Maybe+-- >>> isPrimitiveRoot (fromJust cyclicGroup) (1 :: Mod 13)+-- Nothing+-- >>> isPrimitiveRoot (fromJust cyclicGroup) (2 :: Mod 13)+-- Just (PrimitiveRoot {unPrimitiveRoot = MultMod {multElement = (2 `modulo` 13)}})+isPrimitiveRoot+  :: (Integral a, UniqueFactorisation a)+  => CyclicGroup a m+  -> Mod m+  -> Maybe (PrimitiveRoot m)+isPrimitiveRoot cg r = case proofFromCyclicGroup cg of+  Sub Dict -> do+    r' <- isMultElement r+    guard $ isPrimitiveRoot' cg (fromIntegral (unMod r))+    return $ PrimitiveRoot r'++-- | Computes the discrete logarithm. Currently uses a combination of the baby-step+-- giant-step method and Pollard's rho algorithm, with Bach reduction.+--+-- >>> :set -XDataKinds+-- >>> import Data.Maybe+-- >>> let cg = fromJust cyclicGroup :: CyclicGroup Integer 13+-- >>> let rt = fromJust (isPrimitiveRoot cg 2)+-- >>> let x  = fromJust (isMultElement 11)+-- >>> discreteLogarithm cg rt x+-- 7+discreteLogarithm :: CyclicGroup Integer m -> PrimitiveRoot m -> MultMod m -> Natural+discreteLogarithm cg (multElement . unPrimitiveRoot -> a) (multElement -> b) = case cg of+  CG2+    -> 0+    -- the only valid input was a=1, b=1+  CG4+    -> if unMod 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 (toInteger (unMod a)) (toInteger (unMod b))+  CGDoubleOddPrimePower (unPrime -> p) k+    -> discreteLogarithmPP p k (toInteger (unMod a) `rem` p^k) (toInteger (unMod b) `rem` p^k)+    -- we have the isomorphism t -> t `rem` p^k from (Z/2p^kZ)* -> (Z/p^kZ)*
+ Math/NumberTheory/Moduli/Singleton.hs view
@@ -0,0 +1,315 @@+-- |+-- Module:      Math.NumberTheory.Moduli.Singleton+-- Copyright:   (c) 2019 Andrew Lelechenko+-- Licence:     MIT+-- Maintainer:  Andrew Lelechenko <andrew.lelechenko@gmail.com>+--+-- Singleton data types.+--++{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE DeriveGeneric       #-}+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE LambdaCase          #-}+{-# LANGUAGE PatternSynonyms     #-}+{-# LANGUAGE PolyKinds           #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections       #-}+{-# LANGUAGE TypeOperators       #-}+{-# LANGUAGE ViewPatterns        #-}+{-# OPTIONS_GHC -Wno-unrecognised-warning-flags -Wno-pattern-namespace-specifier #-}++module Math.NumberTheory.Moduli.Singleton+  ( -- * SFactors singleton+    SFactors+  , sfactors+  , someSFactors+  , unSFactors+  , proofFromSFactors+    -- * CyclicGroup singleton+  , CyclicGroup+  , cyclicGroup+  , cyclicGroupFromFactors+  , cyclicGroupFromModulo+  , proofFromCyclicGroup+  , pattern CG2+  , pattern CG4+  , pattern CGOddPrimePower+  , pattern CGDoubleOddPrimePower+    -- * SFactors \<=\> CyclicGroup+  , cyclicGroupToSFactors+  , sfactorsToCyclicGroup+    -- * Some wrapper+  , Some(..)+  ) where++import Control.DeepSeq+import Data.Constraint+import Data.Kind+import Data.List (sort)+import qualified Data.Map as M+import Data.Proxy+import GHC.Generics+import GHC.TypeNats (KnownNat, Nat, natVal)+import Numeric.Natural+import Unsafe.Coerce++import Math.NumberTheory.Roots (highestPower)+import Math.NumberTheory.Primes+import Math.NumberTheory.Primes.Types+import Math.NumberTheory.Utils.FromIntegral++-- | Wrapper to hide an unknown type-level natural.+data Some (a :: Nat -> Type) where+  Some :: a m -> Some a++-- | From "Data.Constraint.Nat".+newtype Magic n = Magic (KnownNat n => Dict (KnownNat n))++-- | This singleton data type establishes a correspondence+-- between a modulo @m@ on type level+-- and its factorisation on term level.+newtype SFactors a (m :: Nat) = SFactors+  { unSFactors :: [(Prime a, Word)]+  -- ^ Factors of @m@.+  } deriving (Show, Generic)++instance Eq (SFactors a m) where+  _ == _ = True++instance Ord (SFactors a m) where+  _ `compare` _ = EQ++instance NFData a => NFData (SFactors a m)++instance Ord a => Eq (Some (SFactors a)) where+  Some (SFactors xs) == Some (SFactors ys) =+    xs == ys++instance Ord a => Ord (Some (SFactors a)) where+  Some (SFactors xs) `compare` Some (SFactors ys) =+    xs `compare` ys++instance Show a => Show (Some (SFactors a)) where+  showsPrec p (Some x) = showsPrec p x++instance NFData a => NFData (Some (SFactors a)) where+  rnf (Some x) = rnf x++-- | Create a singleton from a type-level positive modulo @m@,+-- passed in a constraint.+--+-- >>> :set -XDataKinds+-- >>> sfactors :: SFactors Integer 13+-- SFactors {unSFactors = [(Prime 13,1)]}+sfactors :: forall a m. (Ord a, UniqueFactorisation a, KnownNat m) => SFactors a m+sfactors = if m == 0+  then error "sfactors: modulo must be positive"+  else SFactors (sort (factorise m))+  where+    m = fromIntegral (natVal (Proxy :: Proxy m))++-- | Create a singleton from factors of @m@.+-- Factors must be distinct, as in output of 'factorise'.+--+-- >>> import Math.NumberTheory.Primes+-- >>> someSFactors (factorise 98)+-- SFactors {unSFactors = [(Prime 2,1),(Prime 7,2)]}+someSFactors :: (Ord a, Num a) => [(Prime a, Word)] -> Some (SFactors a)+someSFactors+  = Some+  . SFactors+  -- Just a precaution against ill-formed lists of factors+  . M.assocs+  . M.fromListWith (+)++-- | Convert a singleton to a proof that @m@ is known. Usage example:+--+-- > toModulo :: SFactors Integer m -> Natural+-- > toModulo t = case proofFromSFactors t of Sub Dict -> natVal t+proofFromSFactors :: Integral a => SFactors a m -> (() :- KnownNat m)+proofFromSFactors (SFactors fs) = Sub $ unsafeCoerce (Magic Dict) (fromIntegral' (factorBack fs) :: Natural)++-- | This singleton data type establishes a correspondence+-- between a modulo @m@ on type level+-- and a cyclic group of the same order on term level.+data CyclicGroup a (m :: Nat)+  = CG2' -- ^ Residues modulo 2.+  | CG4' -- ^ Residues modulo 4.+  | CGOddPrimePower'       (Prime a) Word+  -- ^ Residues modulo @p@^@k@ for __odd__ prime @p@.+  | CGDoubleOddPrimePower' (Prime a) Word+  -- ^ Residues modulo 2@p@^@k@ for __odd__ prime @p@.+  deriving (Show, Generic)++instance Eq (CyclicGroup a m) where+  _ == _ = True++instance Ord (CyclicGroup a m) where+  _ `compare` _ = EQ++instance NFData a => NFData (CyclicGroup a m)++instance Eq a => Eq (Some (CyclicGroup a)) where+  Some CG2' == Some CG2' = True+  Some CG4' == Some CG4' = True+  Some (CGOddPrimePower' p1 k1) == Some (CGOddPrimePower' p2 k2) =+    p1 == p2 && k1 == k2+  Some (CGDoubleOddPrimePower' p1 k1) == Some (CGDoubleOddPrimePower' p2 k2) =+    p1 == p2 && k1 == k2+  _ == _ = False++instance Ord a => Ord (Some (CyclicGroup a)) where+  compare (Some x) (Some y) = case x of+    CG2' -> case y of+      CG2' -> EQ+      _    -> LT+    CG4' -> case y of+      CG2' -> GT+      CG4' -> EQ+      _    -> LT+    CGOddPrimePower' p1 k1 -> case y of+      CGDoubleOddPrimePower'{} -> LT+      CGOddPrimePower' p2 k2 ->+        p1 `compare` p2 <> k1 `compare` k2+      _ -> GT+    CGDoubleOddPrimePower' p1 k1 -> case y of+      CGDoubleOddPrimePower' p2 k2 ->+        p1 `compare` p2 <> k1 `compare` k2+      _ -> GT++instance Show a => Show (Some (CyclicGroup a)) where+  showsPrec p (Some x) = showsPrec p x++instance NFData a => NFData (Some (CyclicGroup a)) where+  rnf (Some x) = rnf x++-- | Create a singleton from a type-level positive modulo @m@,+-- passed in a constraint.+--+-- >>> :set -XDataKinds+-- >>> import Data.Maybe+-- >>> cyclicGroup :: Maybe (CyclicGroup Integer 169)+-- Just (CGOddPrimePower' (Prime 13) 2)+--+-- >>> :set -XTypeOperators -XNoStarIsType+-- >>> import GHC.TypeNats+-- >>> sfactorsToCyclicGroup (sfactors :: SFactors Integer 4)+-- Just CG4'+-- >>> sfactorsToCyclicGroup (sfactors :: SFactors Integer (2 * 13 ^ 3))+-- Just (CGDoubleOddPrimePower' (Prime 13) 3)+-- >>> sfactorsToCyclicGroup (sfactors :: SFactors Integer  (4 * 13))+-- Nothing+cyclicGroup+  :: forall a m.+     (Integral a, UniqueFactorisation a, KnownNat m)+  => Maybe (CyclicGroup a m)+cyclicGroup = fromModuloInternal m+  where+    m = fromIntegral (natVal (Proxy :: Proxy m))++-- | Create a singleton from factors.+-- Factors must be distinct, as in output of 'factorise'.+cyclicGroupFromFactors+  :: (Eq a, Num a)+  => [(Prime a, Word)]+  -> Maybe (Some (CyclicGroup a))+cyclicGroupFromFactors = \case+  [(unPrime -> 2, 1)] -> Just $ Some CG2'+  [(unPrime -> 2, 2)] -> Just $ Some CG4'+  [(unPrime -> 2, _)] -> Nothing+  [(p, k)] -> Just $ Some $ CGOddPrimePower' p k+  [(unPrime -> 2, 1), (p, k)] -> Just $ Some $ CGDoubleOddPrimePower' p k+  [(p, k), (unPrime -> 2, 1)] -> Just $ Some $ CGDoubleOddPrimePower' p k+  _ -> Nothing++-- | Similar to 'cyclicGroupFromFactors' . 'factorise',+-- but much faster, because it+-- but performs only one primality test instead of full+-- factorisation.+cyclicGroupFromModulo+  :: (Integral a, UniqueFactorisation a)+  => a+  -> Maybe (Some (CyclicGroup a))+cyclicGroupFromModulo = fmap Some . fromModuloInternal++fromModuloInternal+  :: (Integral a, UniqueFactorisation a)+  => a+  -> Maybe (CyclicGroup a m)+fromModuloInternal = \case+  2 -> Just CG2'+  4 -> Just CG4'+  n+    | even n -> uncurry CGDoubleOddPrimePower' <$> isOddPrimePower (n `div` 2)+    | otherwise -> uncurry CGOddPrimePower' <$> isOddPrimePower n++isOddPrimePower+  :: (Integral a, UniqueFactorisation a)+  => a+  -> Maybe (Prime a, Word)+isOddPrimePower n+  | even n    = Nothing+  | otherwise = (, k) <$> isPrime p+  where+    (p, k) = highestPower n++-- | Convert a cyclic group to a proof that @m@ is known. Usage example:+--+-- > toModulo :: CyclicGroup Integer m -> Natural+-- > toModulo t = case proofFromCyclicGroup t of Sub Dict -> natVal t+proofFromCyclicGroup :: Integral a => CyclicGroup a m -> (() :- KnownNat m)+proofFromCyclicGroup = proofFromSFactors . cyclicGroupToSFactors++-- | Check whether a multiplicative group of residues,+-- characterized by its modulo, is cyclic and, if yes, return its form.+--+-- >>> :set -XTypeOperators -XNoStarIsType+-- >>> import GHC.TypeNats+-- >>> sfactorsToCyclicGroup (sfactors :: SFactors Integer 4)+-- Just CG4'+-- >>> sfactorsToCyclicGroup (sfactors :: SFactors Integer (2 * 13 ^ 3))+-- Just (CGDoubleOddPrimePower' (Prime 13) 3)+-- >>> sfactorsToCyclicGroup (sfactors :: SFactors Integer  (4 * 13))+-- Nothing+sfactorsToCyclicGroup :: (Eq a, Num a) => SFactors a m -> Maybe (CyclicGroup a m)+sfactorsToCyclicGroup (SFactors fs) = case fs of+  [(unPrime -> 2, 1)]         -> Just CG2'+  [(unPrime -> 2, 2)]         -> Just CG4'+  [(unPrime -> 2, _)]         -> Nothing+  [(p, k)]                    -> Just $ CGOddPrimePower' p k+  [(p, k), (unPrime -> 2, 1)] -> Just $ CGDoubleOddPrimePower' p k+  [(unPrime -> 2, 1), (p, k)] -> Just $ CGDoubleOddPrimePower' p k+  _ -> Nothing++-- | Invert 'sfactorsToCyclicGroup'.+--+-- >>> import Data.Maybe+-- >>> cyclicGroupToSFactors (fromJust (sfactorsToCyclicGroup (sfactors :: SFactors Integer 4)))+-- SFactors {unSFactors = [(Prime 2,2)]}+cyclicGroupToSFactors :: Num a => CyclicGroup a m -> SFactors a m+cyclicGroupToSFactors = SFactors . \case+  CG2' -> [(Prime 2, 1)]+  CG4' -> [(Prime 2, 2)]+  CGOddPrimePower' p k -> [(p, k)]+  CGDoubleOddPrimePower' p k -> [(Prime 2, 1), (p, k)]++-- | Unidirectional pattern for residues modulo 2.+pattern CG2 :: CyclicGroup a m+pattern CG2 <- CG2'++-- | Unidirectional pattern for residues modulo 4.+pattern CG4 :: CyclicGroup a m+pattern CG4 <- CG4'++-- | Unidirectional pattern for residues modulo @p@^@k@ for __odd__ prime @p@.+pattern CGOddPrimePower :: Prime a -> Word -> CyclicGroup a m+pattern CGOddPrimePower p k <- CGOddPrimePower' p k++-- | Unidirectional pattern for residues modulo 2@p@^@k@ for __odd__ prime @p@.+pattern CGDoubleOddPrimePower :: Prime a -> Word -> CyclicGroup a m+pattern CGDoubleOddPrimePower p k <- CGDoubleOddPrimePower' p k++{-# COMPLETE CG2, CG4, CGOddPrimePower, CGDoubleOddPrimePower #-}
+ Math/NumberTheory/Moduli/SomeMod.hs view
@@ -0,0 +1,198 @@+-- |+-- Module:      Math.NumberTheory.Moduli.SomeMod+-- Copyright:   (c) 2017 Andrew Lelechenko+-- Licence:     MIT+-- Maintainer:  Andrew Lelechenko <andrew.lelechenko@gmail.com>+--+-- Safe modular arithmetic with modulo on type level.+--++{-# LANGUAGE GADTs               #-}+{-# LANGUAGE LambdaCase          #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Math.NumberTheory.Moduli.SomeMod+  ( SomeMod(..)+  , modulo+  , invertSomeMod+  , powSomeMod+  ) where++import Data.Euclidean (GcdDomain(..), Euclidean(..), Field)+import Data.Mod (Mod, unMod, invertMod, (^%))+import Data.Proxy+import Data.Semiring (Semiring(..), Ring(..))+import Data.Type.Equality+import GHC.TypeNats (KnownNat, SomeNat(..), sameNat, natVal, someNatVal)+import Numeric.Natural++-- | 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)+-- >>> import Data.Ratio+-- >>> 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.,+--+-- > case modulo n m of+-- >   SomeMod k -> process k -- Here k has type Mod m+-- >   InfMod{}  -> error "impossible"+data SomeMod where+  SomeMod :: KnownNat m => Mod m -> SomeMod+  InfMod  :: Rational -> SomeMod++instance Eq SomeMod where+  SomeMod mx == SomeMod my =+    natVal mx == natVal my && unMod mx == unMod my+  InfMod rx  == InfMod ry  = rx == ry+  _          == _          = False++instance Ord SomeMod where+  SomeMod mx `compare` SomeMod my =+    natVal mx `compare` natVal my <> unMod mx `compare` unMod my+  SomeMod{} `compare` InfMod{} = LT+  InfMod{} `compare` SomeMod{} = GT+  InfMod rx `compare` InfMod ry = rx `compare` ry++instance Show SomeMod where+  show = \case+    SomeMod m -> show m+    InfMod  r -> show r++-- | Create modular value by representative of residue class and modulo.+-- One can use the result either directly (via functions from 'Num' and 'Fractional'),+-- or deconstruct it by pattern matching. Note that 'modulo' never returns 'InfMod'.+modulo :: Integer -> Natural -> SomeMod+modulo n m = case someNatVal m of+  SomeNat (_ :: Proxy t) -> SomeMod (fromInteger n :: Mod t)+{-# INLINABLE modulo #-}+infixl 7 `modulo`++liftUnOp+  :: (forall k. KnownNat k => Mod k -> Mod k)+  -> (Rational -> Rational)+  -> SomeMod+  -> SomeMod+liftUnOp fm fr = \case+  SomeMod m -> SomeMod (fm m)+  InfMod  r -> InfMod  (fr r)+{-# INLINEABLE liftUnOp #-}++liftBinOpMod+  :: (KnownNat m, KnownNat n)+  => (forall k. KnownNat k => Mod k -> Mod k -> Mod k)+  -> Mod m+  -> Mod n+  -> SomeMod+liftBinOpMod f mx my = case someNatVal m of+  SomeNat (_ :: Proxy t) ->+    SomeMod (fromIntegral (x `mod` m) `f` fromIntegral (y `mod` m) :: Mod t)+  where+    x = unMod mx+    y = unMod my+    m = natVal mx `Prelude.gcd` natVal my++liftBinOp+  :: (forall k. KnownNat k => Mod k -> Mod k -> Mod k)+  -> (Rational -> Rational -> Rational)+  -> SomeMod+  -> SomeMod+  -> SomeMod+liftBinOp _ fr (InfMod rx)  (InfMod ry)  = InfMod  (rx `fr` ry)+liftBinOp fm _ (InfMod rx)  (SomeMod my) = SomeMod (fromRational rx `fm` my)+liftBinOp fm _ (SomeMod mx) (InfMod ry)  = SomeMod (mx `fm` fromRational ry)+liftBinOp fm _ (SomeMod (mx :: Mod m)) (SomeMod (my :: Mod n))+  = case (Proxy :: Proxy m) `sameNat` (Proxy :: Proxy n) of+    Nothing   -> liftBinOpMod fm mx my+    Just Refl -> SomeMod (mx `fm` my)++instance Num SomeMod where+  (+)    = liftBinOp (+) (+)+  (-)    = liftBinOp (-) (-)+  negate = liftUnOp Prelude.negate Prelude.negate+  {-# INLINE negate #-}+  (*)    = liftBinOp (*) (*)+  abs    = id+  {-# INLINE abs #-}+  signum = const 1+  {-# INLINE signum #-}+  fromInteger = InfMod . fromInteger+  {-# INLINE fromInteger #-}++instance Semiring SomeMod where+  plus  = (+)+  times = (*)+  zero  = InfMod 0+  one   = InfMod 1+  fromNatural = fromIntegral++instance Ring SomeMod where+  negate = Prelude.negate++-- | Beware that division by residue, which is not coprime with the modulo,+-- will result in runtime error. Consider using 'invertSomeMod' instead.+instance Fractional SomeMod where+  fromRational = InfMod+  {-# INLINE fromRational #-}+  recip x = case invertSomeMod x of+    Nothing -> error "recip{SomeMod}: residue is not coprime with modulo"+    Just y  -> y++-- | See the warning about division above.+instance GcdDomain SomeMod where+  divide x y = Just (x / y)+  gcd        = const $ const 1+  lcm        = const $ const 1+  coprime    = const $ const True++-- | See the warning about division above.+instance Euclidean SomeMod where+  degree      = const 0+  quotRem x y = (x / y, 0)+  quot        = (/)+  rem         = const $ const 0++-- | See the warning about division above.+instance Field SomeMod++-- | Computes the inverse value, if it exists.+--+-- >>> invertSomeMod (3 `modulo` 10) -- because 3 * 7 = 1 :: Mod 10+-- Just (7 `modulo` 10)+-- >>> invertSomeMod (4 `modulo` 10)+-- Nothing+-- >>> import Data.Ratio+-- >>> invertSomeMod (fromRational (2 % 5))+-- Just 5 % 2+invertSomeMod :: SomeMod -> Maybe SomeMod+invertSomeMod = \case+  SomeMod m -> fmap SomeMod (invertMod m)+  InfMod  r -> Just (InfMod (recip r))+{-# INLINABLE [1] invertSomeMod #-}++{-# SPECIALISE [1] powSomeMod :: SomeMod -> Integer -> SomeMod #-}+{-# SPECIALISE [1] powSomeMod :: SomeMod -> Natural -> SomeMod #-}+{-# SPECIALISE [1] powSomeMod :: SomeMod -> Int     -> SomeMod #-}+{-# SPECIALISE [1] powSomeMod :: SomeMod -> Word    -> SomeMod #-}++-- | Drop-in replacement for 'Prelude.^', with much better performance.+-- When -O is enabled, there is a rewrite rule, which specialises 'Prelude.^' to 'powSomeMod'.+--+-- >>> 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)+{-# INLINABLE [1] powSomeMod #-}++{-# RULES "^%SomeMod" forall x p. x ^ p = powSomeMod x p #-}
Math/NumberTheory/Moduli/Sqrt.hs view
@@ -3,142 +3,235 @@ -- Copyright:   (c) 2011 Daniel Fischer -- Licence:     MIT -- Maintainer:  Andrew Lelechenko <andrew.lelechenko@gmail.com>--- Stability:   Provisional--- Portability: Non-portable (GHC extensions) ----- Modular square roots.+-- Modular square roots and+-- <https://en.wikipedia.org/wiki/Jacobi_symbol Jacobi symbol>. --  {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP          #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE PostfixOperators #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ViewPatterns #-}  module Math.NumberTheory.Moduli.Sqrt-  ( sqrtModP-  , sqrtModPList-  , sqrtModP'-  , tonelliShanks-  , sqrtModPP-  , sqrtModPPList-  , sqrtModF-  , sqrtModFList+  ( -- * Modular square roots+    sqrtsMod+  , sqrtsModFactorisation+  , sqrtsModPrimePower+  , sqrtsModPrime+    -- * Jacobi symbol+  , JacobiSymbol(..)+  , jacobi+  , symbolToNum   ) 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 Data.Constraint+import Data.List.Infinite (Infinite(..), (...))+import qualified Data.List.Infinite as Inf+import Data.Maybe+import Data.Mod+import Data.Proxy+import GHC.TypeNats (KnownNat, SomeNat(..), natVal, someNatVal, Nat)+import Numeric.Natural (Natural)  import Math.NumberTheory.Moduli.Chinese-import Math.NumberTheory.Moduli.Jacobi-import Math.NumberTheory.Primes.Sieve (sieveFrom)+import Math.NumberTheory.Moduli.JacobiSymbol+import Math.NumberTheory.Moduli.Singleton+import Math.NumberTheory.Primes import Math.NumberTheory.Utils (shiftToOddCount, splitOff)+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.+-- | 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 sfactors (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 :: SFactors Integer m -> Mod m -> [Mod m]+sqrtsMod sm a = case proofFromSFactors sm of+  Sub Dict -> map fromInteger $ sqrtsModFactorisation (toInteger (unMod a)) (unSFactors sm) --- | @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, the factorisation of which 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 (\(p, pow) -> unPrime p ^ pow) pps +    rs :: [[Integer]]+    rs = map (uncurry (sqrtsModPrimePower n)) pps++    cs :: [[(Integer, Integer)]]+    cs = zipWith (\l m -> map (, m) l) rs ms++    comb t1 t2 = (if ch < 0 then ch + m else ch, m)+      where+        (ch, m) = fromJust $ chinese t1 t2++-- | List all square roots modulo the power of a prime.+--+-- >>> import Data.Maybe+-- >>> import Math.NumberTheory.Primes+-- >>> 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 (unPrime -> 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 = 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.+--+-- >>> import Data.Maybe+-- >>> import Math.NumberTheory.Primes+-- >>> 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 (unPrime -> 2) = [n `mod` 2]+sqrtsModPrime n (unPrime -> prime) = case jacobi n prime of+  MinusOne -> []+  Zero     -> [0]+  One      -> case someNatVal (fromInteger prime) of+    SomeNat (_ :: Proxy p) -> let r = toInteger (unMod (sqrtModP' @p (fromInteger n))) 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-    | otherwise     = tonelliShanks square prime+sqrtModP' :: KnownNat p => Mod p -> Mod p+sqrtModP' square+  | prime == 2         = square+  | rem4 prime == 3    = square ^ ((prime + 1) `quot` 4)+  | square == maxBound = sqrtOfMinusOne+  | otherwise          = tonelliShanks square+  where+    prime = natVal square +-- | @p@ must be of form @4k + 1@+sqrtOfMinusOne :: forall (p :: Nat). KnownNat p => Mod p+sqrtOfMinusOne = case results of+  [] -> error "sqrtOfMinusOne: internal invariant violated"+  hd : _ -> hd+  where+    p :: Natural+    p = natVal (Proxy :: Proxy p)++    k :: Natural+    k = (p - 1) `quot` 4++    results :: [Mod p]+    results = dropWhile (\n -> n == 1 || n == maxBound) $+      map (^ k) [2 .. maxBound - 1]+ -- | @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+tonelliShanks :: forall p. KnownNat p => Mod p -> Mod p+tonelliShanks square = 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+    prime = natVal square+    (log2, q) = shiftToOddCount (prime - 1)+    generator = findNonSquare ^ q+    rc = square ^ ((q + 1) `quot` 2)+    t1 = square ^ q+     msquare 0 x = x-    msquare k x = msquare (k-1) (msqr x)+    msquare k x = msquare (k-1) (x * x)+     findPeriod per 1 = per-    findPeriod per x = findPeriod (per+1) (msqr x)+    findPeriod per x = findPeriod (per + 1) (x * x)++    loop :: Mod p -> Mod p -> Mod p -> Word -> Mod p     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+            nextR = r * b+            nextC = b * b+            nextT = t * nextC --- | @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 jacobi n prime of+  MinusOne -> Nothing+  Zero     -> Nothing+  One      -> case someNatVal (fromInteger prime) of+    SomeNat (_ :: Proxy p) -> Just $ fixup $ sqrtModP' @p (fromInteger n)   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)+    fixup :: KnownNat p => Mod p -> Integer+    fixup r+      | diff' == 0 = r'+      | expo <= e  = r'+      | otherwise  = hoist (recip (2 * r)) r' (fromInteger q) (prime^e)+      where+        r' = toInteger (unMod r)+        diff' = r' * r' - n+        (e, q) = splitOff prime diff' +    hoist :: KnownNat p => Mod p -> Integer -> Mod p -> Integer -> Integer     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'+      | diff' == 0    = root'+      | expo <= ex    = root'+      | otherwise     = hoist inv root' (fromInteger nelim) (prime ^ ex)+        where+          root' = root + toInteger (unMod (inv * negate elim)) * pp+          diff' = root' * root' - n+          (ex, nelim) = splitOff prime diff'  -- dirty, dirty-sqM2P :: Integer -> Int -> Maybe Integer+sqM2P :: Integer -> Word -> 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+    | otherwise = (`mod` mdl) . (`shiftL` wordToInt k2) <$> solve s e2       where-        mdl = 1 `shiftL` e+        mdl = 1 `shiftL` wordToInt 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 _@@ -150,80 +243,31 @@                     | pw >= e2  = Just x                     | otherwise = fixup x' pw'                       where-                        x' = x + (1 `shiftL` (pw-1))+                        x' = x + (1 `shiftL` (wordToInt 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."+findNonSquare :: forall (n :: Nat). KnownNat n => Mod n+findNonSquare+  | rem8 n == 3 || rem8 n == 5 = 2+  | otherwise = fromIntegral $ Inf.head $+    Inf.dropWhile (\p -> jacobi p n /= MinusOne) candidates+  where+    n = natVal (Proxy :: Proxy n) -recipMod :: Integer -> Integer -> Maybe Integer-recipMod x m = case recipModInteger x m of-  0 -> Nothing-  y -> Just y+    -- It is enough to consider only prime candidates, but+    -- the probability that the smallest non-residue is > 67+    -- is small and 'jacobi' test is fast,+    -- so we use [71..n] instead of filter isPrime [71..n].+    candidates :: Infinite Natural+    candidates = 3 :< 5 :< 7 :< 11 :< 13 :< 17 :< 19 :< 23 :< 29 :< 31 :<+      37 :< 41 :< 43 :< 47 :< 53 :< 59 :< 61 :< 67 :< (71...)
Math/NumberTheory/MoebiusInversion.hs view
@@ -3,39 +3,51 @@ -- Copyright:   (c) 2012 Daniel Fischer -- Licence:     MIT -- Maintainer:  Daniel Fischer <daniel.is.fischer@googlemail.com>--- Stability:   Provisional--- Portability: Non-portable (GHC extensions) ----- Generalised Moebius inversion----{-# LANGUAGE BangPatterns, FlexibleContexts #-}+-- Generalised Möbius inversion++{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE ScopedTypeVariables #-}+ module Math.NumberTheory.MoebiusInversion     ( generalInversion     , totientSum     ) where -import Data.Array.ST import Control.Monad import Control.Monad.ST+import Data.Proxy+import qualified Data.Vector.Generic as G+import qualified Data.Vector.Generic.Mutable as MG -import Math.NumberTheory.Powers.Squares-import Math.NumberTheory.Unsafe+import Math.NumberTheory.Roots+import Math.NumberTheory.Utils.FromIntegral  -- | @totientSum n@ is, for @n > 0@, the sum of @[totient k | k <- [1 .. n]]@,---   computed via generalised Moebius inversion.+--   computed via generalised Möbius inversion. --   See <http://mathworld.wolfram.com/TotientSummatoryFunction.html> for the --   formula used for @totientSum@.-totientSum :: Int -> Integer-totientSum n-  | n < 1 = 0-  | otherwise = generalInversion (triangle . fromIntegral) n+--+-- >>> import Data.Proxy+-- >>> totientSum (Proxy :: Proxy Data.Vector.Unboxed.Vector) 100 :: Int+-- 3044+-- >>> totientSum (Proxy :: Proxy Data.Vector.Vector) 100 :: Integer+-- 3044+totientSum+    :: (Integral t, G.Vector v t)+    => Proxy v+    -> Word+    -> t+totientSum _ 0 = 0+totientSum proxy n = generalInversion proxy (triangle . fromIntegral) n   where-    triangle k = (k*(k+1)) `quot` 2+    triangle k = (k * (k + 1)) `quot` 2 --- | @generalInversion g n@ evaluates the generalised Moebius inversion of @g@+-- | @generalInversion g n@ evaluates the generalised Möbius inversion of @g@ --   at the argument @n@. -----   The generalised Moebius inversion implemented here allows an efficient+--   The generalised Möbius inversion implemented here allows an efficient --   calculation of isolated values of the function @f : N -> Z@ if the function --   @g@ defined by --@@ -43,15 +55,15 @@ -- > g n = sum [f (n `quot` k) | k <- [1 .. n]] -- > -----   can be cheaply computed. By the generalised Moebius inversion formula, then+--   can be cheaply computed. By the generalised Möbius inversion formula, then -- -- > -- > f n = sum [moebius k * g (n `quot` k) | k <- [1 .. n]] -- > -- --   which allows the computation in /O/(n) steps, if the values of the---   Moebius function are known. A slightly different formula, used here,---   does not need the values of the Moebius function and allows the+--   Möbius function are known. A slightly different formula, used here,+--   does not need the values of the Möbius function and allows the --   computation in /O/(n^0.75) steps, using /O/(n^0.5) memory. -- --   An example of a pair of such functions where the inversion allows a@@ -76,67 +88,84 @@ --   The value @f n@ is then computed by @generalInversion g n@. Note that when --   many values of @f@ are needed, there are far more efficient methods, this --   method is only appropriate to compute isolated values of @f@.-generalInversion :: (Int -> Integer) -> Int -> Integer-generalInversion fun n-    | n < 1     = error "Moebius inversion only defined on positive domain"-    | n == 1    = fun 1-    | n == 2    = fun 2 - fun 1-    | n == 3    = fun 3 - 2*fun 1-    | otherwise = fastInvert fun n+generalInversion+    :: (Num t, G.Vector v t)+    => Proxy v+    -> (Word -> t)+    -> Word+    -> t+generalInversion proxy fun n = case n of+    0 ->error "Möbius inversion only defined on positive domain"+    1 -> fun 1+    2 -> fun 2 - fun 1+    3 -> fun 3 - 2*fun 1+    _ -> runST (fastInvertST proxy (fun . intToWord) (wordToInt n)) -fastInvert :: (Int -> Integer) -> Int -> Integer-fastInvert fun n = big `unsafeAt` 0-  where-    !k0 = integerSquareRoot (n `quot` 2)-    !mk0 = n `quot` (2*k0+1)-    kmax a m = (a `quot` m - 1) `quot` 2-    big = runSTArray $ do-        small <- newArray_ (0,mk0) :: ST s (STArray s Int Integer)-        unsafeWrite small 0 0-        unsafeWrite small 1 $! (fun 1)-        when (mk0 >= 2) $-            unsafeWrite small 2 $! (fun 2 - fun 1)-        let calcit switch change i-                | mk0 < i   = return (switch,change)-                | i == change = calcit (switch+1) (change + 4*switch+6) i-                | otherwise = do-                    let mloop !acc k !m-                            | k < switch    = kloop acc k-                            | otherwise     = do-                                val <- unsafeRead small m-                                let nxtk = kmax i (m+1)-                                mloop (acc - fromIntegral (k-nxtk)*val) nxtk (m+1)-                        kloop !acc k-                            | k == 0    = do-                                unsafeWrite small i $! acc-                                calcit switch change (i+1)-                            | otherwise = do-                                val <- unsafeRead small (i `quot` (2*k+1))-                                kloop (acc-val) (k-1)-                    mloop (fun i - fun (i `quot` 2)) ((i-1) `quot` 2) 1-        (sw, ch) <- calcit 1 8 3-        large <- newArray_ (0,k0-1)-        let calcbig switch change j-                | j == 0    = return large-                | (2*j-1)*change <= n   = calcbig (switch+1) (change + 4*switch+6) j-                | otherwise = do-                    let i = n `quot` (2*j-1)-                        mloop !acc k m-                            | k < switch    = kloop acc k-                            | otherwise     = do-                                val <- unsafeRead small m-                                let nxtk = kmax i (m+1)-                                mloop (acc - fromIntegral (k-nxtk)*val) nxtk (m+1)-                        kloop !acc k-                            | k == 0    = do-                                unsafeWrite large (j-1) $! acc-                                calcbig switch change (j-1)-                            | otherwise = do-                                let m = i `quot` (2*k+1)-                                val <- if m <= mk0-                                         then unsafeRead small m-                                         else unsafeRead large (k*(2*j-1)+j-1)-                                kloop (acc-val) (k-1)-                    mloop (fun i - fun (i `quot` 2)) ((i-1) `quot` 2) 1-        calcbig sw ch k0+fastInvertST+    :: forall s t v.+       (Num t, G.Vector v t)+    => Proxy v+    -> (Int -> t)+    -> Int+    -> ST s t+fastInvertST _ fun n = do+    let !k0 = integerSquareRoot (n `quot` 2)+        !mk0 = n `quot` (2*k0+1)+        kmax a m = (a `quot` m - 1) `quot` 2++    small <- MG.unsafeNew (mk0 + 1) :: ST s (G.Mutable v s t)+    MG.unsafeWrite small 0 0+    MG.unsafeWrite small 1 $! fun 1+    when (mk0 >= 2) $+        MG.unsafeWrite small 2 $! (fun 2 - fun 1)++    let calcit :: Int -> Int -> Int -> ST s (Int, Int)+        calcit switch change i+            | mk0 < i   = return (switch,change)+            | i == change = calcit (switch+1) (change + 4*switch+6) i+            | otherwise = do+                let mloop !acc k !m+                        | k < switch    = kloop acc k+                        | otherwise     = do+                            val <- MG.unsafeRead small m+                            let nxtk = kmax i (m+1)+                            mloop (acc - fromIntegral (k-nxtk)*val) nxtk (m+1)+                    kloop !acc k+                        | k == 0    = do+                            MG.unsafeWrite small i $! acc+                            calcit switch change (i+1)+                        | otherwise = do+                            val <- MG.unsafeRead small (i `quot` (2*k+1))+                            kloop (acc-val) (k-1)+                mloop (fun i - fun (i `quot` 2)) ((i-1) `quot` 2) 1++    (sw, ch) <- calcit 1 8 3+    large <- MG.unsafeNew k0 :: ST s (G.Mutable v s t)++    let calcbig :: Int -> Int -> Int -> ST s (G.Mutable v s t)+        calcbig switch change j+            | j == 0    = return large+            | (2*j-1)*change <= n   = calcbig (switch+1) (change + 4*switch+6) j+            | otherwise = do+                let i = n `quot` (2*j-1)+                    mloop !acc k m+                        | k < switch    = kloop acc k+                        | otherwise     = do+                            val <- MG.unsafeRead small m+                            let nxtk = kmax i (m+1)+                            mloop (acc - fromIntegral (k-nxtk)*val) nxtk (m+1)+                    kloop !acc k+                        | k == 0    = do+                            MG.unsafeWrite large (j-1) $! acc+                            calcbig switch change (j-1)+                        | otherwise = do+                            let m = i `quot` (2*k+1)+                            val <- if m <= mk0+                                     then MG.unsafeRead small m+                                     else MG.unsafeRead large (k*(2*j-1)+j-1)+                            kloop (acc-val) (k-1)+                mloop (fun i - fun (i `quot` 2)) ((i-1) `quot` 2) 1++    mvec <- calcbig sw ch k0+    MG.unsafeRead mvec 0
− Math/NumberTheory/MoebiusInversion/Int.hs 
@@ -1,142 +0,0 @@--- |--- Module:      Math.NumberTheory.MoebiusInversion--- Copyright:   (c) 2012 Daniel Fischer--- Licence:     MIT--- Maintainer:  Daniel Fischer <daniel.is.fischer@googlemail.com>--- Stability:   Provisional--- Portability: Non-portable (GHC extensions)------ Generalised Moebius inversion for 'Int' valued functions.----{-# LANGUAGE BangPatterns, FlexibleContexts #-}-{-# OPTIONS_GHC -fspec-constr-count=8 #-}-module Math.NumberTheory.MoebiusInversion.Int-    ( generalInversion-    , totientSum-    ) where--import Data.Array.ST-import Control.Monad-import Control.Monad.ST--import Math.NumberTheory.Powers.Squares-import Math.NumberTheory.Unsafe---- | @totientSum n@ is, for @n > 0@, the sum of @[totient k | k <- [1 .. n]]@,---   computed via generalised Moebius inversion.---   See <http://mathworld.wolfram.com/TotientSummatoryFunction.html> for the---   formula used for @totientSum@.-totientSum :: Int -> Int-totientSum n-  | n < 1 = 0-  | otherwise = generalInversion (triangle . fromIntegral) n-  where-    triangle k = (k*(k+1)) `quot` 2---- | @generalInversion g n@ evaluates the generalised Moebius inversion of @g@---   at the argument @n@.------   The generalised Moebius inversion implemented here allows an efficient---   calculation of isolated values of the function @f : N -> Z@ if the function---   @g@ defined by------ >--- > g n = sum [f (n `quot` k) | k <- [1 .. n]]--- >------   can be cheaply computed. By the generalised Moebius inversion formula, then------ >--- > f n = sum [moebius k * g (n `quot` k) | k <- [1 .. n]]--- >------   which allows the computation in /O/(n) steps, if the values of the---   Moebius function are known. A slightly different formula, used here,---   does not need the values of the Moebius function and allows the---   computation in /O/(n^0.75) steps, using /O/(n^0.5) memory.------   An example of a pair of such functions where the inversion allows a---   more efficient computation than the direct approach is------ >--- > f n = number of reduced proper fractions with denominator <= n--- > g n = number of proper fractions with denominator <= n--- >------   (a /proper fraction/ is a fraction @0 < n/d < 1@). Then @f n@ is the---   cardinality of the Farey sequence of order @n@ (minus 1 or 2 if 0 and/or---   1 are included in the Farey sequence), or the sum of the totients of---   the numbers @2 <= k <= n@. @f n@ is not easily directly computable,---   but then @g n = n*(n-1)/2@ is very easy to compute, and hence the inversion---   gives an efficient method of computing @f n@.------   For 'Int' valued functions, unboxed arrays can be used for greater efficiency.---   That bears the risk of overflow, however, so be sure to use it only when it's---   safe.------   The value @f n@ is then computed by @generalInversion g n@. Note that when---   many values of @f@ are needed, there are far more efficient methods, this---   method is only appropriate to compute isolated values of @f@.-generalInversion :: (Int -> Int) -> Int -> Int-generalInversion fun n-    | n < 1     = error "Moebius inversion only defined on positive domain"-    | n == 1    = fun 1-    | n == 2    = fun 2 - fun 1-    | n == 3    = fun 3 - 2*fun 1-    | otherwise = fastInvert fun n--fastInvert :: (Int -> Int) -> Int -> Int-fastInvert fun n = big `unsafeAt` 0-  where-    !k0 = integerSquareRoot (n `quot` 2)-    !mk0 = n `quot` (2*k0+1)-    kmax a m = (a `quot` m - 1) `quot` 2-    big = runSTUArray $ do-        small <- newArray_ (0,mk0) :: ST s (STUArray s Int Int)-        unsafeWrite small 0 0-        unsafeWrite small 1 (fun 1)-        when (mk0 >= 2) $-            unsafeWrite small 2 (fun 2 - fun 1)-        let calcit switch change i-                | mk0 < i   = return (switch,change)-                | i == change = calcit (switch+1) (change + 4*switch+6) i-                | otherwise = do-                    let mloop !acc k !m-                            | k < switch    = kloop acc k-                            | otherwise     = do-                                val <- unsafeRead small m-                                let nxtk = kmax i (m+1)-                                mloop (acc - (k-nxtk)*val) nxtk (m+1)-                        kloop !acc k-                            | k == 0    = do-                                unsafeWrite small i acc-                                calcit switch change (i+1)-                            | otherwise = do-                                val <- unsafeRead small (i `quot` (2*k+1))-                                kloop (acc-val) (k-1)-                    mloop (fun i - fun (i `quot` 2)) ((i-1) `quot` 2) 1-        (sw, ch) <- calcit 1 8 3-        large <- newArray_ (0,k0-1)-        let calcbig switch change j-                | j == 0    = return large-                | (2*j-1)*change <= n   = calcbig (switch+1) (change + 4*switch+6) j-                | otherwise = do-                    let i = n `quot` (2*j-1)-                        mloop !acc k m-                            | k < switch    = kloop acc k-                            | otherwise     = do-                                val <- unsafeRead small m-                                let nxtk = kmax i (m+1)-                                mloop (acc - (k-nxtk)*val) nxtk (m+1)-                        kloop !acc k-                            | k == 0    = do-                                unsafeWrite large (j-1) acc-                                calcbig switch change (j-1)-                            | otherwise = do-                                let m = i `quot` (2*k+1)-                                val <- if m <= mk0-                                         then unsafeRead small m-                                         else unsafeRead large (k*(2*j-1)+j-1)-                                kloop (acc-val) (k-1)-                    mloop (fun i - fun (i `quot` 2)) ((i-1) `quot` 2) 1-        calcbig sw ch k0
− Math/NumberTheory/Powers.hs 
@@ -1,40 +0,0 @@--- |--- Module:      Math.NumberTheory.Powers--- Copyright:   (c) 2011 Daniel Fischer--- Licence:     MIT--- Maintainer:  Daniel Fischer <daniel.is.fischer@googlemail.com>--- Stability:   Provisional--- Portability: Non-portable (GHC extensions)------ Calculating integer roots, modular powers and related things.--- This module reexports the most needed functions from the implementation--- modules. The implementation modules provide some additional functions,--- in particular some unsafe functions which omit some tests for performance--- reasons.----module Math.NumberTheory.Powers-  ( -- *  Integer Roots-    -- ** Square roots-    integerSquareRoot-  , isSquare-  , exactSquareRoot-    -- ** Cube roots-  , integerCubeRoot-  , isCube-  , exactCubeRoot-    -- ** Fourth roots-  , integerFourthRoot-  , isFourthPower-  , exactFourthRoot-    -- ** General roots-  , integerRoot-  , isKthPower-  , exactRoot-  , isPerfectPower-  , highestPower-  ) where--import Math.NumberTheory.Powers.Squares-import Math.NumberTheory.Powers.Cubes-import Math.NumberTheory.Powers.Fourth-import Math.NumberTheory.Powers.General
− Math/NumberTheory/Powers/Cubes.hs 
@@ -1,256 +0,0 @@--- |--- Module:      Math.NumberTheory.Powers.Cubes--- Copyright:   (c) 2011 Daniel Fischer--- Licence:     MIT--- Maintainer:  Daniel Fischer <daniel.is.fischer@googlemail.com>--- Stability:   Provisional--- Portability: Non-portable (GHC extensions)------ Functions dealing with cubes. Moderately efficient calculation of integer--- cube roots and testing for cubeness.-{-# LANGUAGE MagicHash, BangPatterns, CPP, FlexibleContexts #-}-module Math.NumberTheory.Powers.Cubes-    ( integerCubeRoot-    , integerCubeRoot'-    , exactCubeRoot-    , isCube-    , isCube'-    , isPossibleCube-    ) where--#include "MachDeps.h"--import Data.Array.Unboxed-import Data.Array.ST--import Data.Bits--import GHC.Base-import GHC.Integer-import GHC.Integer.GMP.Internals-import GHC.Integer.Logarithms (integerLog2#)--import Math.NumberTheory.Unsafe---- | Calculate the integer cube root of an integer @n@,---   that is the largest integer @r@ such that @r^3 <= n@.---   Note that this is not symmetric about @0@, for example---   @integerCubeRoot (-2) = (-2)@ while @integerCubeRoot 2 = 1@.-{-# SPECIALISE integerCubeRoot :: Int -> Int,-                                  Integer -> Integer,-                                  Word -> Word-  #-}-integerCubeRoot :: Integral a => a -> a-integerCubeRoot 0 = 0-integerCubeRoot n-    | n > 0     = integerCubeRoot' n-    | otherwise =-      let m = negate n-          r = if m < 0-                then negate . fromInteger $ integerCubeRoot' (negate $ fromIntegral n)-                else negate (integerCubeRoot' m)-      in if r*r*r == n then r else (r-1)---- | Calculate the integer cube root of a nonnegative integer @n@,---   that is, the largest integer @r@ such that @r^3 <= n@.---   The precondition @n >= 0@ is not checked.-{-# RULES-"integerCubeRoot'/Int"     integerCubeRoot' = cubeRootInt'-"integerCubeRoot'/Word"    integerCubeRoot' = cubeRootWord-"integerCubeRoot'/Integer" integerCubeRoot' = cubeRootIgr-  #-}-{-# INLINE [1] integerCubeRoot' #-}-integerCubeRoot' :: Integral a => a -> a-integerCubeRoot' 0 = 0-integerCubeRoot' n = newton3 n (approxCuRt n)---- | Returns @Nothing@ if the argument is not a cube,---   @Just r@ if @n == r^3@.-{-# SPECIALISE exactCubeRoot :: Int -> Maybe Int,-                                Word -> Maybe Word,-                                Integer -> Maybe Integer-  #-}-exactCubeRoot :: Integral a => a -> Maybe a-exactCubeRoot 0 = Just 0-exactCubeRoot n-    | n < 0     =-      if m < 0-        then fmap (negate . fromInteger) $ exactCubeRoot (negate $ fromIntegral n)-        else fmap negate (exactCubeRoot m)-    | isPossibleCube n && r*r*r == n    = Just r-    | otherwise = Nothing-      where-        m = negate n-        r = integerCubeRoot' n---- | Test whether an integer is a cube.-{-# SPECIALISE isCube :: Int -> Bool,-                         Integer -> Bool,-                         Word -> Bool-  #-}-isCube :: Integral a => a -> Bool-isCube 0 = True-isCube n-    | n > 0     = isCube' n-    | m > 0     = isCube' m-    | otherwise = isCube' (negate (fromIntegral n) :: Integer)-      where-        m = negate n---- | Test whether a nonnegative integer is a cube.---   Before 'integerCubeRoot' is calculated, a few tests---   of remainders modulo small primes weed out most non-cubes.---   For testing many numbers, most of which aren't cubes,---   this is much faster than @let r = cubeRoot n in r*r*r == n@.---   The condition @n >= 0@ is /not/ checked.-{-# SPECIALISE isCube' :: Int -> Bool,-                          Integer -> Bool,-                          Word -> Bool-  #-}-isCube' :: Integral a => a -> Bool-isCube' !n = isPossibleCube n-             && (r*r*r == n)-      where-        r    = integerCubeRoot' n---- | Test whether a nonnegative number is possibly a cube.---   Only about 0.08% of all numbers pass this test.---   The precondition @n >= 0@ is /not/ checked.-{-# SPECIALISE isPossibleCube :: Int -> Bool,-                                 Integer -> Bool,-                                 Word -> Bool-  #-}-isPossibleCube :: Integral a => a -> Bool-isPossibleCube !n =-    unsafeAt cr512 (fromIntegral n .&. 511)-    && unsafeAt cubeRes837 (fromIntegral (n `rem` 837))-    && unsafeAt cubeRes637 (fromIntegral (n `rem` 637))-    && unsafeAt cubeRes703 (fromIntegral (n `rem` 703))---------------------------------------------------------------------------                         Utility Functions                        ----------------------------------------------------------------------------- Special case for 'Int', a little faster.--- For @n <= 2^64@, the truncated 'Double' is never--- more than one off. Things might overflow for @n@--- close to @maxBound@, so check for overflow.-cubeRootInt' :: Int -> Int-cubeRootInt' 0 = 0-cubeRootInt' n-    | n < c || c < 0    = r-1-    | 0 < d && d < n    = r+1-    | otherwise         = r-      where-        x = fromIntegral n :: Double-        r = truncate (x ** (1/3))-        c = r*r*r-        d = c+3*r*(r+1)--cubeRootWord :: Word -> Word-cubeRootWord 0 = 0-cubeRootWord w-#if WORD_SIZE_IN_BITS == 64-    | r > 2642245       = 2642245-#else-    | r > 1625          = 1625-#endif-    | w < c             = r-1-    | c < w && e < w && c < e  = r+1-    | otherwise         = r-      where-        r = truncate ((fromIntegral w) ** (1/3) :: Double)-        c = r*r*r-        d = 3*r*(r+1)-        e = c+d--cubeRootIgr :: Integer -> Integer-cubeRootIgr 0 = 0-cubeRootIgr n = newton3 n (approxCuRt n)--{-# SPECIALISE newton3 :: Int -> Int -> Int #-}-{-# SPECIALISE newton3 :: Integer -> Integer -> Integer #-}-newton3 :: Integral a => a -> a -> a-newton3 n a = go (step a)-      where-        step k = (2*k + n `quot` (k*k)) `quot` 3-        go k-            | m < k     = go m-            | otherwise = k-              where-                m = step k--{-# SPECIALISE approxCuRt :: Integer -> Integer #-}-approxCuRt :: Integral a => a -> a-approxCuRt 0 = 0-approxCuRt n = fromInteger $ appCuRt (fromIntegral n)---- threshold for shifting vs. direct fromInteger--- we shift when we expect more than 256 bits-#if WORD_SIZE_IN_BITS == 64-#define THRESH 5-#else-#define THRESH 9-#endif---- | approximate cube root, about 50 bits should be correct for large numbers-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-cr512 = runSTUArray $ do-    ar <- newArray (0,511) True-    let note s i-            | i < 512   = unsafeWrite ar i False >> note s (i+s)-            | otherwise = return ()-    note 4 2-    note 8 4-    note 32 16-    note 64 32-    note 256 128-    unsafeWrite ar 256 False-    return ar---- Remainders modulo @3^3 * 31@-cubeRes837 :: UArray Int Bool-cubeRes837 = runSTUArray $ do-    ar <- newArray (0,836) False-    let note 837 = return ar-        note k = unsafeWrite ar ((k*k*k) `rem` 837) True >> note (k+1)-    note 0---- Remainders modulo @7^2 * 13@-cubeRes637 :: UArray Int Bool-cubeRes637 = runSTUArray $ do-    ar <- newArray (0,636) False-    let note 637 = return ar-        note k = unsafeWrite ar ((k*k*k) `rem` 637) True >> note (k+1)-    note 0---- Remainders modulo @19 * 37@-cubeRes703 :: UArray Int Bool-cubeRes703 = runSTUArray $ do-    ar <- newArray (0,702) False-    let note 703 = return ar-        note k = unsafeWrite ar ((k*k*k) `rem` 703) True >> note (k+1)-    note 0
− Math/NumberTheory/Powers/Fourth.hs 
@@ -1,221 +0,0 @@--- |--- Module:      Math.NumberTheory.Powers.Squares--- Copyright:   (c) 2011 Daniel Fischer--- Licence:     MIT--- Maintainer:  Daniel Fischer <daniel.is.fischer@googlemail.com>--- Stability:   Provisional--- Portability: Non-portable (GHC extensions)------ Functions dealing with fourth powers. Efficient calculation of integer fourth--- roots and efficient testing for being a square's square.-{-# LANGUAGE MagicHash, CPP, FlexibleContexts #-}-module Math.NumberTheory.Powers.Fourth-    ( integerFourthRoot-    , integerFourthRoot'-    , exactFourthRoot-    , isFourthPower-    , isFourthPower'-    , isPossibleFourthPower-    ) where--#include "MachDeps.h"--import GHC.Base-import GHC.Integer-import GHC.Integer.GMP.Internals-import GHC.Integer.Logarithms (integerLog2#)--import Data.Array.Unboxed-import Data.Array.ST--import Data.Bits--import Math.NumberTheory.Unsafe---- | Calculate the integer fourth root of a nonnegative number,---   that is, the largest integer @r@ with @r^4 <= n@.---   Throws an error on negaitve input.-{-# SPECIALISE integerFourthRoot :: Int -> Int,-                                    Integer -> Integer,-                                    Word -> Word-  #-}-integerFourthRoot :: Integral a => a -> a-integerFourthRoot n-    | n < 0     = error "integerFourthRoot: negative argument"-    | otherwise = integerFourthRoot' n---- | Calculate the integer fourth root of a nonnegative number,---   that is, the largest integer @r@ with @r^4 <= n@.---   The condition is /not/ checked.-{-# RULES-"integerFourthRoot'/Int"     integerFourthRoot' = biSqrtInt-"integerFourthRoot'/Word"    integerFourthRoot' = biSqrtWord-"integerFourthRoot'/Integer" integerFourthRoot' = biSqrtIgr-  #-}-{-# INLINE [1] integerFourthRoot' #-}-integerFourthRoot' :: Integral a => a -> a-integerFourthRoot' 0 = 0-integerFourthRoot' n = newton4 n (approxBiSqrt n)---- | Returns @Nothing@ if @n@ is not a fourth power,---   @Just r@ if @n == r^4@ and @r >= 0@.-{-# SPECIALISE exactFourthRoot :: Int -> Maybe Int,-                                  Integer -> Maybe Integer,-                                  Word -> Maybe Word-  #-}-exactFourthRoot :: Integral a => a -> Maybe a-exactFourthRoot 0 = Just 0-exactFourthRoot n-    | n < 0     = Nothing-    | isPossibleFourthPower n && r2*r2 == n = Just r-    | otherwise = Nothing-      where-        r = integerFourthRoot' n-        r2 = r*r---- | Test whether an integer is a fourth power.---   First nonnegativity is checked, then the unchecked---   test is called.-{-# SPECIALISE isFourthPower :: Int -> Bool,-                                Integer -> Bool,-                                Word -> Bool-  #-}-isFourthPower :: Integral a => a -> Bool-isFourthPower 0 = True-isFourthPower n = n > 0 && isFourthPower' n---- | Test whether a nonnegative number is a fourth power.---   The condition is /not/ checked. If a number passes the---   'isPossibleFourthPower' test, its integer fourth root---   is calculated.-{-# SPECIALISE isFourthPower' :: Int -> Bool,-                                 Integer -> Bool,-                                 Word -> Bool-  #-}-isFourthPower' :: Integral a => a -> Bool-isFourthPower' n = isPossibleFourthPower n && r2*r2 == n-  where-    r = integerFourthRoot' n-    r2 = r*r---- | Test whether a nonnegative number is a possible fourth power.---   The condition is /not/ checked.---   This eliminates about 99.958% of numbers.-{-# SPECIALISE isPossibleFourthPower :: Int -> Bool,-                                        Integer -> Bool,-                                        Word -> Bool-  #-}-isPossibleFourthPower :: Integral a => a -> Bool-isPossibleFourthPower n =-        biSqRes256 `unsafeAt` (fromIntegral n .&. 255)-      && biSqRes425 `unsafeAt` (fromIntegral (n `rem` 425))-      && biSqRes377 `unsafeAt` (fromIntegral (n `rem` 377))--{-# SPECIALISE newton4 :: Integer -> Integer -> Integer #-}-newton4 :: Integral a => a -> a -> a-newton4 n a = go (step a)-      where-        step k = (3*k + n `quot` (k*k*k)) `quot` 4-        go k-            | m < k     = go m-            | otherwise = k-              where-                m = step k--{-# SPECIALISE approxBiSqrt :: Integer -> Integer #-}-approxBiSqrt :: Integral a => a -> a-approxBiSqrt = fromInteger . appBiSqrt . fromIntegral---- threshold for shifting vs. direct fromInteger--- we shift when we expect more than 384 bits-#if WORD_SIZE_IN_BITS == 64-#define THRESH 7-#else-#define THRESH 13-#endif---- Find a fairly good approximation to the fourth root.--- 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-biSqRes256 = runSTUArray $ do-    ar <- newArray (0,255) False-    let note 257 = return ar-        note i = unsafeWrite ar i True >> note (i+16)-    unsafeWrite ar 0 True-    unsafeWrite ar 16 True-    note 1--biSqRes425 :: UArray Int Bool-biSqRes425 = runSTUArray $ do-    ar <- newArray (0,424) False-    let note 154 = return ar-        note i = unsafeWrite ar ((i*i*i*i) `rem` 425) True >> note (i+1)-    note 0--biSqRes377 :: UArray Int Bool-biSqRes377 = runSTUArray $ do-    ar <- newArray (0,376) False-    let note 144 = return ar-        note i = unsafeWrite ar ((i*i*i*i) `rem` 377) True >> note (i+1)-    note 0--biSqrtInt :: Int -> Int-biSqrtInt 0 = 0-biSqrtInt n-#if WORD_SIZE_IN_BITS == 64-    | r > 55108 = 55108-#else-    | r > 215   = 215-#endif-    | n < r4    = r-1-    | otherwise = r-      where-        x :: Double-        x = fromIntegral n-        -- timed faster than x**0.25, never too small-        r = truncate (sqrt (sqrt x))-        r2 = r*r-        r4 = r2*r2--biSqrtWord :: Word -> Word-biSqrtWord 0 = 0-biSqrtWord n-#if WORD_SIZE_IN_BITS == 64-    | r > 65535 = 65535-#else-    | r > 255   = 255-#endif-    | n < r4    = r-1-    | otherwise = r-      where-        x :: Double-        x = fromIntegral n-        r = truncate (sqrt (sqrt x))-        r2 = r*r-        r4 = r2*r2--biSqrtIgr :: Integer -> Integer-biSqrtIgr 0 = 0-biSqrtIgr n = newton4 n (approxBiSqrt n)
− Math/NumberTheory/Powers/General.hs 
@@ -1,347 +0,0 @@--- |--- Module:      Math.NumberTheory.Powers.General--- Copyright:   (c) 2011 Daniel Fischer--- Licence:     MIT--- Maintainer:  Daniel Fischer <daniel.is.fischer@googlemail.com>--- Stability:   Provisional--- Portability: Non-portable (GHC extensions)------ Calculating integer roots and determining perfect powers.--- The algorithms are moderately efficient.----{-# LANGUAGE MagicHash, BangPatterns, CPP #-}-{-# OPTIONS_GHC -O2 -fspec-constr-count=8 #-}-module Math.NumberTheory.Powers.General-    ( integerRoot-    , exactRoot-    , isKthPower-    , isPerfectPower-    , highestPower-    , largePFPower-    ) where--#include "MachDeps.h"--import GHC.Base-import GHC.Integer-import GHC.Integer.GMP.Internals-import GHC.Integer.Logarithms (integerLog2#)--import Data.Bits-import Data.List (foldl')-import qualified Data.Set as Set--import Math.NumberTheory.Logarithms (integerLogBase')-import Math.NumberTheory.Utils  (shiftToOddCount-                                , splitOff-                                )-import qualified Math.NumberTheory.Powers.Squares as P2-import qualified Math.NumberTheory.Powers.Cubes as P3-import qualified Math.NumberTheory.Powers.Fourth as P4---- | Calculate an integer root, @'integerRoot' k n@ computes the (floor of) the @k@-th---   root of @n@, where @k@ must be positive.---   @r = 'integerRoot' k n@ means @r^k <= n < (r+1)^k@ if that is possible at all.---   It is impossible if @k@ is even and @n \< 0@, since then @r^k >= 0@ for all @r@,---   then, and if @k <= 0@, @'integerRoot'@ raises an error. For @k < 5@, a specialised---   version is called which should be more efficient than the general algorithm.---   However, it is not guaranteed that the rewrite rules for those fire, so if @k@ is---   known in advance, it is safer to directly call the specialised versions.-{-# SPECIALISE integerRoot :: Int -> Int -> Int,-                              Int -> Word -> Word,-                              Int -> Integer -> Integer,-                              Word -> Int -> Int,-                              Word -> Word -> Word,-                              Word -> Integer -> Integer,-                              Integer -> Integer -> Integer-  #-}-integerRoot :: (Integral a, Integral b) => b -> a -> a-integerRoot 1 n         = n-integerRoot 2 n         = P2.integerSquareRoot n-integerRoot 3 n         = P3.integerCubeRoot n-integerRoot 4 n         = P4.integerFourthRoot n-integerRoot k n-  | k < 1             = error "integerRoot: negative exponent or exponent 0"-  | n < 0 && even k   = error "integerRoot: negative radicand for even exponent"-  | n < 0             =-    let r = negate . fromInteger . integerRoot k . negate $ fromIntegral n-    in if r^k == n then r else (r-1)-  | n == 0            = 0-  | n < 31            = 1-  | kTooLarge         = 1-  | otherwise         = newtonK k' n a-    where-      k' = fromIntegral k-      a  = approxKthRoot (fromIntegral k) n-      kTooLarge = (toInteger k /= toInteger (fromIntegral k `asTypeOf` n))    -- k doesn't fit in n's type-                  || (toInteger k > toInteger (maxBound :: Int))  -- 2^k doesn't fit in Integer-                  || (I# (integerLog2# (toInteger n)) < fromIntegral k) -- n < 2^k---- | @'exactRoot' k n@ returns @'Nothing'@ if @n@ is not a @k@-th power,---   @'Just' r@ if @n == r^k@. If @k@ is divisible by @4, 3@ or @2@, a---   residue test is performed to avoid the expensive calculation if it---   can thus be determined that @n@ is not a @k@-th power.-exactRoot :: (Integral a, Integral b) => b -> a -> Maybe a-exactRoot 1 n = Just n-exactRoot 2 n = P2.exactSquareRoot n-exactRoot 3 n = P3.exactCubeRoot n-exactRoot 4 n = P4.exactFourthRoot n-exactRoot k n-  | n == 1          = Just 1-  | k < 1           = Nothing-  | n < 0 && even k = Nothing-  | n < 0           = fmap negate (exactRoot k (-n))-  | n < 2           = Just n-  | n < 31          = Nothing-  | kTooLarge       = Nothing-  | otherwise       = case k `rem` 12 of-                        0 | c4 && c3 && ok -> Just r-                          | otherwise -> Nothing-                        2 | c2 && ok -> Just r-                          | otherwise -> Nothing-                        3 | c3 && ok -> Just r-                          | otherwise -> Nothing-                        4 | c4 && ok -> Just r-                          | otherwise -> Nothing-                        6 | c3 && c2 && ok -> Just r-                          | otherwise -> Nothing-                        8 | c4 && ok -> Just r-                          | otherwise -> Nothing-                        9 | c3 && ok -> Just r-                          | otherwise -> Nothing-                        10 | c2 && ok -> Just r-                           | otherwise -> Nothing-                        _ | ok -> Just r-                          | otherwise -> Nothing--    where-      k' :: Int-      k' = fromIntegral k-      r  = integerRoot k' n-      c2 = P2.isPossibleSquare n-      c3 = P3.isPossibleCube n-      c4 = P4.isPossibleFourthPower n-      ok = r^k == n-      kTooLarge = (toInteger k /= toInteger (fromIntegral k `asTypeOf` n))    -- k doesn't fit in n's type-                  || (toInteger k > toInteger (maxBound :: Int))  -- 2^k doesn't fit in Integer-                  || (I# (integerLog2# (toInteger n)) < fromIntegral k) -- n < 2^k---- | @'isKthPower' k n@ checks whether @n@ is a @k@-th power.-isKthPower :: (Integral a, Integral b) => b -> a -> Bool-isKthPower k n = case exactRoot k n of-                   Just _ -> True-                   Nothing -> False---- | @'isPerfectPower' n@ checks whether @n == r^k@ for some @k > 1@.-isPerfectPower :: Integral a => a -> Bool-isPerfectPower n-  | n == 0 || n == 1    = True-  | otherwise           = k > 1-    where-      (_,k) = highestPower n---- | @'highestPower' n@ produces the pair @(b,k)@ with the largest---   exponent @k@ such that @n == b^k@, except for @'abs' n <= 1@,---   in which case arbitrarily large exponents exist, and by an---   arbitrary decision @(n,3)@ is returned.------   First, by trial division with small primes, the range of possible---   exponents is reduced (if @p^e@ exactly divides @n@, then @k@ must---   be a divisor of @e@, if several small primes divide @n@, @k@ must---   divide the greatest common divisor of their exponents, which mostly---   will be @1@, generally small; if none of the small primes divides---   @n@, the range of possible exponents is reduced since the base is---   necessarily large), if that has not yet determined the result, the---   remaining factor is examined by trying the divisors of the @gcd@---   of the prime exponents if some have been found, otherwise by trying---   prime exponents recursively.-highestPower :: Integral a => a -> (a, Int)-highestPower n'-  | abs n <= 1  = (n', 3)-  | n < 0       = case integerHighPower (negate n) of-                    (r,e) -> case shiftToOddCount e of-                               (k, o) -> (negate $ fromInteger (sqr k r), o)-  | otherwise   = case integerHighPower n of-                    (r,e) -> (fromInteger r, e)-    where-      n :: Integer-      n = toInteger n'--      sqr :: Int -> Integer -> Integer-      sqr 0 m = m-      sqr k m = sqr (k-1) (m*m)---- | @'largePFPower' bd n@ produces the pair @(b,k)@ with the largest---   exponent @k@ such that @n == b^k@, where @bd > 1@ (it is expected---   that @bd@ is much larger, at least @1000@ or so), @n > bd^2@ and @n@---   has no prime factors @p <= bd@, skipping the trial division phase---   of @'highestPower'@ when that is a priori known to be superfluous.---   It is only present to avoid duplication of work in factorisation---   and primality testing, it is not expected to be generally useful.---   The assumptions are not checked, if they are not satisfied, wrong---   results and wasted work may be the consequence.-largePFPower :: Integer -> Integer -> (Integer, Int)-largePFPower bd n = rawPower ln n-  where-    ln = integerLogBase' (bd+1) n-----------------------------------------------------------------------------------------------                                  Auxiliary functions                                 -----------------------------------------------------------------------------------------------{-# SPECIALISE newtonK :: Int -> Int -> Int -> Int,-                          Integer -> Integer -> Integer -> Integer,-                          Word -> Word -> Word -> Word-  #-}-newtonK :: Integral a => a -> a -> a -> a-newtonK k n a = go (step a)-  where-    -- Beware integer overflow in m^(k-1)-    step m = ((k-1)*m + fromInteger (toInteger n `quot` (toInteger m^(k-1)))) `quot` k-    go m-      | l < m     = go l-      | otherwise = m-        where-          l = step m--{-# SPECIALISE approxKthRoot :: Int -> Integer -> Integer,-                                Int -> Int -> Int,-                                Int -> Word -> Word-  #-}-approxKthRoot :: Integral a => Int -> a -> a-approxKthRoot k = fromInteger . appKthRoot k . fromIntegral---- find an approximation to the k-th root--- here, k > 4 and n > 31-appKthRoot :: Int -> Integer -> Integer-appKthRoot (I# k#) (S# n#) = S# (double2Int# (int2Double# n# **## (1.0## /## int2Double# k#)))-appKthRoot k@(I# k#) n =-    case integerLog2# n of-      l# -> case l# `quotInt#` k# of-              0# -> 1-              1# -> 3-              2# -> 5-              3# -> 11-              h# | isTrue# (h# <# 500#) ->-                   floor (scaleFloat (I# (h# -# 1#))-                          (fromInteger (n `shiftRInteger` (h# *# k# -# k#)) ** (1/fromIntegral k) :: Double))-                 | otherwise ->-                   floor (scaleFloat 400 (fromInteger (n `shiftRInteger` (h# *# k# -# k#)) ** (1/fromIntegral k) :: Double))-                          `shiftLInteger` (h# -# 401#)---- assumption: argument is > 1-integerHighPower :: Integer -> (Integer, Int)-integerHighPower n-  | n < 4       = (n,1)-  | otherwise   = case shiftToOddCount n of-                    (e2,m) | m == 1     -> (2,e2)-                           | otherwise  -> findHighPower e2 (if e2 == 0 then [] else [(2,e2)]) m r smallOddPrimes-                             where-                               r = P2.integerSquareRoot m--findHighPower :: Int -> [(Integer,Int)] -> Integer -> Integer -> [Integer] -> (Integer, Int)-findHighPower 1 pws m _ _ = (foldl' (*) m [p^e | (p,e) <- pws], 1)-findHighPower e pws 1 _ _ = (foldl' (*) 1 [p^(ex `quot` e) | (p,ex) <- pws], e)-findHighPower e pws m s (p:ps)-  | s < p       = findHighPower 1 pws m s []-  | otherwise   =-    case splitOff p m of-      (0,_) -> findHighPower e pws m s ps-      (k,r) -> findHighPower (gcd k e) ((p,k):pws) r (P2.integerSquareRoot r) ps-findHighPower e pws m _ [] = finishPower e pws m--spBEx :: Int-spBEx = 14--spBound :: Integer-spBound = 2^spBEx--smallOddPrimes :: [Integer]-smallOddPrimes = 3:5:primes'-  where-    primes' = 7:11:13:17:19:23:29:filter isPrime (takeWhile (< spBound) $ scanl (+) 31 (cycle [6,4,2,4,2,4,6,2]))-    isPrime n = go primes'-      where-        go (p:ps) = (p*p > n) || (n `rem` p /= 0 && go ps)-        go []     = True---- n large, has no prime divisors < spBound-finishPower :: Int -> [(Integer, Int)] -> Integer -> (Integer, Int)-finishPower e pws n-  | n < (1 `shiftL` (2*spBEx))  = (foldl' (*) n [p^ex | (p,ex) <- pws], 1)    -- n is prime-  | e == 0  = rawPower maxExp n-  | otherwise = go divs-    where-      maxExp = (I# (integerLog2# n)) `quot` spBEx-      divs = divisorsTo maxExp e-      go [] = (foldl' (*) n [p^ex | (p,ex) <- pws], 1)-      go (d:ds) = case exactRoot d n of-                    Just r -> (foldl' (*) r [p^(ex `quot` d) | (p,ex) <- pws], d)-                    Nothing -> go ds--rawPower :: Int -> Integer -> (Integer, Int)-rawPower mx n-  | mx < 2      = (n,1)-  | mx == 2     = case P2.exactSquareRoot n of-                    Just r  -> (r,2)-                    Nothing -> (n,1)-rawPower mx n = case P4.exactFourthRoot n of-                  Just r -> case rawPower (mx `quot` 4) r of-                              (m,e) -> (m, 4*e)-                  Nothing -> case P2.exactSquareRoot n of-                               Just r -> case rawOddPower (mx `quot` 2) r of-                                           (m,e) -> (m, 2*e)-                               Nothing -> rawOddPower mx n--rawOddPower :: Int -> Integer -> (Integer, Int)-rawOddPower mx n-  | mx < 3       = (n,1)-rawOddPower mx n = case P3.exactCubeRoot n of-                     Just r -> case rawOddPower (mx `quot` 3) r of-                                 (m,e) -> (m, 3*e)-                     Nothing -> badPower mx n--badPower :: Int -> Integer -> (Integer, Int)-badPower mx n-  | mx < 5      = (n,1)-  | otherwise   = go 1 mx n (takeWhile (<= mx) $ scanl (+) 5 $ cycle [2,4])-    where-      go !e b m (k:ks)-        | b < k     = (m,e)-        | otherwise = case exactRoot k m of-                        Just r -> go (e*k) (b `quot` k) r (k:ks)-                        Nothing -> go e b m ks-      go e _ m []   = (m,e)--divisorsTo :: Int -> Int -> [Int]-divisorsTo mx n = case shiftToOddCount n of-                    (k,o) | k == 0 -> go (Set.singleton 1) n iops-                          | otherwise -> go (Set.fromDistinctAscList $ takeWhile (<= mx) $ take (k+1) (iterate (*2) 1)) o iops-  where-    mset k st = fst (Set.split (mx+1) (Set.mapMonotonic (*k) st))-    -- unP p m = (k, m / p ^ k), where k is as large as possible such that p ^ k still divides m-    unP :: Int -> Int -> (Int,Int)-    unP p m = goP 0 m-      where-        goP :: Int -> Int -> (Int,Int)-        goP !i j = case j `quotRem` p of-                     (q,r) | r == 0 -> goP (i+1) q-                           | otherwise -> (i,j)-    iops :: [Int]-    iops = 3:5:prs-    prs :: [Int]-    prs = 7:filter prm (scanl (+) 11 $ cycle [2,4,2,4,6,2,6,4])-    prm :: Int -> Bool-    prm k = td prs-      where-        td (p:ps) = (p*p > k) || (k `rem` p /= 0 && td ps)-        td []     = True-    go !st m (p:ps)-      | m == 1  = reverse $ Set.toAscList st-      | m < p*p = reverse . Set.toAscList $ Set.union st (mset m st)-      | otherwise =-        case unP p m of-          (0,_) -> go st m ps-          -- iterate f x = [x, f x, f (f x)...]-          (k,r) -> go (Set.unions (take (k + 1) (iterate (mset p) st))) r ps-    go st m [] = go st m [m+1]
− Math/NumberTheory/Powers/Integer.hs 
@@ -1,44 +0,0 @@--- |--- Module:      Math.NumberTheory.Powers.Integer--- Copyright:   (c) 2011-2014 Daniel Fischer--- Licence:     MIT--- Maintainer:  Daniel Fischer <daniel.is.fischer@googlemail.com>--- Stability:   Provisional--- Portability: Non-portable (GHC extensions)------ Potentially faster power function for 'Integer' base and 'Int'--- or 'Word' exponent.----{-# LANGUAGE CPP #-}-module Math.NumberTheory.Powers.Integer-    {-# DEPRECATED "It is no faster than (^)" #-}-    ( integerPower-    , integerWordPower-    ) where--#if MIN_VERSION_base(4,8,0)-#else-import Data.Word-#endif---- | Power of an 'Integer' by the left-to-right repeated squaring algorithm.---   This needs two multiplications in each step while the right-to-left---   algorithm needs only one multiplication for 0-bits, but here the---   two factors always have approximately the same size, which on average---   gains a bit when the result is large.------   For small results, it is unlikely to be any faster than '(^)', quite---   possibly slower (though the difference shouldn't be large), and for---   exponents with few bits set, the same holds. But for exponents with---   many bits set, the speedup can be significant.------   /Warning:/ No check for the negativity of the exponent is performed,---   a negative exponent is interpreted as a large positive exponent.-integerPower :: Integer -> Int -> Integer-integerPower = (^)-{-# DEPRECATED integerPower "Use (^) instead" #-}---- | Same as 'integerPower', but for exponents of type 'Word'.-integerWordPower :: Integer -> Word -> Integer-integerWordPower = (^)-{-# DEPRECATED integerWordPower "Use (^) instead" #-}
− Math/NumberTheory/Powers/Squares.hs 
@@ -1,258 +0,0 @@--- |--- Module:      Math.NumberTheory.Powers.Squares--- Copyright:   (c) 2011 Daniel Fischer--- Licence:     MIT--- Maintainer:  Daniel Fischer <daniel.is.fischer@googlemail.com>--- Stability:   Provisional--- Portability: Non-portable (GHC extensions)------ Functions dealing with squares. Efficient calculation of integer square roots--- and efficient testing for squareness.-{-# LANGUAGE MagicHash, BangPatterns, PatternGuards, CPP, FlexibleContexts #-}-module Math.NumberTheory.Powers.Squares-    ( -- * Square root calculation-      integerSquareRoot-    , integerSquareRoot'-    , integerSquareRootRem-    , integerSquareRootRem'-    , exactSquareRoot-      -- * Tests for squares-    , isSquare-    , isSquare'-    , isPossibleSquare-    , isPossibleSquare2-    ) where--#include "MachDeps.h"--import Data.Array.Unboxed-import Data.Array.ST--import Data.Bits-#if __GLASGOW_HASKELL__ < 709-import Data.Word        -- Moved to GHC.Types-#endif--import Math.NumberTheory.Unsafe--import Math.NumberTheory.Powers.Squares.Internal---- | Calculate the integer square root of a nonnegative number @n@,---   that is, the largest integer @r@ with @r*r <= n@.---   Throws an error on negative input.-{-# SPECIALISE integerSquareRoot :: Int -> Int,-                                    Word -> Word,-                                    Integer -> Integer-  #-}-integerSquareRoot :: Integral a => a -> a-integerSquareRoot n-  | n < 0       = error "integerSquareRoot: negative argument"-  | otherwise   = integerSquareRoot' n---- | Calculate the integer square root of a nonnegative number @n@,---   that is, the largest integer @r@ with @r*r <= n@.---   The precondition @n >= 0@ is not checked.-{-# RULES-"integerSquareRoot'/Int"     integerSquareRoot' = isqrtInt'-"integerSquareRoot'/Word"    integerSquareRoot' = isqrtWord-"integerSquareRoot'/Integer" integerSquareRoot' = isqrtInteger-  #-}-{-# INLINE [1] integerSquareRoot' #-}-integerSquareRoot' :: Integral a => a -> a-integerSquareRoot' = isqrtA---- | Calculate the integer square root of a nonnegative number as well as---   the difference of that number with the square of that root, that is if---   @(s,r) = integerSquareRootRem n@ then @s^2 <= n == s^2+r < (s+1)^2@.-{-# SPECIALISE integerSquareRootRem ::-        Int -> (Int, Int),-        Word -> (Word, Word),-        Integer -> (Integer, Integer)-  #-}-integerSquareRootRem :: Integral a => a -> (a, a)-integerSquareRootRem n-  | n < 0       = error "integerSquareRootRem: negative argument"-  | otherwise   = integerSquareRootRem' n---- | Calculate the integer square root of a nonnegative number as well as---   the difference of that number with the square of that root, that is if---   @(s,r) = integerSquareRootRem' n@ then @s^2 <= n == s^2+r < (s+1)^2@.---   The precondition @n >= 0@ is not checked.-{-# RULES-"integerSquareRootRem'/Integer" integerSquareRootRem' = karatsubaSqrt-  #-}-{-# INLINE [1] integerSquareRootRem' #-}-integerSquareRootRem' :: Integral a => a -> (a, a)-integerSquareRootRem' n = (s, n - s * s)-  where-    s = integerSquareRoot' n---- | Returns 'Nothing' if the argument is not a square,---   @'Just' r@ if @r*r == n@ and @r >= 0@. Avoids the expensive calculation---   of the square root if @n@ is recognized as a non-square---   before, prevents repeated calculation of the square root---   if only the roots of perfect squares are needed.---   Checks for negativity and 'isPossibleSquare'.-{-# SPECIALISE exactSquareRoot :: Int -> Maybe Int,-                                  Word -> Maybe Word,-                                  Integer -> Maybe Integer-  #-}-exactSquareRoot :: Integral a => a -> Maybe a-exactSquareRoot n-  | n >= 0-  , isPossibleSquare n-  , (r, 0) <- integerSquareRootRem' n = Just r-  | otherwise                         = Nothing---- | Test whether the argument is a square.---   After a number is found to be positive, first 'isPossibleSquare'---   is checked, if it is, the integer square root is calculated.-{-# SPECIALISE isSquare :: Int -> Bool,-                           Word -> Bool,-                           Integer -> Bool-  #-}-isSquare :: Integral a => a -> Bool-isSquare n = n >= 0 && isSquare' n---- | Test whether the input (a nonnegative number) @n@ is a square.---   The same as 'isSquare', but without the negativity test.---   Faster if many known positive numbers are tested.------   The precondition @n >= 0@ is not tested, passing negative---   arguments may cause any kind of havoc.-{-# SPECIALISE isSquare' :: Int -> Bool,-                            Word -> Bool,-                            Integer -> Bool-  #-}-isSquare' :: Integral a => a -> Bool-isSquare' n-    | isPossibleSquare n-    , (_, 0) <- integerSquareRootRem' n = True-    | otherwise                         = False---- | Test whether a non-negative number may be a square.---   Non-negativity is not checked, passing negative arguments may---   cause any kind of havoc.------   First the remainder modulo 256 is checked (that can be calculated---   easily without division and eliminates about 82% of all numbers).---   After that, the remainders modulo 9, 25, 7, 11 and 13 are tested---   to eliminate altogether about 99.436% of all numbers.------   This is the test used by 'exactSquareRoot'. For large numbers,---   the slower but more discriminating test 'isPossibleSqure2' is---   faster.-{-# SPECIALISE isPossibleSquare :: Int -> Bool,-                                   Integer -> Bool,-                                   Word -> Bool-  #-}-isPossibleSquare :: Integral a => a -> Bool-isPossibleSquare n =-  unsafeAt sr256 ((fromIntegral n) .&. 255)-  && unsafeAt sr693 (fromIntegral (n `rem` 693))-  && unsafeAt sr325 (fromIntegral (n `rem` 325))---- | Test whether a non-negative number may be a square.---   Non-negativity is not checked, passing negative arguments may---   cause any kind of havoc.------   First the remainder modulo 256 is checked (that can be calculated---   easily without division and eliminates about 82% of all numbers).---   After that, the remainders modulo several small primes are tested---   to eliminate altogether about 99.98954% of all numbers.------   For smallish to medium sized numbers, this hardly performs better---   than 'isPossibleSquare', which uses smaller arrays, but for large---   numbers, where calculating the square root becomes more expensive,---   it is much faster (if the vast majority of tested numbers aren't squares).-{-# SPECIALISE isPossibleSquare2 :: Int -> Bool,-                                    Integer -> Bool,-                                    Word -> Bool-  #-}-isPossibleSquare2 :: Integral a => a -> Bool-isPossibleSquare2 n =-  unsafeAt sr256 ((fromIntegral n) .&. 255)-  && unsafeAt sr819  (fromIntegral (n `rem` 819))-  && unsafeAt sr1025 (fromIntegral (n `rem` 1025))-  && unsafeAt sr2047 (fromIntegral (n `rem` 2047))-  && unsafeAt sr4097 (fromIntegral (n `rem` 4097))-  && unsafeAt sr341  (fromIntegral (n `rem` 341))----------------------------------------------------------------------------------  Auxiliary Stuff---- Make an array indicating whether a remainder is a square remainder.-sqRemArray :: Int -> UArray Int Bool-sqRemArray md = runSTUArray $ do-  arr <- newArray (0,md-1) False-  let !stop = (md `quot` 2) + 1-      fill k-        | k < stop  = unsafeWrite arr ((k*k) `rem` md) True >> fill (k+1)-        | otherwise = return arr-  unsafeWrite arr 0 True-  unsafeWrite arr 1 True-  fill 2--sr256 :: UArray Int Bool-sr256 = sqRemArray 256--sr819 :: UArray Int Bool-sr819 = sqRemArray 819--sr4097 :: UArray Int Bool-sr4097 = sqRemArray 4097--sr341 :: UArray Int Bool-sr341 = sqRemArray 341--sr1025 :: UArray Int Bool-sr1025 = sqRemArray 1025--sr2047 :: UArray Int Bool-sr2047 = sqRemArray 2047--sr693 :: UArray Int Bool-sr693 = sqRemArray 693--sr325 :: UArray Int Bool-sr325 = sqRemArray 325---- Specialisations for Int, Word, and Integer---- For @n <= 2^64@, the result of------ > truncate (sqrt $ fromIntegral n)------ is never too small and never more than one too large.--- The multiplication doesn't overflow for 32 or 64 bit Ints.-isqrtInt' :: Int -> Int-isqrtInt' n-    | n < r*r   = r-1-    | otherwise = r-      where-        !r = (truncate :: Double -> Int) . sqrt $ fromIntegral n--- With -O2, that should be translated to the below-{--isqrtInt' n@(I# i#)-    | r# *# r# ># i#            = I# (r# -# 1#)-    | otherwise                 = I# r#-      where-        !r# = double2Int# (sqrtDouble# (int2Double# i#))--}---- Same for Word.-isqrtWord :: Word -> Word-isqrtWord n-    | n < (r*r)-#if WORD_SIZE_IN_BITS == 64-      || r == 4294967296--- Double interprets values near maxBound as 2^64, we don't have that problem for 32 bits-#endif-                = r-1-    | otherwise = r-      where-        !r = (fromIntegral :: Int -> Word) . (truncate :: Double -> Int) . sqrt $ fromIntegral n--{-# INLINE isqrtInteger #-}-isqrtInteger :: Integer -> Integer-isqrtInteger = fst . karatsubaSqrt
− Math/NumberTheory/Powers/Squares/Internal.hs 
@@ -1,141 +0,0 @@--- |--- Module:      Math.NumberTheory.Powers.Squares.Internal--- Copyright:   (c) 2016 Andrew Lelechenko--- Licence:     MIT--- Maintainer:  Andrew Lelechenko <andrew.lelechenko@gmail.com>--- Stability:   Provisional--- Portability: Non-portable (GHC extensions)------ Internal functions dealing with square roots. End-users should not import this module.--{-# LANGUAGE MagicHash        #-}-{-# LANGUAGE BangPatterns     #-}-{-# LANGUAGE PatternGuards    #-}-{-# LANGUAGE CPP              #-}-{-# LANGUAGE FlexibleContexts #-}--module Math.NumberTheory.Powers.Squares.Internal-  ( karatsubaSqrt-  , isqrtA-  ) where--#include "MachDeps.h"--import Data.Bits--import GHC.Base-import GHC.Integer-import GHC.Integer.GMP.Internals-import GHC.Integer.Logarithms (integerLog2#)--import Math.NumberTheory.Logarithms (integerLog2)---- Find approximation to square root in 'Integer', then--- find the integer square root by the integer variant--- of Heron's method. Takes only a handful of steps--- unless the input is really large.-{-# SPECIALISE isqrtA :: Integer -> Integer #-}-isqrtA :: Integral a => a -> a-isqrtA 0 = 0-isqrtA n = heron n (fromInteger . appSqrt . fromIntegral $ n)---- Heron's method for integers. First make one step to ensure--- the value we're working on is @>= r@, then we have--- @k == r@ iff @k <= step k@.-{-# SPECIALISE heron :: Integer -> Integer -> Integer #-}-heron :: Integral a => a -> a -> a-heron n a = go (step a)-      where-        step k = (k + n `quot` k) `quot` 2-        go k-            | m < k     = go m-            | otherwise = k-              where-                m = step k---- threshold for shifting vs. direct fromInteger--- we shift when we expect more than 256 bits-#if WORD_SIZE_IN_BITS == 64-#define THRESH 5-#else-#define THRESH 9-#endif---- Find a fairly good approximation to the square root.--- At most one off for small Integers, about 48 bits should be correct--- 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--- algorithm from--- Paul Zimmermann. Karatsuba Square Root. [Research Report] RR-3805, 1999,--- pp.8. <inria-00072854>--karatsubaSqrt :: Integer -> (Integer, Integer)-karatsubaSqrt 0 = (0, 0)-karatsubaSqrt n-    | lgN < 2300 =-        let s = isqrtA n in (s, n - s * s)-    | otherwise =-        if lgN .&. 2 /= 0 then-            karatsubaStep k (karatsubaSplit k n)-        else-            -- before we split n into 4 part we must ensure that the first part-            -- is at least 2^k/4, since this doesn't happen here we scale n by-            -- multiplying it by 4-            let n' = n `unsafeShiftL` 2-                (s, r) = karatsubaStep k (karatsubaSplit k n')-                r' | s .&. 1 == 0 = r-                   | otherwise = r + double s - 1-            in  (s `unsafeShiftR` 1, r' `unsafeShiftR` 2)-  where-    k = lgN `unsafeShiftR` 2 + 1-    lgN = integerLog2 n--karatsubaStep :: Int -> (Integer, Integer, Integer, Integer) -> (Integer, Integer)-karatsubaStep k (a3, a2, a1, a0)-    | r >= 0 = (s, r)-    | otherwise = (s - 1, r + double s - 1)-  where-    r = cat u a0 - q * q-    s = s' `unsafeShiftL` k + q-    (q, u) = cat r' a1 `quotRem` double s'-    (s', r') = karatsubaSqrt (cat a3 a2)-    cat x y = x `unsafeShiftL` k .|. y-    {-# INLINE cat #-}--karatsubaSplit :: Int -> Integer -> (Integer, Integer, Integer, Integer)-karatsubaSplit k n0 = (a3, a2, a1, a0)-  where-    a3 = n3-    n3 = n2 `unsafeShiftR` k-    a2 = n2 .&. m-    n2 = n1 `unsafeShiftR` k-    a1 = n1 .&. m-    n1 = n0 `unsafeShiftR` k-    a0 = n0 .&. m-    m = 1 `unsafeShiftL` k - 1--double :: Bits a => a -> a-double x = x `unsafeShiftL` 1-{-# INLINE double #-}
+ Math/NumberTheory/Prefactored.hs view
@@ -0,0 +1,126 @@+-- |+-- Module:      Math.NumberTheory.Prefactored+-- Copyright:   (c) 2017 Andrew Lelechenko+-- Licence:     MIT+-- Maintainer:  Andrew Lelechenko <andrew.lelechenko@gmail.com>+--+-- Type for numbers, accompanied by their factorisation.+--++{-# LANGUAGE TypeFamilies  #-}++{-# OPTIONS_GHC -fno-warn-unused-imports #-}++module Math.NumberTheory.Prefactored+  ( Prefactored(prefValue, prefFactors)+  , fromValue+  , fromFactors+  ) where++import Prelude hiding ((^), gcd)+import Control.Arrow+import Data.Euclidean+import Data.Semigroup+import Data.Semiring (Semiring(..), Mul(..), (^))+import qualified Data.Semiring as Semiring+import Unsafe.Coerce++import Math.NumberTheory.Euclidean.Coprimes+import Math.NumberTheory.Primes+import Math.NumberTheory.Primes.Types++-- | A container for a number and its pairwise coprime (but not necessarily prime)+-- factorisation.+-- It is designed to preserve information about factors under multiplication.+-- One can use this representation to speed up prime factorisation+-- and computation of arithmetic functions.+--+-- For instance, let @p@ and @q@ be big primes:+--+-- >>> let p = 1000000000000000000000000000057 :: Integer+-- >>> let q = 2000000000000000000000000000071 :: Integer+--+-- It would be difficult to compute the totient function+-- of their product as is, because once we multiplied them+-- the information of factors is lost and+-- 'Math.NumberTheory.ArithmeticFunctions.totient' (@p@ * @q@)+-- would take ages. Things become different if we simply+-- change types of @p@ and @q@ to prefactored ones:+--+-- >>> let p = 1000000000000000000000000000057 :: Prefactored Integer+-- >>> let q = 2000000000000000000000000000071 :: Prefactored Integer+--+-- Now the 'Math.NumberTheory.ArithmeticFunctions.totient' function+-- can be computed instantly:+--+-- >>> import Math.NumberTheory.ArithmeticFunctions+-- >>> prefValue $ totient (p^2 * q^3)+-- 8000000000000000000000000001752000000000000000000000000151322000000000000000000000006445392000000000000000000000135513014000000000000000000001126361040+-- >>> prefValue $ totient $ totient (p^2 * q^3)+-- 2133305798262843681544648472180210822742702690942899511234131900112583590230336435053688694839034890779375223070157301188739881477320529552945446912000+--+-- Let us look under the hood:+--+-- >>> import Math.NumberTheory.ArithmeticFunctions+-- >>> prefFactors $ totient (p^2 * q^3)+-- Coprimes {unCoprimes = [(1000000000000000000000000000057,1),(41666666666666666666666666669,1),(2000000000000000000000000000071,2),(111111111111111111111111111115,1),(2,4),(3,3)]}+-- >>> prefFactors $ totient $ totient (p^2 * q^3)+-- Coprimes {unCoprimes = [(39521,1),(227098769,1),(22222222222222222222222222223,1),(2000000000000000000000000000071,1),(361696272343,1),(85331809838489,1),(6046667,1),(199937,1),(5,3),(41666666666666666666666666669,1),(2,22),(3,8)]}+--+-- Pairwise coprimality of factors is crucial, because it allows+-- us to process them independently, possibly even+-- in parallel or concurrent fashion.+--+-- Following invariant is guaranteed to hold:+--+-- > abs (prefValue x) = abs (product (map (uncurry (^)) (prefFactors x)))+data Prefactored a = Prefactored+  { prefValue   :: a+    -- ^ Number itself.+  , prefFactors :: Coprimes a Word+    -- ^ List of pairwise coprime (but not necessarily prime) factors,+    -- accompanied by their multiplicities.+  } deriving (Eq, Show)++-- | Create 'Prefactored' from a given number.+--+-- >>> fromValue 123+-- Prefactored {prefValue = 123, prefFactors = Coprimes {unCoprimes = [(123,1)]}}+fromValue :: (Eq a, GcdDomain a) => a -> Prefactored a+fromValue a = Prefactored a (singleton a 1)++-- | Create 'Prefactored' from a given list of pairwise coprime+-- (but not necessarily prime) factors with multiplicities.+--+-- >>> fromFactors (splitIntoCoprimes [(140, 1), (165, 1)])+-- Prefactored {prefValue = 23100, prefFactors = Coprimes {unCoprimes = [(28,1),(33,1),(5,2)]}}+-- >>> fromFactors (splitIntoCoprimes [(140, 2), (165, 3)])+-- Prefactored {prefValue = 88045650000, prefFactors = Coprimes {unCoprimes = [(28,2),(33,3),(5,5)]}}+fromFactors :: Semiring a => Coprimes a Word -> Prefactored a+fromFactors as = Prefactored (getMul $ foldMap (\(a, k) -> Mul $ a ^ k) (unCoprimes as)) as++instance (Eq a, GcdDomain a) => Semiring (Prefactored a) where+  Prefactored v1 _ `plus` Prefactored v2 _+    = fromValue (v1 `plus` v2)+  Prefactored v1 f1 `times` Prefactored v2 f2+    = Prefactored (v1 `times` v2) (f1 <> f2)+  fromNatural n = fromValue (fromNatural n)++instance (Eq a, Num a, GcdDomain 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) (f1 <> f2)+  negate (Prefactored v f) = Prefactored (negate v) f+  abs (Prefactored v f)    = Prefactored (abs v) f+  signum (Prefactored v _) = Prefactored (signum v) mempty+  fromInteger n = fromValue (fromInteger n)++instance (Eq a, GcdDomain a, UniqueFactorisation a) => UniqueFactorisation (Prefactored a) where+  factorise (Prefactored _ f)+    = concatMap (\(x, xm) -> map (\(p, k) -> (Prime $ fromValue $ unPrime p, k * xm)) (factorise x)) (unCoprimes f)+  isPrime (Prefactored _ f) = case unCoprimes f of+    [(n, 1)] -> Prime . fromValue . unPrime <$> isPrime n+    _        -> Nothing
Math/NumberTheory/Primes.hs view
@@ -1,19 +1,295 @@ -- | -- Module:      Math.NumberTheory.Primes--- Copyright:   (c) 2011 Daniel Fischer+-- Copyright:   (c) 2016-2018 Andrew.Lelechenko -- Licence:     MIT--- Maintainer:  Daniel Fischer <daniel.is.fischer@googlemail.com>--- Stability:   Provisional--- Portability: Non-portable (GHC extensions)+-- Maintainer:  Andrew Lelechenko <andrew.lelechenko@gmail.com> --++{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase        #-}+{-# LANGUAGE PostfixOperators  #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}+ module Math.NumberTheory.Primes-    ( module Math.NumberTheory.Primes.Sieve-    , module Math.NumberTheory.Primes.Counting-    , module Math.NumberTheory.Primes.Testing-    , module Math.NumberTheory.Primes.Factorisation+    ( Prime+    , unPrime+    , toPrimeIntegral+    , nextPrime+    , precPrime+    , UniqueFactorisation(..)+    , factorBack+    , -- * Old interface+      primes     ) where -import Math.NumberTheory.Primes.Sieve-import Math.NumberTheory.Primes.Counting-import Math.NumberTheory.Primes.Testing hiding (FactorSieve)-import Math.NumberTheory.Primes.Factorisation+import Data.Bits+import Data.Coerce+import Data.List.Infinite (Infinite(..), (...), (....))+import qualified Data.List.Infinite as Inf+import Data.Maybe+import Data.Word+import Numeric.Natural++import Math.NumberTheory.Primes.Counting (nthPrime, primeCount)+import qualified Math.NumberTheory.Primes.Factorisation.Montgomery as F (factorise)+import qualified Math.NumberTheory.Primes.Testing.Probabilistic as T (isPrime)+import Math.NumberTheory.Primes.Sieve.Eratosthenes (primes, sieveRange, primeList, psieveFrom, primeSieve)+import Math.NumberTheory.Primes.Small+import Math.NumberTheory.Primes.Types+import Math.NumberTheory.Utils (toWheel30, fromWheel30)+import Math.NumberTheory.Utils.FromIntegral++-- | A class for unique factorisation domains.+class Num a => UniqueFactorisation a where+  -- | Factorise a number into a product of prime powers.+  -- Factorisation of 0 is an undefined behaviour. Otherwise+  -- following invariants hold:+  --+  -- > abs n == abs (product (map (\(p, k) -> unPrime p ^ k) (factorise n)))+  -- > all ((> 0) . snd) (factorise n)+  --+  -- >>> factorise (1 :: Integer)+  -- []+  -- >>> factorise (-1 :: Integer)+  -- []+  -- >>> factorise (6 :: Integer)+  -- [(Prime 2,1),(Prime 3,1)]+  -- >>> factorise (-108 :: Integer)+  -- [(Prime 2,2),(Prime 3,3)]+  --+  -- This function is a replacement+  -- for 'Math.NumberTheory.Primes.Factorisation.factorise'.+  -- If you were looking for the latter, please import+  -- "Math.NumberTheory.Primes.Factorisation" instead of this module.+  --+  -- __Warning:__ there are no guarantees of any particular+  -- order of prime factors, do not expect them to be ascending. E. g.,+  --+  -- >>> factorise 10251562501+  -- [(Prime 101701,1),(Prime 100801,1)]+  factorise :: a -> [(Prime a, Word)]+  -- | Check whether an argument is prime.+  -- If it is then return an associated prime.+  --+  -- >>> isPrime (3 :: Integer)+  -- Just (Prime 3)+  -- >>> isPrime (4 :: Integer)+  -- Nothing+  -- >>> isPrime (-5 :: Integer)+  -- Just (Prime 5)+  --+  -- This function is a replacement+  -- for 'Math.NumberTheory.Primes.Testing.isPrime'.+  -- If you were looking for the latter, please import+  -- "Math.NumberTheory.Primes.Testing" instead of this module.+  isPrime   :: a -> Maybe (Prime a)++instance UniqueFactorisation Int where+  factorise = coerce . F.factorise+  isPrime n = if T.isPrime (toInteger n) then Just (Prime $ abs n) else Nothing++instance UniqueFactorisation Word where+  factorise = coerce . F.factorise+  isPrime n = if T.isPrime (toInteger n) then Just (Prime n) else Nothing++instance UniqueFactorisation Integer where+  factorise = coerce . F.factorise+  isPrime n = if T.isPrime n then Just (Prime $ abs n) else Nothing++instance UniqueFactorisation Natural where+  factorise = coerce . F.factorise+  isPrime n = if T.isPrime (toInteger n) then Just (Prime n) else Nothing++-- | Restore a number from its factorisation.+factorBack :: Num a => [(Prime a, Word)] -> a+factorBack = product . map (\(p, k) -> unPrime p ^ k)++-- | Smallest prime, greater or equal to argument.+--+-- > nextPrime (-100) ==    2+-- > nextPrime  1000  == 1009+-- > nextPrime  1009  == 1009+nextPrime :: (Bits a, Integral a, UniqueFactorisation a) => a -> Prime a+nextPrime n+  | n <= 2    = Prime 2+  | n <= 3    = Prime 3+  | n <= 5    = Prime 5+  | otherwise = Inf.head $ mapMaybeInf isPrime $+                  Inf.dropWhile (< n) $ fmap fromWheel30 (toWheel30 n ...)+                  -- dropWhile is important, because fromWheel30 (toWheel30 n) may appear to be < n.+                  -- E. g., fromWheel30 (toWheel30 94) == 97++-- | Largest prime, less or equal to argument. Undefined, when argument < 2.+--+-- > precPrime 100 == 97+-- > precPrime  97 == 97+precPrime :: (Bits a, Integral a, UniqueFactorisation a) => a -> Prime a+precPrime n+  | n < 2     = error "precPrime: tried to take `precPrime` of an argument less than 2"+  | n < 3     = Prime 2+  | n < 5     = Prime 3+  | n < 7     = Prime 5+  | otherwise = Inf.head $ mapMaybeInf isPrime $+                  Inf.dropWhile (> n) $ fmap fromWheel30 ((toWheel30 n, toWheel30 n - 1) ....)+                  -- dropWhile is important, because fromWheel30 (toWheel30 n) may appear to be > n.+                  -- E. g., fromWheel30 (toWheel30 100) == 101++mapMaybeInf :: (a -> Maybe b) -> Infinite a -> Infinite b+mapMaybeInf = Inf.foldr . (maybe id (:<) .)++-------------------------------------------------------------------------------+-- Prime sequences++data Algorithm = IsPrime | Sieve++chooseAlgorithm :: Integral a => a -> a -> Algorithm+chooseAlgorithm from to+  | to <= fromIntegral sieveRange+  && to < from + truncate (sqrt (fromIntegral from) :: Double)+  = IsPrime+  | to > fromIntegral sieveRange+  && to < from + truncate (0.036 * sqrt (fromIntegral from) + 40000 :: Double)+  = IsPrime+  | otherwise+  = Sieve++succGeneric :: (Bits a, Integral a, UniqueFactorisation a) => Prime a -> Prime a+succGeneric = \case+  Prime 2 -> Prime 3+  Prime 3 -> Prime 5+  Prime 5 -> Prime 7+  Prime p -> Inf.head $ mapMaybeInf (isPrime . fromWheel30) ((toWheel30 p + 1) ...)++succGenericBounded+  :: (Bits a, Integral a, UniqueFactorisation a, Bounded a)+  => Prime a+  -> Prime a+succGenericBounded = \case+  Prime 2 -> Prime 3+  Prime 3 -> Prime 5+  Prime 5 -> Prime 7+  Prime p -> case mapMaybe (isPrime . fromWheel30) [toWheel30 p + 1 .. toWheel30 maxBound] of+    []    -> error "Enum.succ{Prime}: tried to take `succ' near `maxBound'"+    q : _ -> q++predGeneric :: (Bits a, Integral a, UniqueFactorisation a) => Prime a -> Prime a+predGeneric = \case+  Prime 2 -> error "Enum.pred{Prime}: tried to take `pred' of 2"+  Prime 3 -> Prime 2+  Prime 5 -> Prime 3+  Prime 7 -> Prime 5+  Prime p -> Inf.head $ mapMaybeInf (isPrime . fromWheel30) ((toWheel30 p - 1, toWheel30 p - 2) ....)++-- 'dropWhile' is important, because 'psieveFrom' can actually contain primes less than p.+enumFromGeneric :: Integral a => Prime a -> [Prime a]+enumFromGeneric p@(Prime p')+  = coerce+  $ dropWhile (< p)+  $ concat+  $ takeWhile (not . null)+  $ map primeList+  $ psieveFrom+  $ toInteger p'++smallPrimesLimit :: Integral a => a+smallPrimesLimit = fromIntegral (maxBound :: Word16)++enumFromToGeneric :: (Bits a, Integral a, UniqueFactorisation a) => Prime a -> Prime a -> [Prime a]+enumFromToGeneric p@(Prime p') q@(Prime q')+  | p' <= smallPrimesLimit, q' <= smallPrimesLimit+  = map (Prime . fromIntegral) $ smallPrimesFromTo (fromIntegral p') (fromIntegral q')+  | p' <= smallPrimesLimit+  = map (Prime . fromIntegral) (smallPrimesFromTo (fromIntegral p') smallPrimesLimit)+  ++ enumFromToGeneric' (nextPrime smallPrimesLimit) q+  | otherwise+  = enumFromToGeneric' p q++enumFromToGeneric'+  :: (Bits a, Integral a, UniqueFactorisation a)+  => Prime a+  -> Prime a+  -> [Prime a]+enumFromToGeneric' p@(Prime p') q@(Prime q') = takeWhile (<= q) $ dropWhile (< p) $+  case chooseAlgorithm p' q' of+    IsPrime -> Prime 2 : Prime 3 : Prime 5 : mapMaybe (isPrime . fromWheel30) [toWheel30 p' .. toWheel30 q']+    Sieve   ->+      if q' < fromIntegral sieveRange+      then           primeList $ primeSieve $ toInteger q'+      else concatMap primeList $ psieveFrom $ toInteger p'++enumFromThenGeneric :: (Bits a, Integral a, UniqueFactorisation a) => Prime a -> Prime a -> [Prime a]+enumFromThenGeneric p@(Prime p') (Prime q') = case p' `compare` q' of+  LT -> filter (\(Prime r') -> (r' - p') `rem` delta == 0) $ enumFromGeneric p+    where+      delta = q' - p'+  EQ -> repeat p+  GT -> filter (\(Prime r') -> (p' - r') `rem` delta == 0) $ reverse $ enumFromToGeneric (Prime 2) p+    where+      delta = p' - q'++enumFromThenToGeneric :: (Bits a, Integral a, UniqueFactorisation a) => Prime a -> Prime a -> Prime a -> [Prime a]+enumFromThenToGeneric p@(Prime p') (Prime q') r@(Prime r') = case p' `compare` q' of+  LT -> filter (\(Prime t') -> (t' - p') `rem` delta == 0) $ enumFromToGeneric p r+    where+      delta = q' - p'+  EQ -> if p' <= r' then repeat p else []+  GT -> filter (\(Prime t') -> (p' - t') `rem` delta == 0) $ reverse $ enumFromToGeneric r p+    where+      delta = p' - q'++instance Enum (Prime Integer) where+  toEnum = nthPrime+  fromEnum = integerToInt . primeCount . unPrime+  succ = succGeneric+  pred = predGeneric+  enumFrom = enumFromGeneric+  enumFromTo = enumFromToGeneric+  enumFromThen = enumFromThenGeneric+  enumFromThenTo = enumFromThenToGeneric++instance Enum (Prime Natural) where+  toEnum = Prime . integerToNatural . unPrime . nthPrime+  fromEnum = integerToInt . primeCount . naturalToInteger . unPrime+  succ = succGeneric+  pred = predGeneric+  enumFrom = enumFromGeneric+  enumFromTo = enumFromToGeneric+  enumFromThen = enumFromThenGeneric+  enumFromThenTo = enumFromThenToGeneric++instance Enum (Prime Int) where+  toEnum n = if p > intToInteger maxBound+    then error $ "Enum.toEnum{Prime}: " ++ show n ++ "th prime = " ++ show p ++ " is out of bounds of Int"+    else Prime (integerToInt p)+    where+      Prime p = nthPrime n+  fromEnum = integerToInt . primeCount . intToInteger . unPrime+  succ = succGenericBounded+  pred = predGeneric+  enumFrom = enumFromGeneric+  enumFromTo = enumFromToGeneric+  enumFromThen = enumFromThenGeneric+  enumFromThenTo = enumFromThenToGeneric++instance Bounded (Prime Int) where+  minBound = Prime 2+  maxBound = precPrime maxBound++instance Enum (Prime Word) where+  toEnum n = if p > wordToInteger maxBound+    then error $ "Enum.toEnum{Prime}: " ++ show n ++ "th prime = " ++ show p ++ " is out of bounds of Word"+    else Prime (integerToWord p)+    where+      Prime p = nthPrime n+  fromEnum = integerToInt . primeCount . wordToInteger . unPrime+  succ = succGenericBounded+  pred = predGeneric+  enumFrom = enumFromGeneric+  enumFromTo = enumFromToGeneric+  enumFromThen = enumFromThenGeneric+  enumFromThenTo = enumFromThenToGeneric++instance Bounded (Prime Word) where+  minBound = Prime 2+  maxBound = precPrime maxBound
Math/NumberTheory/Primes/Counting.hs view
@@ -3,8 +3,6 @@ -- Copyright:   (c) 2011 Daniel Fischer -- Licence:     MIT -- Maintainer:  Daniel Fischer <daniel.is.fischer@googlemail.com>--- Stability:   Provisional--- Portability: non-portable -- -- Number of primes not exceeding @n@, @&#960;(n)@, and @n@-th prime; also fast, but -- reasonably accurate approximations to these.@@ -13,7 +11,6 @@       primeCount     , primeCountMaxArg     , nthPrime-    , nthPrimeMaxArg       -- * Approximations     , approxPrimeCount     , approxPrimeCountOverestimateLimit
Math/NumberTheory/Primes/Counting/Approximate.hs view
@@ -3,13 +3,10 @@ -- Copyright:   (c) 2011 Daniel Fischer -- Licence:     MIT -- Maintainer:  Daniel Fischer <daniel.is.fischer@googlemail.com>--- Stability:   Provisional--- Portability: portable -- -- Approximations to the number of primes below a limit and the -- n-th prime. ---{-# OPTIONS_HADDOCK hide #-} module Math.NumberTheory.Primes.Counting.Approximate     ( approxPrimeCount     , approxPrimeCountOverestimateLimit
+ Math/NumberTheory/Primes/Counting/HowPrimeCountingWorks.md view
@@ -0,0 +1,153 @@+## Algorithm and Implementation Description++### History and Formulas++This prime counting implementation is based on the work by Adrien-Marie Legendre, who in about the year 1800 observed that the count of the primes to a limit, Pi(limit), can be determined by the inclusion-exclusion principle as noted at the following link:++https://en.wikipedia.org/wiki/Prime-counting_function#Algorithms_for_evaluating_%CF%80(x)++In analysis of this series, it can be seen that it is also an expression of what the Sieve of Eratosthenes does when extended to become the Wheel Sieve where no composite number is culled more than once since the products of the unique primes must always be unique.  Note that the terms with the product of odd numbers of primes on the denominator are subtracted and with even primes are added:  thus the inclusion/exclusion principle.  This expression can then be expressed recursively using a "Phi" expression as follows:++Phi(m, n) = Phi(m, n - 1) - Phi(floor(m / pn), n - 1) where+  `m` is the current limit for this "branch" of the Phi function and+  `n` is the one-based index of the nth prime so p1 is 2, p2 is 3, etc+     and with the terminating conditions that+       Phi(0, n) is 0 and Phi(m, 0) is m.++Now the Legendre formula for the prime count, Pi(limit), is as follows:++Pi(limit) = Phi(limit, Pi(sqrt(limit))) + Pi(sqrt(limit)) - 1++where from this it can be seen that one needs only know the primes to the square root of the range to be counted (and thus the number of them).++The above recursive solution is quite inefficient as to complexity due to the deeply nested recursion, but a further terminating condition can stop the splitting of the "tree" a little sooner as follows:++Phi(m, n) when m is less than or equal to pn must be exactly one++This can be seen to be true because Phi(m, n) expresses the number of values up to `m` that cannot be divided evenly by any of the primes up to `pn` (this includes one, which can't be divided evenly by all numbers higher than it), thus excludes the sieving primes in the range p1 to pn. Therefore, the Phi value for any `m` <= `pn` must be just one.++The computational complexity of this recursive expression is as follows:++O(limit/((log limit)^2)), which while lower than by the Sieve of Eratosthenes due to the log squared in the denominator, is practically quite slow due to the high cost of the multiple recursions and (long) divisions.++However, it has been realized quite recently (1985) that one does not have to solve that expression recursively by, instead of starting from the top of the "tree" and "splitting" first by the larger primes and building up the prime products down to the lowest primes, one can start at the bottom of the "tree" and divide by the lowest prime first on up; also, one can do all of the divisions by each of the primes in partial sieving "waves" while retaining the results in an array of intermediate results which replace the recursive method's "stack".  One then finds that the results of all of the prime products already exist in the as yet unculled values in the partial sieved passes, greatly reducing the amount of computation (especially divisions) of having to build up these prime products from individual primes.++"Phi's" as described are closely related to "rough" numbers, which are the values remaining after culling of all multiples of base primes up to some "partial sieving" base prime and including a count for the one value, so the number of rough numbers up to a limit sieved by primes up to pn is exactly Phi(that limit, n). Using an array of rough numbers and a parallel array of the Phi's (or Pi's) for each of those rough numbers is an efficient way to organize the intermediate calculations.++Note that Phi's and Pi's are also closely related and can be converted one to the other because:++Phi(x, Pi(sqrt(x))) = Pi(x) - Pi(sqrt(x)) + 1++Rough numbers: https://en.wikipedia.org/wiki/Rough_number.Applicative++### Method++In general, the method is as follows:++1. All arrays are of size the square root of the counting range limit, as follows:++    a. A `roughs` array to process the remaining rough numbers in culling waves, initialized to all odds starting from 1 (ie. 1, 3, ...),++    b. A `phis` array which contains counts of remaining values after culling up to some level of base prime but is used for emulating the stack during processing initialized with the values as culled by two as in ((`limit`/roughs[`i`] + 1) `div` 2) where `i` is the zero-base index, and++    c. A `pisndxs` array that also contains a simple count of values remaining after culling up to a given culling base prime level but is in `Pi` form with the representations of the already culled base primes included in the count, and with no count for 1 just as for a normal pi; this is initialized with the index numbers as in (0, 1, ...).++    d. Variables are initialized to track the number of base primes processed initialized to zero as well as the current effective size of the `roughs`/`pis` arrays initialized to their current total size.+++   The `pisndxs` array and the `roughs` array are closely related to each other in that if one takes a given rough value at a given index, divides that rough value by two and uses the quotient as an index to this array will produce an element value that when the number of (odd) base primes already used is subtracted, produces the index in the roughs array of the original roughs element to form a connected loop; also, this array is used to look up "Pi" values that are used to add and subtract the counts in the manner as described for the phi/pi calculation.  The implementation tries to reduce the number of offsets added and subtracted in the "hottest" loops.++2. The main loop takes the following recursive "bottom-up" function and+   flattens it by using the `pis` array to replace the stack used+   by this function:++   For the following function `baseprms` is an array of odd primes plus non-prime one and values from three up to the square root limit from above.++   ```haskell+   phip2 x = (x + 1) / 2++   phi pmult pilmt =+     let looppi pi acc =+        if pi >= pilmt then acc else+        p = unsafeAt baseprms pi+        npmult = pmult * p+        -- special termination condition for when p >= limit / npmult...+        if p * npmult >= limit then acc + pilmit - pi+        else looppi (pi + 1)+                    (acc + phip2(limit / npmult) - phi npmult pi) -- recursion+   ```++   Phi(limit (Pi(sqrt(limit))) is the above function called with:+   phi 1 (length paseprms).++   Using the recursive function is not efficient because it doesn't have the asymptotic improvements to performance due to partial sieving.++   The loop is for each "base prime" in succession up to the square root of the square root of the `limit` in three phases:++     a. the given base prime value and all multiples of it are marked to be culled if they haven't already been eliminated in previous passes by something like the Sieve of Eratosthenes culling pass per base prime.++     b. this phase processes each of the remaining `roughs` values in turn for all remaining after being marked and splits the processing depending on whether the base prime value multiplied by the remaining rough element is:++    - less than or equal to the square root limit, in which case it compresses the `roughs` and `pis` array by subtracting the next `pis` element from the current one and writing it into an index that doesn't included the marked/skipped elements, or++    - if greater than it subtracts a value looked up by rough value index in the `pisndxs` array and again writes the result into the compression index as per above.++    - in all cases it moves the `roughs` to synchronizes with the pi's indices to move values to the left to fill the holes left by eliminating the marked rough values.++     c. the last phase is to adjust pisndxs values so they address the correct rough/pis values after the above compression of these arrays has taken place.++3. The partial sieving loop only runs the base prime values up to the square root of the square root of the limit; after that point all of the roughs are prime (other than one) and therefore, the `limit` divided by each of the unique products of pairs of these roughs are added to the final answer from the loop with the usual procedure of looking up the values to be added from the `pisndx` array by using as an index: toIndex (limit / p1 / p2) but with the limitation that p1 can not be larger than (limit / p1 / p1) which satisfies the terminating condition that `p1` must be less than or equal to the quotient:++   `limit` `div` `pi` `div` `p1`.++4. There are various offset calculations and compenstation to make sure allowance has be made for the various conversions between Phi and Pi.++### Detailed Method++In more detail, the "bottom up" partial sieving method is as follows; this implementeds the odds-only optimization so the arrays represent only the odd numbers:++1. Keep track of the number of base primes that have been processed yet and the current effective number of rough numbers; INITIALIZE `y` as the square root of the limit and three arrays each of the size `y`, with the first small counts array keeping track of the current number of possible primes up to the number represented by the index value so initialized with each element containing the index value, the second the roughs array containing the current level zero rough numbers as per the current culling passes (starts with nothing culled, so all odd values could be prime), and finally, the third containing the current Phi's/ (Pi's in this case) for each rough number in the rough numbers array (initially limit divided by the rough value corresponding to the index).++2. For each base prime in order from the lowest to the limit^(1/4) (same as the square root of `y`) do the following:++    a. Do a partial sieve culling pass of the composites boolean array by the Sieve of Eratosthenes marking all multiples of the current base prime, also marking the value representing the current base prime as "non rough".  The marked values will be those that can't be rough number.++    b. Update the Phi's table for each value that is still rough, while+    eliminating and removing them from the array of roughs by moving them down the table (to the left, to lower indices).  The adjustment is done differently depending whether the product of the base prime and the current rough is greater than the cube root of the limit (where limit divided by this product would be less than the square root of the limit and the counts can be just looked up in the counts table) or less than or equal to the square root in which case they can't be looked up in the counts table; however, the value in the counts table can be looked up in the counts table and that can be used to loop up the adjustment value in the phis table.  All adjustments are subtracted from the current value of the phis table and, since all accumulated phi values will be subtracted from the first accumulation in the phi table, has the effect of subtracting for the first partial sieve pass, adding for the seconds, subtracting for the third, and so on, thus implementing the inclusion/exclusion principle.++    c. Adjust the counts table so the counts reflect the rough values culled in the last partial sieve culling pass.++    d. Repeat all above steps of the stop 2x steps for each base prime up to the limit where the rough values have been fully sieved, adjusting the number of base primes and the effective used sizes of the roughs and phis arrays for every pass.++3. All the accumulated phis from the roughs higher than one can be subtracted from the accumulated phi for one to get an amalgamated answer which is still not complete, as per the last steps.  At this point there are no further changes made to the counts, roughs, or phis arrays.++4. The remaining base primes are now all higher than the the square root of `y` and the remaining roughs higher than these base primes are all prime so the following results can all be added (add for even number of primes in the denominator product - inclusion).  Also, these products are all higher than `y` so the square root of the limit, so all counts can now be looked up in the counts table as follows:++   For each base prime from above the `y`^(1/2) to limit^(1/3) value multiplied by each value above the first to just below `y`` such that the product of the first prime squared and second primes is never higher than the limit (the terminal condition that Phi(0, n) is 0), divide the limit by this product and use the quotient to index the counts value to be added to the answer.++5. The final answer can be obtained by doing any necessary conversions from Phi to Pi.++There are some additional offset and compensation adjustments to make the array indexing and final reaults work out right, especially adjusting for whether particular count/phi values included the current base primes or not; these are negligible in computing cost.++### Asymptotic Complexity++It can easily be seen that the memory requirements are proportional to the square root of the limit; however, the computational complexity isn't quite so obvious as follows:++1. All of the 3a steps represent a Sieve of Eratosthenes to the square root of the limit, so `y` times log log `y`); this is close enough to `y` and the operations are fast, so this is not a significant portion of the time used.++2. All of the 3b steps take the number of base primes to the square root of `y` or `y`^(1/2)/(log (`y`^(1/2))) or 2*`y`^(1/2)/(log `y`) times the number of roughs which quickly reduces to about `y`/log`y` so the product is 2*`y`^(3/2)/((log `y`)^2) or 8*`limit`^(3/4)/((log `limit`)^2).  For large limits, this is clearly a stronger term than the first.++3. All of the 3c stops are the product of all the base primes to the square root of `y` as above times almost all of the counts values (of size `y`) so this is 2*`y`^(3/2)/(log `y`) or 4*`limit`^(3/4)/(log `limit`), which makes this a slightly stronger term than that of 2 above due to the loss of a log factor on the dividend; however, the operations of this step are faster than those of step 2 because step 2 has divisions for almost all operations, so these two may be effectively about the same until large\counting ranges when this term will be the strongest.++4. The operations of step 4 would takes a long time at `limit`/((log `y`)^2) but are saved by the terminating condition when p >= `limit`/`p`/`p` so are about `y`^(4/3)/((log `y`)^2) or 4*`limit`^(2/3)/((log `limit`)^2), meaning that it is considerably less strong than the operations of step 2, although also slightly more complex.++5. Thus, the time complexity is likely mostly controlled by step 2 for smaller counting ranges and by step 3 for large counting ranges meaning that the asymptotic time complexity is about that of 3, which lacks one log factor on the denominator due to having to process most of the count array values for each base prime pass.  Thus the asymptotic complexity for large ranges can be expressed as O(limit^(3/4)/(log limit)), although the epirical complexity won't approach that for the ranges where this algorithm is usable due to memory use constraints.++This implementation only deals with odd values (1, 3, 5 ...), thereby reducing memory storage requirements by a factor of two.++### Conclusions++In short, this is an effective implementation of the Legendre algorithm because any of the "Phi" values for the products of unique primes have already been computed simply and are available in the arrays where this isn't available for the fully recursive expression (for instance, the limit/(p1*p2*P3) value will be immediately available where the recursive expression would have to build it+up from all the combinations of limit/(p1*p2), limit/(p1*p3), and limit/(p2*p3), and so on for longer chains of base prime products).++The worst problem with this algorithm and implementation is its relatively high memory use of O(limit^(1/2)) which in this case is eight times the square root of the counting range in bytes. This means that to sieve to 1e16 takes about 800 Megabytes and to the theoretical maximum limit of 2^19 - 1 would take about 32 Gigabytes, even if one were willing to wait the hours required to return a result.  For such larger counting ranges, there are much better algorithms that aren't that much more difficult to implement, such as a variation on this with the Daniel Friedrich Ernst Meissel modification in about 1870 to change `y` to the cube root of the counting range instead of the square root to use memory as the cube root of the counting range and somewhat improve on the execution asymptotic complexity to proportial to the limit to the two thirds power.
Math/NumberTheory/Primes/Counting/Impl.hs view
@@ -3,96 +3,258 @@ -- Copyright:   (c) 2011 Daniel Fischer -- Licence:     MIT -- Maintainer:  Daniel Fischer <daniel.is.fischer@googlemail.com>--- Stability:   Provisional--- Portability: non-portable ----- Number of primes not exceeding @n@, @&#960;(n)@, and @n@-th prime.+-- Number of primes not exceeding @limit@, @&#960;(limit)@, and @n@-th prime. ---{-# LANGUAGE CPP, BangPatterns, FlexibleContexts #-}+{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE ScopedTypeVariables #-}++{-# OPTIONS_GHC -O2 #-} {-# OPTIONS_GHC -fspec-constr-count=24 #-}-{-# OPTIONS_HADDOCK hide #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+ module Math.NumberTheory.Primes.Counting.Impl     ( primeCount     , primeCountMaxArg     , nthPrime-    , nthPrimeMaxArg     ) where -#include "MachDeps.h"- import Math.NumberTheory.Primes.Sieve.Eratosthenes-import Math.NumberTheory.Primes.Sieve.Indexing-import Math.NumberTheory.Primes.Counting.Approximate-import Math.NumberTheory.Powers.Squares-import Math.NumberTheory.Powers.Cubes-import Math.NumberTheory.Logarithms-import Math.NumberTheory.Unsafe--import Data.Array.ST-import Control.Monad.ST-import Data.Bits-import Data.Int+                             (PrimeSieve(..), primeSieve, psieveFrom)+import Math.NumberTheory.Primes.Sieve.Indexing (toPrim)+import Math.NumberTheory.Primes.Counting.Approximate (nthPrimeApprox)+import Math.NumberTheory.Primes.Types+import Math.NumberTheory.Roots (integerSquareRoot)+import Math.NumberTheory.Utils.FromIntegral -#if SIZEOF_HSWORD < 8-#define COUNT_T Int64-#else-#define COUNT_T Int-#endif+import Data.Word (Word64, Word32)+import Data.Bits (Bits(shiftR, (.&.), (.|.)))+import Control.Monad (forM_, when)+import Control.Monad.ST (ST, runST)+import Data.Array.Base (STUArray, MArray(unsafeNewArray_),+                        unsafeAt, unsafeFreezeSTUArray, unsafeRead, unsafeWrite)+import Data.Bit (Bit(..), unBit, nthBitIndex, countBits)+import qualified Data.Vector.Unboxed as U  -- | Maximal allowed argument of 'primeCount'. Currently 8e18. primeCountMaxArg :: Integer primeCountMaxArg = 8000000000000000000 --- | @'primeCount' n == &#960;(n)@ is the number of (positive) primes not exceeding @n@.+-- | @'primeCount' limit == &#960;(limit)@ is the number of primes not exceeding @limit@. -----   For efficiency, the calculations are done on 64-bit signed integers, therefore @n@ must---   not exceed 'primeCountMaxArg'.+--   For efficiency, the calculations are done on 64-bit unsigned integers, therefore @limit@+--   must not exceed 'primeCountMaxArg'. -----   Requires @/O/(n^0.5)@ space, the time complexity is roughly @/O/(n^0.7)@.---   For small bounds, @'primeCount' n@ simply counts the primes not exceeding @n@,---   for bounds from @30000@ on, Meissel's algorithm is used in the improved form due to---   D.H. Lehmer, cf.---   <http://en.wikipedia.org/wiki/Prime_counting_function#Algorithms_for_evaluating_.CF.80.28x.29>.+--   Requires @/O/(limit^0.5)@ space, the time complexity is roughly @/O/(limit^0.7)@.+--   @'primeCount' limit@ uses Legendre's algorithm in an improved form using "partial sieving"+--   and processing by "splitting" based on whether the product of the "base prime" and a+--   product of higher co-primes is less than or equal to, or greater than the square root of+--   @limit@ where "base primes" are lower than the square root of the square root of @limit@;+--   above this limit all remaining values are primes so are used in unique prime pairs to+--   calculate the additional amounts to add to the accumulated "Phi" for the answer.++--   NOTE: This is not related to the later work (about 1870) by Daniel Friedrich Ernst Meissel,+--   nor the extension to Meissel's work by Professor D. H. Lehmer in 1959 to adapt these types+--   of algorithms to use on a mainframe computer of that time; both of whose purpose was to+--   reduce the number of calculations for a given counting range and/or reduce the storage+--   requirements.  Neither of these used "partial sieving" to get anywhere near the asymptotic+--   complexity of this implementation.++--   See the "HowPrimeCountingWorks.md" file in this directory for a more complete explanation+--   of how this implementation works.+ primeCount :: Integer -> Integer-primeCount n-    | n > primeCountMaxArg = error $ "primeCount: can't handle bound " ++ show n-    | n < 2     = 0-    | n < 1000  = fromIntegral . length . takeWhile (<= n) . primeList . primeSieve $ max 242 n-    | n < 30000 = runST $ do-        ba <- sieveTo n-        (s,e) <- getBounds ba-        ct <- countFromTo s e ba-        return (fromIntegral $ ct+3)-    | otherwise =-        let !ub = cop $ fromInteger n-            !sr = integerSquareRoot' ub-            !cr = nxtEnd $ integerCubeRoot' ub + 15-            nxtEnd k = k - (k `rem` 30) + 31-            !phn1 = calc ub cr-            !cs = cr+6-            !pdf = sieveCount ub cs sr-        in phn1 - pdf+primeCount limit+  | limit > primeCountMaxArg = error $ "primeCount: can't handle bound " ++ show limit+  | limit < 9 = if limit < 2 then 0 else (limit + 1) `div` 2+  | otherwise =+  let+    +    -- initialize constants...+    ilimit = fromIntegral limit+    sqrtlmt = fromIntegral $ integerSquareRoot ilimit+    sqrtsqrtlmt = integerSquareRoot sqrtlmt+    maxndx = toIndex sqrtlmt -- last index of arrays --- | Maximal allowed argument of 'nthPrime'. Currently 1.5e17.-nthPrimeMaxArg :: Integer-nthPrimeMaxArg = 150000000000000000+    -- `numbps` will be the number of odd base primes up to `limit`^(1/4);+    -- `roughssz` is the current effective length of `roughs` after reduction;+    -- `phindxs` is the count of odd primes to limit by index not including bps,+    --    the above is an index to the `roughs`/`phis` that repr the index;+    -- `roughs` are the values remaining after culling base primes < its index,+    --    the above values when divided by two is the index for `phindxs`;+    -- `phis` is count of odd primes to a limit set by its index...+    (numbps, roughssz, phindxs, roughs, phis) = runST $ do -- run in ST monad... +      -- initialize monadic versions of `phindxs`/`roughs`/`phis`...+      mphindxs <- unsafeNewArray_ (0, maxndx) :: ST s (STUArray s Int Word32)+      -- initially is odd phi of the index repr 3 shr 1 is 1 -> value 1, etc...+      forM_ [ 0 .. maxndx ] $ \ i -> unsafeWrite mphindxs i (fromIntegral i)+      unsafeWrite mphindxs 0 1 -- for correctness, never used!+      mrs <- unsafeNewArray_ (0, maxndx) :: ST s (STUArray s Int Word32)+      -- odd values from 1 as in 1, 3 ... to maximum for roughs...+      forM_ [ 0 .. maxndx ] $ \ i ->+        unsafeWrite mrs i (fromIntegral i * 2 + 1)+      mphis <- unsafeNewArray_ (0, maxndx) :: ST s (STUArray s Int Word64)+      -- initialized to limit // roughs; are phis including count for one...+      forM_ [ 0 .. maxndx ] $ \ i -> do+        r <- unsafeRead mrs i; let d = fromIntegral r+        unsafeWrite mphis i (fromIntegral $ phip2 $ divide ilimit d)++      -- all work requiring modifying arrays and values done recursively here;+      -- the "partial sieving" loop with one `bp` sieving pass per loop;+      -- uses `roi` output and `rii` input roughs processing indices...+      let loop !nbps !rsilmt = do -- `rslmt` is maximum current ndx for `roughs`+            bpw32 <- unsafeRead mrs 1+            let bp = fromIntegral bpw32+            if bp > sqrtsqrtlmt then do -- means `bp` primes <= limit^(1/4)+              fmsops <- unsafeFreezeSTUArray mphindxs+              fmrs <- unsafeFreezeSTUArray mrs+              fmlops <- unsafeFreezeSTUArray mphis+              return (nbps, rsilmt + 1, fmsops, fmrs, fmlops) -- done loop!+            else do -- for each base prime `bp`...+                let -- mark `mrs` values that are multiples of bp if still there+                    cullmrs cullpos =+                      if cullpos > sqrtlmt then return () else do+                        cnt <- unsafeRead mphindxs (cullpos `shiftR` 1)+                        let ndx = fromIntegral cnt - nbps+                        tstr <- unsafeRead mrs ndx+                        when (tstr == fromIntegral cullpos)+                          (unsafeWrite mrs ndx 0)+                        cullmrs (cullpos + bp + bp)++                    -- recursive function to process all remaining `mrs` by+                    -- forming products of unique pairs with `bp`...+                    split rii !roi =+                      if rii > rsilmt then return (roi - 1) else do+                        m <- unsafeRead mrs rii -- multiplier may not be prime!+                        if m == 0 then split (rii + 1) roi else do -- skip marked+                          -- only unculled values; may not be prime+                          olv <- unsafeRead mphis rii -- large odd "pi" to adjust+                          let mbp = fromIntegral m * fromIntegral bp+                          adjv <- -- depends on condition...+                            if mbp <= fromIntegral sqrtlmt then do+                              -- ilimit `div` mbp too large...+                              let cnti = fromIntegral mbp `shiftR` 1+                              adji <- unsafeRead mphindxs cnti+                              let adjndx = fromIntegral adji - nbps+                              unsafeRead mphis adjndx+--                              adj <- unsafeRead mphis adjndx+--                              return $ adj - fromIntegral nbps+                            else do+                              -- ilimit `div` mbp in index range; use directly!+                              let adjndx = toIndex (divide ilimit mbp)+                              adj <- unsafeRead mphindxs adjndx -- phi form...+                              return $ fromIntegral adj - fromIntegral nbps + 1+                          -- write adjusted value into `mphis` at new offset...+                          unsafeWrite mphis roi (olv - adjv)+                          unsafeWrite mrs roi m -- move rougn values in sync+                          split (rii + 1) (roi + 1) -- recursively loop ++                    -- update `mphindxs` array for last cull pass...+                    adjcnt cm !mxci = -- cull multiple and maximum index+                      if cm < bp then return () else do+                        ofstc <- unsafeRead mphindxs (cm `shiftR` 1)+                        let c = ofstc - fromIntegral nbps+                            e = (cm * bp) `shiftR` 1+                            adjci ci =+                              if ci < e then adjcnt (cm - 2) ci else do+                                ov <- unsafeRead mphindxs ci+                                unsafeWrite mphindxs ci (ov - c)+                                adjci (ci - 1)+                        adjci mxci+                +                -- the code that uses the above "let"'s...+                unsafeWrite mrs 1 0 -- mark first non-one rough for deletion+                cullmrs (bp * bp) -- mark the other rough multiples of `bp`+                maxrsi <- split 0 0 -- adjust `roughs` and `phis` for cull+                let topcullpnt = (sqrtlmt `div` bp - 1) .|. 1 -- odd <= sqrtlmt+                adjcnt topcullpnt maxndx -- update `phindxs` for culling pass+                loop (nbps + 1) maxrsi -- recurse for all base primes++      loop 0 maxndx -- calling recursive "partial sieving" loop!++    -- the offset of the sum of the other `phis`...+    othroddpis = sum [ unsafeAt phis bpi | bpi <- [ 1 .. roughssz - 1 ] ]+    -- subtracted from the first first element of `phis`...+    phi0 = unsafeAt phis 0 - othroddpis -- + pi0crct -- to produce an intermediate phi+    +    -- recursively calculate the additional odd "phis" for all pairs of+    -- unique primes/`roughs` starting above limit^(1/4) to limit^(1/2);+    -- these are exactly the remaining values in `roughs` above the "one";+    -- Note that all roughs above the first "one" element are now prime;+    -- pre-comp of all additional ones for following "pairs" calculation...+    phi0adj = fromIntegral $ (roughssz - 2) * (roughssz - 1) `div` 2+    accum p1i !ans =+      if p1i >= roughssz - 1 then ans else -- for all roughs skipping "one"...+      let p1 = fromIntegral $ unsafeAt roughs p1i -- `p1` - first of prime pair+          qp1 = ilimit `div` p1 -- pre divide for "p1" value+          ndx = unsafeAt phindxs (toIndex (fromIntegral (qp1 `div` p1)))+          endndx = fromIntegral ndx - numbps -- last `p1` index!+          adj = fromIntegral $ (endndx - p1i) * (numbps + p1i - 1)+          comp p2i !ac = -- `rii` is index of the second of the `roughs`+            if p2i > endndx then accum (p1i + 1) ac else -- exit if reach end index!+            let p2 = fromIntegral (unsafeAt roughs p2i) -- second rough+                cnti = toIndex (divide qp1 p2) -- ndx for comp "pi"+            in comp (p2i + 1) (ac + fromIntegral (unsafeAt phindxs cnti))+      in if endndx <= p1i then ans -- terminate if `p1`^3 >= `ilimit`!+         -- adjust for ones added and not used due to `endndx` termination...+         else comp (p1i + 1) (ans - adj)++    numsqrtprms = fromIntegral $ numbps + roughssz++  -- finally call addition of the phis for all pairs of unique primes added to+  -- the offset of the other odd "phis" already adjusted for the subtracting+  -- of odd "phis" from odd "phis" plus the total primes to the square root of+  -- the `limit` counting range minus one according to the formula...+  in fromIntegral $ accum 1 (phi0 + phi0adj) + numsqrtprms - 1++--------------------------------------------------------------------------------+--                               Auxiliaries                                  --+--------------------------------------------------------------------------------++{-# INLINE divide #-}+divide :: Word64 -> Word64 -> Int+divide n d = fromIntegral $ n `div` d++{-# INLINE phip2 #-}+phip2 :: Int -> Int+phip2 x = (x + 1) `shiftR` 1    ++{-# INLINE toIndex #-}+toIndex :: Int -> Int+toIndex x = (x - 1) `shiftR` 1++--------------------------------------------------------------------------------+--                                Nth Prime                                   --+--------------------------------------------------------------------------------+ -- | @'nthPrime' n@ calculates the @n@-th prime. Numbering of primes is --   @1@-based, so @'nthPrime' 1 == 2@. -- --   Requires @/O/((n*log n)^0.5)@ space, the time complexity is roughly @/O/((n*log n)^0.7@.---   The argument must be strictly positive, and must not exceed 'nthPrimeMaxArg'.-nthPrime :: Integer -> Integer+--   The argument must be strictly positive.+nthPrime :: Int -> Prime Integer+nthPrime 1 = Prime 2+nthPrime 2 = Prime 3+nthPrime 3 = Prime 5+nthPrime 4 = Prime 7+nthPrime 5 = Prime 11+nthPrime 6 = Prime 13 nthPrime n-    | n < 1         = error "Prime indexing starts at 1"-    | n > nthPrimeMaxArg = error $ "nthPrime: can't handle index " ++ show n-    | n < 200000    = nthPrimeCt n-    | ct0 < n       = tooLow n p0 (n-ct0) approxGap-    | otherwise     = tooHigh n p0 (ct0-n) approxGap+    | n < 1+    = error "Prime indexing starts at 1"+    | n < 200000+    = Prime $ countToNth (n - 3) [primeSieve (p0 + p0 `quot` 32 + 37)]+    | p0 > toInteger (maxBound :: Int)+    = error $ "nthPrime: index " ++ show n ++ " is too large to handle"+    | miss > 0+    = Prime $ tooLow  n (fromInteger p0) miss+    | otherwise+    = Prime $ tooHigh n (fromInteger p0) (negate miss)       where-        p0 = nthPrimeApprox n-        approxGap = (7 * fromIntegral (integerLog2' p0)) `quot` 10-        ct0 = primeCount p0+        p0 = nthPrimeApprox (toInteger n)+        miss = n - fromInteger (primeCount p0)  -------------------------------------------------------------------------------- --                                The Works                                   --@@ -102,293 +264,54 @@ -- Not too pressing, since I think a) nthPrimeApprox always underestimates -- in the range we can handle, and b) it's always "goodEnough" -tooLow :: Integer -> Integer -> Integer -> Integer -> Integer-tooLow n a miss gap-    | goodEnough    = lowSieve a miss-    | c1 < n        = lowSieve p1 (n-c1)-    | otherwise     = lowSieve a miss   -- a third count wouldn't make it faster, I think-      where-        est = miss*gap-        p1  = a + (est * 19) `quot` 20-        goodEnough = 3*est*est*est < 2*p1*p1    -- a second counting would be more work than sieving-        c1  = primeCount p1+tooLow :: Int -> Int -> Int -> Integer+tooLow n p0 shortage+  | p1 > toInteger (maxBound :: Int)+  = error $ "nthPrime: index " ++ show n ++ " is too large to handle"+  | goodEnough+  = lowSieve p0 shortage+  | c1 < n+  = lowSieve (fromInteger p1) (n-c1)+  | otherwise+  = lowSieve p0 shortage   -- a third count wouldn't make it faster, I think+  where+    gap = truncate (log (intToDouble p0 :: Double))+    est = toInteger shortage * gap+    p1  = toInteger p0 + est+    goodEnough = 3*est*est*est < 2*p1*p1    -- a second counting would be more work than sieving+    c1  = fromInteger (primeCount p1) -tooHigh :: Integer -> Integer -> Integer -> Integer -> Integer-tooHigh n a surp gap-    | c < n     = lowSieve b (n-c)-    | otherwise = tooHigh n b (c-n) gap-      where-        b = a - (surp * gap * 11) `quot` 10-        c = primeCount b+tooHigh :: Int -> Int -> Int -> Integer+tooHigh n p0 surplus+  | c < n+  = lowSieve b (n-c)+  | otherwise+  = tooHigh n b (c-n)+  where+    gap = truncate (log (intToDouble p0 :: Double))+    b = p0 - (surplus * gap * 11) `quot` 10+    c = fromInteger (primeCount (toInteger b)) -lowSieve :: Integer -> Integer -> Integer+lowSieve :: Int -> Int -> Integer lowSieve a miss = countToNth (miss+rep) psieves       where-        strt = if (fromInteger a .&. (1 :: Int)) == 1-                 then a+2-                 else a+1-        psieves@(PS vO ba:_) = psieveFrom strt+        strt = a + 1 + (a .&. 1)+        psieves@(PS vO ba:_) = psieveFrom (toInteger strt)         rep | o0 < 0    = 0-            | otherwise = sum [1 | i <- [0 .. r2], ba `unsafeAt` i]+            | otherwise = sum [1 | i <- [0 .. r2], unBit (ba `U.unsafeIndex` i)]               where-                o0 = strt - vO - 9   -- (strt - 2) - v0 - 7+                o0 = toInteger strt - vO - 9   -- (strt - 2) - v0 - 7                 r0 = fromInteger o0 `rem` 30                 r1 = r0 `quot` 3                 r2 = min 7 (if r1 > 5 then r1-1 else r1) --- highSieve :: Integer -> Integer -> Integer -> Integer--- highSieve a surp gap = error "Oh shit"--sieveCount :: COUNT_T -> COUNT_T -> COUNT_T -> Integer-sieveCount ub cr sr = runST $ 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-          | ri == sieveBits = case sves of-                                (PS vO ba : more) -> feed (fromInteger vO) wi 0 ba more-                                _ -> error "prime stream ended prematurely"-          | pval > sr   = do-              stu <- unsafeThaw uar-              eat 0 0 voff (wi-1) ri stu sves-          | uar `unsafeAt` ri = do-              unsafeWrite store wi (ub `quot` pval)-              feed voff (wi+1) (ri+1) uar sves-          | otherwise = feed voff wi (ri+1) uar sves-            where-              pval = voff + toPrim ri-        eat !acc !btw voff !wi !si stu sves-            | si == sieveBits =-                case sves of-                  [] -> error "Premature end of prime stream"-                  (PS vO ba : more) -> do-                      nstu <- unsafeThaw ba-                      eat acc btw (fromInteger vO) wi 0 nstu more-            | wi < 0    = return acc-            | otherwise = do-                qb <- unsafeRead store wi-                let dist = qb - voff - 7-                if dist < fromIntegral sieveRange-                  then do-                      let (b,j) = idxPr (dist+7)-                          !li = (b `shiftL` 3) .|. j-                      new <- if li < si then return 0 else countFromTo si li stu-                      let nbtw = btw + fromIntegral new + 1-                      eat (acc+nbtw) nbtw voff (wi-1) (li+1) stu sves-                  else do-                      let (cpl,fds) = dist `quotRem` fromIntegral sieveRange-                          (b,j) = idxPr (fds+7)-                          !li = (b `shiftL` 3) .|. j-                          ctLoop !lac 0 (PS vO ba : more) = do-                              nstu <- unsafeThaw ba-                              new <- countFromTo 0 li nstu-                              let nbtw = btw + lac + 1 + fromIntegral new-                              eat (acc+nbtw) nbtw (fromIntegral vO) (wi-1) (li+1) nstu more-                          ctLoop lac s (ps : more) = do-                              !new <- countAll ps-                              ctLoop (lac + fromIntegral new) (s-1) more-                          ctLoop _ _ [] = error "Primes ended"-                      new <- countFromTo si (sieveBits-1) stu-                      ctLoop (fromIntegral new) (cpl-1) sves-    case psieves of-      (PS vO ba : more) -> feed (fromInteger vO) 0 0 ba more-      _ -> error "No primes sieved"--calc :: COUNT_T -> COUNT_T -> Integer-calc lim plim = runST $ do-    !parr <- sieveTo (fromIntegral plim)-    (plo,phi) <- getBounds parr-    !pct <- countFromTo plo phi parr-    !ar1 <- unsafeNewArray_ (0,end-1)-    unsafeWrite ar1 0 lim-    unsafeWrite ar1 1 1-    !ar2 <- unsafeNewArray_ (0,end-1)-    let go cap pix old new-            | pix == 2  =   coll cap old-            | otherwise = do-                isp <- unsafeRead parr pix-                if isp-                    then do-                        let !n = fromInteger (toPrim pix)-                        !ncap <- treat cap n old new-                        go ncap (pix-1) new old-                    else go cap (pix-1) old new-        coll stop ar =-            let cgo !acc i-                    | i < stop  = do-                        !k <- unsafeRead ar i-                        !v <- unsafeRead ar (i+1)-                        cgo (acc + fromIntegral v*cp6 k) (i+2)-                    | otherwise = return (acc+fromIntegral pct+2)-            in cgo 0 0-    go 2 start ar1 ar2-  where-    (bt,ri) = idxPr plim-    !start = 8*bt + ri-    !size = fromIntegral $ (integerSquareRoot lim) `quot` 4-    !end = 2*size--treat :: Int -> COUNT_T -> STUArray s Int COUNT_T -> STUArray s Int COUNT_T -> ST s Int-treat end n old new = do-    qi0 <- locate n 0 (end `quot` 2 - 1) old-    let collect stop !acc ix-            | ix < end  = do-                !k <- unsafeRead old ix-                if k < stop-                    then do-                        v <- unsafeRead old (ix+1)-                        collect stop (acc-v) (ix+2)-                    else return (acc,ix)-            | otherwise = return (acc,ix)-        goTreat !wi !ci qi-            | qi < end  = do-                !key <- unsafeRead old qi-                !val <- unsafeRead old (qi+1)-                let !q0 = key `quot` n-                    !r0 = fromIntegral (q0 `rem` 30030)-                    !nkey = q0 - fromIntegral (cpDfAr `unsafeAt` r0)-                    nk0 = q0 + fromIntegral (cpGpAr `unsafeAt` (r0+1) + 1)-                    !nlim = n*nk0-                (wi1,ci1) <- copyTo end nkey old ci new wi-                ckey <- unsafeRead old ci1-                (!acc, !ci2) <- if ckey == nkey-                                  then do-                                    !ov <- unsafeRead old (ci1+1)-                                    return (ov-val,ci1+2)-                                  else return (-val,ci1)-                (!tot, !nqi) <- collect nlim acc (qi+2)-                unsafeWrite new wi1 nkey-                unsafeWrite new (wi1+1) tot-                goTreat (wi1+2) ci2 nqi-            | otherwise = copyRem end old ci new wi-    goTreat 0 0 qi0-------------------------------------------------------------------------------------                               Auxiliaries                                  -------------------------------------------------------------------------------------locate :: COUNT_T -> Int -> Int -> STUArray s Int COUNT_T -> ST s Int-locate p low high arr = do-    let go lo hi-          | lo < hi     = do-            let !md = (lo+hi) `quot` 2-            v <- unsafeRead arr (2*md)-            case compare p v of-                LT -> go lo md-                EQ -> return (2*md)-                GT -> go (md+1) hi-          | otherwise   = return (2*lo)-    go low high--{-# INLINE copyTo #-}-copyTo :: Int -> COUNT_T -> STUArray s Int COUNT_T -> Int-       -> STUArray s Int COUNT_T -> Int -> ST s (Int,Int)-copyTo end lim old oi new ni = do-    let go ri wi-            | ri < end  = do-                ok <- unsafeRead old ri-                if ok < lim-                    then do-                        !ov <- unsafeRead old (ri+1)-                        unsafeWrite new wi ok-                        unsafeWrite new (wi+1) ov-                        go (ri+2) (wi+2)-                    else return (wi,ri)-            | otherwise = return (wi,ri)-    go oi ni--{-# INLINE copyRem #-}-copyRem :: Int -> STUArray s Int COUNT_T -> Int -> STUArray s Int COUNT_T -> Int -> ST s Int-copyRem end old oi new ni = do-    let go ri wi-          | ri < end    = do-            unsafeRead old ri >>= unsafeWrite new wi-            go (ri+1) (wi+1)-          | otherwise   = return wi-    go oi ni--{-# INLINE cp6 #-}-cp6 :: COUNT_T -> Integer-cp6 k =-  case k `quotRem` 30030 of-    (q,r) -> 5760*fromIntegral q +-                fromIntegral (cpCtAr `unsafeAt` fromIntegral r)--cop :: COUNT_T -> COUNT_T-cop m = m - fromIntegral (cpDfAr `unsafeAt` fromIntegral (m `rem` 30030))--------------------------------------------------------------------------------------                           Ugly helper arrays                               -------------------------------------------------------------------------------------cpCtAr :: UArray Int Int16-cpCtAr = runSTUArray $ do-    ar <- newArray (0,30029) 1-    let zilch s i-            | i < 30030 = unsafeWrite ar i 0 >> zilch s (i+s)-            | otherwise = return ()-        accumulate ct i-            | i < 30030 = do-                v <- unsafeRead ar i-                let !ct' = ct+v-                unsafeWrite ar i ct'-                accumulate ct' (i+1)-            | otherwise = return ar-    zilch 2 0-    zilch 6 3-    zilch 10 5-    zilch 14 7-    zilch 22 11-    zilch 26 13-    accumulate 1 2--cpDfAr :: UArray Int Int8-cpDfAr = runSTUArray $ do-    ar <- newArray (0,30029) 0-    let note s i-            | i < 30029 = unsafeWrite ar i 1 >> note s (i+s)-            | otherwise = return ()-        accumulate d i-            | i < 30029 = do-                v <- unsafeRead ar i-                if v == 0-                    then accumulate 2 (i+2)-                    else do unsafeWrite ar i d-                            accumulate (d+1) (i+1)-            | otherwise = return ar-    note 2 0-    note 6 3-    note 10 5-    note 14 7-    note 22 11-    note 26 13-    accumulate 2 3--cpGpAr :: UArray Int Int8-cpGpAr = runSTUArray $ do-    ar <- newArray (0,30030) 0-    unsafeWrite ar 30030 1-    let note s i-            | i < 30029 = unsafeWrite ar i 1 >> note s (i+s)-            | otherwise = return ()-        accumulate d i-            | i < 1     = return ar-            | otherwise = do-                v <- unsafeRead ar i-                if v == 0-                    then accumulate 2 (i-2)-                    else do unsafeWrite ar i d-                            accumulate (d+1) (i-1)-            | otherwise = return ar-    note 2 0-    note 6 3-    note 10 5-    note 14 7-    note 22 11-    note 26 13-    accumulate 2 30027+-------------------------------------------------------------------------------+-- Prime counting +-- find the n-th set bit in a list of PrimeSieves,+-- aka find the (n+3)-rd prime+countToNth :: Int -> [PrimeSieve] -> Integer+countToNth !_ [] = error "countToNth: Prime stream ended prematurely"+countToNth !n (PS v0 bs : more) = case nthBitIndex (Bit True) n bs of+  Just i -> v0 + toPrim i+  Nothing -> countToNth (n - countBits bs) more
− Math/NumberTheory/Primes/Factorisation.hs 
@@ -1,67 +0,0 @@--- |--- Module:      Math.NumberTheory.Primes.Factorisation--- Copyright:   (c) 2011 Daniel Fischer--- Licence:     MIT--- Maintainer:  Daniel Fischer <daniel.is.fischer@googlemail.com>--- Stability:   Provisional--- Portability: Non-portable (GHC extensions)------ Various functions related to prime factorisation.--- Many of these functions use the prime factorisation of an 'Integer'.--- If several of them are used on the same 'Integer', it would be inefficient--- to recalculate the factorisation, hence there are also functions working--- on the canonical factorisation, these require that the number be positive--- and in the case of the Carmichael function that the list of prime factors--- with their multiplicities is ascending.--module Math.NumberTheory.Primes.Factorisation-    ( -- * Factorisation functions-      -- $algorithm-      -- ** Complete factorisation-      factorise-    , defaultStdGenFactorisation-    , stepFactorisation-    , factorise'-    , defaultStdGenFactorisation'-      -- *** Factor sieves-    , FactorSieve-    , factorSieve-    , sieveFactor-      -- *** Trial division-    , trialDivisionTo-      -- ** Partial factorisation-    , smallFactors-    , stdGenFactorisation-    , 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------ Factorisation of 'Integer's by the elliptic curve algorithm after Montgomery.--- The algorithm is explained at--- <http://programmingpraxis.com/2010/04/23/modern-elliptic-curve-factorization-part-1/>--- and--- <http://programmingpraxis.com/2010/04/27/modern-elliptic-curve-factorization-part-2/>------ The implementation is not very optimised, so it is not suitable for factorising numbers--- with several huge prime divisors. However, factors of 20-25 digits are normally found in--- acceptable time. The time taken depends, however, strongly on how lucky the curve-picking--- is. With luck, even large factors can be found in seconds; on the other hand, finding small--- factors (about 12-15 digits) can take minutes when the curve-picking is bad.------ Given enough time, the algorithm should be able to factor numbers of 100-120 digits, but it--- is best suited for numbers of up to 50-60 digits.
− Math/NumberTheory/Primes/Factorisation/Certified.hs 
@@ -1,175 +0,0 @@--- |--- Module:      Math.NumberTheory.Primes.Factorisation.Certified--- Copyright:   (c) 2011 Daniel Fischer--- Licence:     MIT--- Maintainer:  Daniel Fischer <daniel.is.fischer@googlemail.com>--- Stability:   Provisional--- Portability: Non-portable (GHC extensions)------ Factorisation proving the primality of the found factors.------ For large numbers, this will be very slow in general.--- Use only if you're paranoid or must be /really/ sure.-{-# LANGUAGE BangPatterns, CPP #-}-module Math.NumberTheory.Primes.Factorisation.Certified-  ( certifiedFactorisation-  , certificateFactorisation-  , provenFactorisation-  ) where--import System.Random-import Control.Monad.State.Strict-#if __GLASGOW_HASKELL__ < 709-import Control.Applicative-#endif-import Data.Maybe-import Data.Bits--import Math.NumberTheory.Moduli.Class-import Math.NumberTheory.Primes.Factorisation.Montgomery-import Math.NumberTheory.Primes.Testing.Certificates.Internal-import Math.NumberTheory.Primes.Testing.Probabilistic---- | @'certifiedFactorisation' n@ produces the prime factorisation---   of @n@, proving the primality of the factors, but doesn't report the proofs.-certifiedFactorisation :: Integer -> [(Integer,Int)]-certifiedFactorisation = map fst . certificateFactorisation---- | @'certificateFactorisation' n@ produces a 'provenFactorisation'---   with a default bound of @100000@.-certificateFactorisation :: Integer -> [((Integer,Int),PrimalityProof)]-certificateFactorisation n = provenFactorisation 100000 n---- | @'provenFactorisation' bound n@ constructs a the prime factorisation of @n@---   (which must be positive) together with proofs of primality of the factors,---   using trial division up to @bound@ (which is arbitrarily replaced by @2000@---   if the supplied value is smaller) and elliptic curve factorisation for the---   remaining factors if necessary.------   Construction of primality proofs can take a /very/ long time, so this---   will usually be slow (but should be faster than using 'factorise' and---   proving the primality of the factors from scratch).-provenFactorisation :: Integer -> Integer -> [((Integer,Int),PrimalityProof)]-provenFactorisation _ 1 = []-provenFactorisation bd n-    | n < 2     = error "provenFactorisation: argument not positive"-    | bd < 2000 = provenFactorisation 2000 n-    | otherwise = test $-      case smallFactors bd n of-        (sfs,mb) -> map (\t@(p,_) -> (t, smallCert p)) sfs-            ++ case mb of-                 Nothing -> []-                 Just k -> certiFactorisation (Just $ bd*(bd+2)) primeCheck (randomR . (,) 6)-                                                (mkStdGen $ fromIntegral n `xor` 0xdeadbeef) Nothing k---- | verify that we indeed have a correct primality proof-test :: [((Integer,Int),PrimalityProof)] -> [((Integer,Int),PrimalityProof)]-test (t@((p,_),prf):more)-    | p == cprime prf && checkPrimalityProof prf    = t : test more-    | otherwise = error (invalid p prf)-test [] = []---- | produce a proof of primality for primes---   Only called for (not too small) numbers known to have no small prime factors,---   so we can directly use BPSW without trial division.-primeCheck :: Integer -> Maybe PrimalityProof-primeCheck n-    | bailliePSW n  = case certifyBPSW n of-                        proof@Pocklington{} -> Just proof-                        _ -> Nothing-    | otherwise = Nothing---- | produce a certified factorisation---   Assumes all small prime factors have been stripped before.---   Since it is not exported, that is known to hold.---   This is a near duplicate of 'curveFactorisation', I should some time---   clean this up.-certiFactorisation :: Maybe Integer                 -- ^ Lower bound for composite divisors-                   -> (Integer -> Maybe PrimalityProof)-                                                    -- ^ A primality test-                   -> (Integer -> g -> (Integer,g)) -- ^ A PRNG-                   -> g                             -- ^ Initial PRNG state-                   -> Maybe Int                     -- ^ Estimated number of digits of the smallest prime factor-                   -> Integer                       -- ^ The number to factorise-                   -> [((Integer,Int),PrimalityProof)]-                                                    -- ^ List of prime factors, exponents and primality proofs-certiFactorisation primeBound primeTest prng seed mbdigs n-    = case ptest n of-        Just proof -> [((n,1),proof)]-        Nothing -> evalState (fact n digits) seed-      where-        digits = fromMaybe 8 mbdigs-        mult 1 xs = xs-        mult j xs = [((p,j*k),c) | ((p,k),c) <- xs]-        vdb xs = [(p,2*e) | (p,e) <- xs]-        dbl (u,v) = (mult 2 u, vdb v)-        ptest = case primeBound of-                  Just bd -> \k -> if k <= bd then (Just $ smallCert k) else primeTest k-                  Nothing -> primeTest-        rndR k = state (\gen -> prng k gen)-        fact m digs = do let (b1,b2,ct) = findParms digs-                         (pfs,cfs) <- repFact m b1 b2 ct-                         if null cfs-                           then return pfs-                           else do-                               nfs <- forM cfs $ \(k,j) ->-                                   mult j <$> fact k (if null pfs then digs+4 else digs)-                               return (mergeAll $ pfs:nfs)-        repFact m b1 b2 count-            | count < 0 = return ([],[(m,1)])-            | otherwise = do-                s <- rndR m-                case s `modulo` fromInteger m of-                  InfMod{} -> error "impossible case"-                  SomeMod sm -> case montgomeryFactorisation b1 b2 sm of-                    Nothing -> repFact m b1 b2 (count-1)-                    Just d  -> do-                      let !cof = m `quot` d-                      case gcd cof d of-                        1 -> do-                            (dp,dc) <- case ptest d of-                                         Just proof -> return ([((d,1),proof)],[])-                                         Nothing -> repFact d b1 b2 (count-1)-                            (cp,cc) <- case ptest cof of-                                         Just proof -> return ([((cof,1),proof)],[])-                                         Nothing -> repFact cof b1 b2 (count-1)-                            return (merge dp cp, dc ++ cc)-                        g -> do-                            let d' = d `quot` g-                                c' = cof `quot` g-                            (dp,dc) <- case ptest d' of-                                         Just proof -> return ([((d',1),proof)],[])-                                         Nothing -> repFact d' b1 b2 (count-1)-                            (cp,cc) <- case ptest c' of-                                         Just proof -> return ([((c',1),proof)],[])-                                         Nothing -> repFact c' b1 b2 (count-1)-                            (gp,gc) <- case ptest g of-                                         Just proof -> return ([((g,2),proof)],[])-                                         Nothing -> dbl <$> repFact g b1 b2 (count-1)-                            return  (mergeAll [dp,cp,gp], dc ++ cc ++ gc)---- | merge two lists of factors, so that the result is strictly increasing (wrt the primes)-merge :: [((Integer,Int),PrimalityProof)] -> [((Integer,Int),PrimalityProof)] -> [((Integer,Int),PrimalityProof)]-merge xxs@(x@((p,e),c):xs) yys@(y@((q,d),_):ys)-    = case compare p q of-        LT -> x : merge xs yys-        EQ -> ((p,e+d),c) : merge xs ys-        GT -> y : merge xxs ys-merge [] ys = ys-merge xs _  = xs---- | merge a list of lists of factors so that the result is strictly increasing (wrt the primes)-mergeAll :: [[((Integer,Int),PrimalityProof)]] -> [((Integer,Int),PrimalityProof)]-mergeAll [] = []-mergeAll [xs] = xs-mergeAll (xs:ys:zss) = merge (merge xs ys) (mergeAll zss)---- | message for an invalid proof, should never be used-invalid :: Integer -> PrimalityProof -> String-invalid p prf = unlines-                    [ "\nInvalid primality proof constructed, please report this to the package maintainer!"-                    , "The supposed prime was:\n"-                    , show p-                    , "\nThe presumed proof was:\n"-                    , show prf-                    ]
Math/NumberTheory/Primes/Factorisation/Montgomery.hs view
@@ -3,8 +3,6 @@ -- Copyright:   (c) 2011 Daniel Fischer -- Licence:     MIT -- Maintainer:  Daniel Fischer <daniel.is.fischer@googlemail.com>--- Stability:   Provisional--- Portability: Non-portable (GHC extensions) -- -- Factorisation of 'Integer's by the elliptic curve algorithm after Montgomery. -- The algorithm is explained at@@ -12,115 +10,75 @@ -- and -- <http://programmingpraxis.com/2010/04/27/modern-elliptic-curve-factorization-part-2/> ----- The implementation is not very optimised, so it is not suitable for factorising numbers--- with only huge prime divisors. However, factors of 20-25 digits are normally found in--- acceptable time. The time taken depends, however, strongly on how lucky the curve-picking--- is. With luck, even large factors can be found in seconds; on the other hand, finding small--- factors (about 10 digits) can take minutes when the curve-picking is bad.------ Given enough time, the algorithm should be able to factor numbers of 100-120 digits, but it--- is best suited for numbers of up to 50-60 digits. -{-# LANGUAGE BangPatterns   #-}-{-# LANGUAGE CPP            #-}-{-# LANGUAGE DataKinds      #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE LambdaCase     #-}+{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE KindSignatures      #-}+{-# LANGUAGE LambdaCase          #-}+{-# LANGUAGE MagicHash           #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UnboxedTuples       #-}  {-# OPTIONS_GHC -fno-warn-type-defaults #-}-{-# OPTIONS_HADDOCK hide #-}  module Math.NumberTheory.Primes.Factorisation.Montgomery   ( -- *  Complete factorisation functions     -- ** Functions with input checking     factorise-  , defaultStdGenFactorisation-    -- ** Functions without input checking-  , factorise'-  , stepFactorisation-  , defaultStdGenFactorisation'-    -- * Partial factorisation+  --   -- * Partial factorisation   , smallFactors-  , stdGenFactorisation-  , curveFactorisation-    -- ** Single curve worker+  --   -- ** Single curve worker   , montgomeryFactorisation   , findParms   ) where -#include "MachDeps.h"--import System.Random-import Control.Monad.State.Strict-#if __GLASGOW_HASKELL__ < 709-import Control.Applicative-import Data.Word-#endif+import Prelude hiding (Foldable(..))+import Control.Arrow+import Control.Monad.Trans.State.Lazy+import Data.Bit import Data.Bits+import Data.Foldable import Data.IntMap (IntMap) import qualified Data.IntMap as IM-import Data.List (foldl') import Data.Maybe--import GHC.TypeNats.Compat+import Data.Mod+import Data.Proxy+import Data.Traversable+import qualified Data.Vector.Unboxed as U+import GHC.Exts+import GHC.Num.BigNat+import GHC.Natural+import GHC.TypeNats (KnownNat, SomeNat(..), natVal, someNatVal)+import System.Random  import Math.NumberTheory.Curves.Montgomery-import Math.NumberTheory.Moduli.Class-import Math.NumberTheory.Powers.General     (highestPower, largePFPower)-import Math.NumberTheory.Powers.Squares     (integerSquareRoot')-import Math.NumberTheory.Primes.Sieve.Eratosthenes-import Math.NumberTheory.Primes.Sieve.Indexing+import Math.NumberTheory.Euclidean.Coprimes (splitIntoCoprimes, unCoprimes)+import Math.NumberTheory.Logarithms (integerLogBase')+import Math.NumberTheory.Roots+import Math.NumberTheory.Primes.Sieve.Eratosthenes (PrimeSieve(..), psieveFrom)+import Math.NumberTheory.Primes.Sieve.Indexing (toPrim)+import Math.NumberTheory.Primes.Small import Math.NumberTheory.Primes.Testing.Probabilistic-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 :: Integer -> [(Integer,Int)]-factorise n-    | n < 0     = (-1,1):factorise (-n)-    | n == 0    = error "0 has no prime factorisation"-    | n == 1    = []-    | otherwise = factorise' n---- | Like 'factorise', but without input checking, hence @n > 1@ is required.-factorise' :: Integer -> [(Integer,Int)]-factorise' n = defaultStdGenFactorisation' (mkStdGen $ fromInteger n `xor` 0xdeadbeef) n---- | @'stepFactorisation'@ is like 'factorise'', except that it doesn't use a---   pseudo random generator but steps through the curves in order.---   This strategy turns out to be surprisingly fast, on average it doesn't---   seem to be slower than the 'StdGen' based variant.-stepFactorisation :: Integer -> [(Integer,Int)]-stepFactorisation n-    = let (sfs,mb) = smallFactors 100000 n-      in sfs ++ case mb of-                  Nothing -> []-                  Just r  -> curveFactorisation (Just 10000000000) bailliePSW-                                                (\m k -> (if k < (m-1) then k else error "Curves exhausted",k+1)) 6 Nothing r---- | @'defaultStdGenFactorisation'@ first strips off all small prime factors and then,---   if the factorisation is not complete, proceeds to curve factorisation.---   For negative numbers, a factor of @-1@ is included, the factorisation of @1@---   is empty. Since @0@ has no prime factorisation, a zero argument causes---   an error.-defaultStdGenFactorisation :: StdGen -> Integer -> [(Integer,Int)]-defaultStdGenFactorisation sg n-    | n == 0    = error "0 has no prime factorisation"-    | n < 0     = (-1,1) : defaultStdGenFactorisation sg (-n)-    | n == 1    = []-    | otherwise = defaultStdGenFactorisation' sg n+import Math.NumberTheory.Utils hiding (splitOff)+import Math.NumberTheory.Utils.FromIntegral --- | Like 'defaultStdGenFactorisation', but without input checking, so---   @n@ must be larger than @1@.-defaultStdGenFactorisation' :: StdGen -> Integer -> [(Integer,Int)]-defaultStdGenFactorisation' sg n-    = let (sfs,mb) = smallFactors 100000 n-      in sfs ++ case mb of-                  Nothing -> []-                  Just m  -> stdGenFactorisation (Just 10000000000) sg Nothing m+-- | @'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@.+--+-- __Warning:__ there are no guarantees of any particular+-- order of prime factors, do not expect them to be ascending.+factorise :: Integral a => a -> [(a, Word)]+factorise 0 = error "0 has no prime factorisation"+factorise n' = map (first fromIntegral) sfs <> map (first fromInteger) rest+  where+    n = abs n'+    (sfs, mb) = smallFactors (fromIntegral' n)+    sg = mkStdGen (fromIntegral n `xor` 0xdeadbeef)+    rest = case mb of+      Nothing -> []+      Just m  -> stdGenFactorisation (Just $ 65536 * 65536) sg Nothing (toInteger m)  ---------------------------------------------------------------------------------------------------- --                                    Factorisation wrappers                                      --@@ -130,15 +88,15 @@ --   The primality test is 'bailliePSW', the @prng@ function - naturally - --   'randomR'. This function also requires small prime factors to have been --   stripped before.-stdGenFactorisation :: Maybe Integer    -- ^ Lower bound for composite divisors-                    -> StdGen           -- ^ Standard PRNG-                    -> Maybe Int        -- ^ Estimated number of digits of smallest prime factor-                    -> Integer          -- ^ The number to factorise-                    -> [(Integer,Int)]  -- ^ List of prime factors and exponents-stdGenFactorisation primeBound sg digits n-    = curveFactorisation primeBound bailliePSW (\m -> randomR (6,m-2)) sg digits n+stdGenFactorisation :: Maybe Integer     -- ^ Lower bound for composite divisors+                    -> StdGen            -- ^ Standard PRNG+                    -> Maybe Int         -- ^ Estimated number of digits of smallest prime factor+                    -> Integer           -- ^ The number to factorise+                    -> [(Integer, Word)] -- ^ List of prime factors and exponents+stdGenFactorisation primeBound =+  curveFactorisation primeBound bailliePSW (\m -> randomR (6, m - 2)) --- | @'curveFactorisation'@ is the driver for the factorisation. Its performance (and success)+-- | 'curveFactorisation' is the driver for the factorisation. Its performance (and success) --   can be influenced by passing appropriate arguments. If you know that @n@ has no prime divisors --   below @b@, any divisor found less than @b*b@ must be prime, thus giving @Just (b*b)@ as the --   first argument allows skipping the comparatively expensive primality test for those.@@ -150,78 +108,148 @@ --   make a huge difference. So, if the default takes too long, try another one; or you can improve your --   chances for a quick result by running several instances in parallel. -----   @'curveFactorisation'@ requires that small prime factors have been stripped before. Also, it is---   unlikely to succeed if @n@ has more than one (really) large prime factor.-curveFactorisation :: Maybe Integer                 -- ^ Lower bound for composite divisors-                   -> (Integer -> Bool)             -- ^ A primality test-                   -> (Integer -> g -> (Integer,g)) -- ^ A PRNG-                   -> g                             -- ^ Initial PRNG state-                   -> Maybe Int                     -- ^ Estimated number of digits of the smallest prime factor-                   -> Integer                       -- ^ The number to factorise-                   -> [(Integer,Int)]               -- ^ List of prime factors and exponents+--   'curveFactorisation' @n@ requires that small (< 65536) prime factors of @n@+--   have been stripped before. Otherwise it is likely to cycle forever.+--+--   'curveFactorisation' is unlikely to succeed if @n@ has more than one (really) large prime factor.+--+curveFactorisation+  :: forall g.+     Maybe Integer                  -- ^ Lower bound for composite divisors+  -> (Integer -> Bool)              -- ^ A primality test+  -> (Integer -> g -> (Integer, g)) -- ^ A PRNG+  -> g                              -- ^ Initial PRNG state+  -> Maybe Int                      -- ^ Estimated number of digits of the smallest prime factor+  -> Integer                        -- ^ The number to factorise+  -> [(Integer, Word)]              -- ^ List of prime factors and exponents curveFactorisation primeBound primeTest prng seed mbdigs n-    | ptest n   = [(n,1)]+    | n == 1    = []+    | ptest n   = [(n, 1)]     | otherwise = evalState (fact n digits) seed       where+        digits :: Int         digits = fromMaybe 8 mbdigs-        mult 1 xs = xs-        mult j xs = [(p,j*k) | (p,k) <- xs]-        dbl (u,v) = (mult 2 u, mult 2 v)-        ptest = case primeBound of-                  Just bd -> \k -> k <= bd || primeTest k-                  Nothing -> primeTest-        rndR k = state (\gen -> prng k gen)-        perfPw = case primeBound of-                   Nothing -> highestPower-                   Just bd -> largePFPower (integerSquareRoot' bd)-        fact m digs = do let (b1,b2,ct) = findParms digs-                         (pfs,cfs) <- repFact m b1 b2 ct-                         if null cfs-                           then return pfs-                           else do-                               nfs <- forM cfs $ \(k,j) ->-                                   mult j <$> fact k (if null pfs then digs+5 else digs)-                               return (mergeAll $ pfs:nfs)-        repFact m b1 b2 count = case perfPw m of-                                  (_,1) -> workFact m b1 b2 count-                                  (b,e)-                                    | ptest b -> return ([(b,e)],[])-                                    | otherwise -> do-                                      (as,bs) <- workFact b b1 b2 count-                                      return $ (mult e as, mult e bs)-        workFact m b1 b2 count-            | count == 0 = return ([],[(m,1)])-            | otherwise = do-                s <- rndR m-                case s `modulo` fromInteger m of-                  InfMod{} -> error "impossible case"-                  SomeMod sm -> case montgomeryFactorisation b1 b2 sm of-                    Nothing -> workFact m b1 b2 (count-1)-                    Just d  -> do-                      let !cof = m `quot` d-                      case gcd cof d of-                        1 -> do-                            (dp,dc) <- if ptest d-                                         then return ([(d,1)],[])-                                         else repFact d b1 b2 (count-1)-                            (cp,cc) <- if ptest cof-                                         then return ([(cof,1)],[])-                                         else repFact cof b1 b2 (count-1)-                            return (merge dp cp, dc ++ cc)-                        g -> do-                            let d' = d `quot` g-                                c' = cof `quot` g-                            (dp,dc) <- if ptest d'-                                         then return ([(d',1)],[])-                                         else repFact d' b1 b2 (count-1)-                            (cp,cc) <- if ptest c'-                                         then return ([(c',1)],[])-                                         else repFact c' b1 b2 (count-1)-                            (gp,gc) <- if ptest g-                                         then return ([(g,2)],[])-                                         else dbl <$> repFact g b1 b2 (count-1)-                            return  (mergeAll [dp,cp,gp], dc ++ cc ++ gc) +        ptest :: Integer -> Bool+        ptest = maybe primeTest (\bd k -> k <= bd || primeTest k) primeBound++        rndR :: Integer -> State g Integer+        rndR k = state (prng k)++        perfPw :: Integer -> (Integer, Word)+        perfPw = maybe highestPower (largePFPower . integerSquareRoot) primeBound++        fact :: Integer -> Int -> State g [(Integer, Word)]+        fact 1 _ = return mempty+        fact m digs = do+          let (b1, b2, ct) = findParms digs+          -- All factors (both @pfs@ and @cfs@), are pairwise coprime. This is+          -- because 'repFact' returns either a single factor, or output of 'workFact'.+          -- In its turn, 'workFact' returns either a single factor,+          -- or concats 'repFact's over coprime integers. Induction completes the proof.+          Factors pfs cfs <- repFact m b1 b2 ct+          case cfs of+            [] -> return pfs+            _  -> do+              nfs <- forM cfs $ \(k, j) ->+                  map (second (* j)) <$> fact k (if null pfs then digs + 5 else digs)+              return $ mconcat (pfs : nfs)++        repFact :: Integer -> Word -> Word -> Word -> State g Factors+        repFact 1 _ _ _ = return mempty+        repFact m b1 b2 count =+          case perfPw m of+            (_, 1) -> workFact m b1 b2 count+            (b, e)+              | ptest b   -> return $ singlePrimeFactor b e+              | otherwise -> modifyPowers (* e) <$> workFact b b1 b2 count++        workFact :: Integer -> Word -> Word -> Word -> State g Factors+        workFact 1 _ _ _ = return mempty+        workFact m _ _ 0 = return $ singleCompositeFactor m 1+        workFact m b1 b2 count = do+          s <- rndR m+          case someNatVal (fromInteger m) of+            SomeNat (_ :: Proxy t) -> case montgomeryFactorisation b1 b2 (fromInteger s :: Mod t) of+              Nothing -> workFact m b1 b2 (count - 1)+              Just d  -> do+                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.+                fmap mconcat $ forM cs $+                  \(x, xm) -> if ptest x+                              then pure $ singlePrimeFactor x xm+                              else fmap (modifyPowers (* xm)) (repFact x b1 b2 (count - 1))++data Factors = Factors+  { _primeFactors     :: [(Integer, Word)]+  , _compositeFactors :: [(Integer, Word)]+  } deriving (Show)++singlePrimeFactor :: Integer -> Word -> Factors+singlePrimeFactor a b = Factors [(a, b)] []++singleCompositeFactor :: Integer -> Word -> Factors+singleCompositeFactor a b = Factors [] [(a, b)]++instance Semigroup Factors where+  Factors pfs1 cfs1 <> Factors pfs2 cfs2+    = Factors (pfs1 <> pfs2) (cfs1 <> cfs2)++instance Monoid Factors where+  mempty = Factors [] []++modifyPowers :: (Word -> Word) -> Factors -> Factors+modifyPowers f (Factors pfs cfs)+  = Factors (map (second f) pfs) (map (second f) cfs)++-------------------------------------------------------------------------------+-- largePFPower++-- | @'largePFPower' bd n@ produces the pair @(b,k)@ with the largest+--   exponent @k@ such that @n == b^k@, where @bd > 1@ (it is expected+--   that @bd@ is much larger, at least @1000@ or so), @n > bd^2@ and @n@+--   has no prime factors @p <= bd@, skipping the trial division phase+--   of @'highestPower'@ when that is a priori known to be superfluous.+--   It is only present to avoid duplication of work in factorisation+--   and primality testing, it is not expected to be generally useful.+--   The assumptions are not checked, if they are not satisfied, wrong+--   results and wasted work may be the consequence.+largePFPower :: Integer -> Integer -> (Integer, Word)+largePFPower bd n = rawPower ln n+  where+    ln = intToWord (integerLogBase' (bd+1) n)++rawPower :: Word -> Integer -> (Integer, Word)+rawPower mx n = case exactRoot 4 n of+                  Just r -> case rawPower (mx `quot` 4) r of+                              (m,e) -> (m, 4*e)+                  Nothing -> case exactSquareRoot n of+                               Just r -> case rawOddPower (mx `quot` 2) r of+                                           (m,e) -> (m, 2*e)+                               Nothing -> rawOddPower mx n++rawOddPower :: Word -> Integer -> (Integer, Word)+rawOddPower mx n+  | mx < 3       = (n,1)+rawOddPower mx n = case exactCubeRoot n of+                     Just r -> case rawOddPower (mx `quot` 3) r of+                                 (m,e) -> (m, 3*e)+                     Nothing -> badPower mx n++badPower :: Word -> Integer -> (Integer, Word)+badPower mx n+  | mx < 5      = (n,1)+  | otherwise   = go 1 mx n (takeWhile (<= mx) $ scanl (+) 5 $ cycle [2,4])+    where+      go !e b m (k:ks)+        | b < k     = (m,e)+        | otherwise = case exactRoot k m of+                        Just r -> go (e*k) (b `quot` k) r (k:ks)+                        Nothing -> go e b m ks+      go e _ m []   = (m,e)+ ---------------------------------------------------------------------------------------------------- --                                         The workhorse                                          -- ----------------------------------------------------------------------------------------------------@@ -240,7 +268,7 @@ -- --   The result is maybe a nontrivial divisor of @n@. montgomeryFactorisation :: KnownNat n => Word -> Word -> Mod n -> Maybe Integer-montgomeryFactorisation b1 b2 s = case newPoint (getVal s) n of+montgomeryFactorisation b1 b2 s = case newPoint (toInteger (unMod s)) n of   Nothing             -> Nothing   Just (SomePoint p0) -> do     -- Small step: for each prime p <= b1@@ -248,16 +276,17 @@     let q = foldl (flip multiply) p0 smallPowers         z = pointZ q -    fromIntegral <$> case gcd n z of+    case gcd n z of       -- If small step did not succeed, perform a big step.       1 -> case gcd n (bigStep q b1 b2) of         1 -> Nothing         g -> Just g       g -> Just g   where-    n = getMod s-    smallPrimes = takeWhile (<= b1) (2 : 3 : 5 : list primeStore)-    smallPowers = map findPower smallPrimes+    n = toInteger (natVal s)+    smallPowers+      = map findPower+      $ takeWhile (<= b1) (2 : 3 : 5 : list primeStore)     findPower p = go p       where         go acc@@ -273,7 +302,7 @@     n = pointN q      b0 = b1 - b1 `rem` wheel-    qks = zip [0..] $ map (\k -> multiply k q) wheelCoprimes+    qks = zip [0..] $ map (`multiply` q) wheelCoprimes     qs = enumAndMultiplyFromThenTo q b0 (b0 + wheel) b2      rs = foldl' (\ts (_cHi, p) -> foldl' (\us (_cLo, pq) ->@@ -303,7 +332,7 @@     pThen = multiply thn  p     pStep = multiply step p -    progression = pFrom : pThen : zipWith (\x0 x1 -> add x0 pStep x1) progression (tail progression)+    progression = pFrom : pThen : zipWith (`add` pStep) progression (drop 1 progression)  -- primes, compactly stored as a bit sieve primeStore :: [PrimeSieve]@@ -311,42 +340,71 @@  -- generate list of primes from arrays list :: [PrimeSieve] -> [Word]-list sieves = concat [[off + toPrim i | i <- [0 .. li], unsafeAt bs i]-                                | PS vO bs <- sieves, let { (_,li) = bounds bs; off = fromInteger vO; }]+list sieves = concat [[off + toPrim i | i <- [0 .. li], unBit (U.unsafeIndex bs i)]+                                | PS vO bs <- sieves, let { li = U.length bs - 1; off = fromInteger vO; }] --- | @'smallFactors' bound n@ finds all prime divisors of @n > 1@ up to @bound@ by trial division and returns the+-- | @'smallFactors' n@ finds all prime divisors of @n > 1@ up to 2^16 by trial division and returns the --   list of these together with their multiplicities, and a possible remaining factor which may be composite.-smallFactors :: Integer -> Integer -> ([(Integer,Int)], Maybe Integer)-smallFactors bd n = case shiftToOddCount n of-                      (0,m) -> go m prms-                      (k,m) -> (2,k) <: if m == 1 then ([],Nothing) else go m prms+smallFactors :: Natural -> ([(Natural, Word)], Maybe Natural)+smallFactors = \case+  NatS# 0## -> error "0 has no prime factorisation"+  NatS# n#  -> case shiftToOddCount# n# of+    (# 0##, m# #) -> goWord m# 1+    (# k#,  m# #) -> (2, W# k#) <: goWord m# 1+  NatJ# (BN# n) -> case shiftToOddCountBigNat n of+    (# 0, m #) -> goBigNat m 1+    (# k, m #) -> (2, k) <: goBigNat m 1   where-    prms = tail (primeStore >>= primeList)     x <: ~(l,b) = (x:l,b)-    go m (p:ps)-        | m < p*p   = ([(m,1)], Nothing)-        | bd < p    = ([], Just m)-        | otherwise = case splitOff p m of-                        (0,_) -> go m ps-                        (k,r) | r == 1 -> ([(p,k)], Nothing)-                              | otherwise -> (p,k) <: go r ps-    go m [] = ([(m,1)], Nothing) --- helpers: merge sorted lists-merge :: (Ord a, Num b) => [(a, b)] -> [(a, b)] -> [(a, b)]-merge xs [] = xs-merge [] ys = ys-merge xxs@(x@(p, k) : xs) yys@(y@(q, m) : ys)-  = case p `compare` q of-    LT -> x          : merge xs yys-    EQ -> (p, k + m) : merge xs  ys-    GT -> y          : merge xxs ys+    !(Ptr smallPrimesAddr#) = smallPrimesPtr -mergeAll :: (Ord a, Num b) => [[(a, b)]] -> [(a, b)]-mergeAll = \case-  []              -> []-  [xs]            -> xs-  (xs : ys : zss) -> merge (merge xs ys) (mergeAll zss)+    goBigNat :: BigNat# -> Int -> ([(Natural, Word)], Maybe Natural)+    goBigNat !m i@(I# i#)+      | isTrue# (bigNatSize# m ==# 1#)+      = goWord (bigNatToWord# m) i+      | i >= smallPrimesLength+      = ([], Just (NatJ# (BN# m)))+      | otherwise+      = let p# =+#if MIN_VERSION_base(4,16,0)+              word16ToWord#+#endif+              (indexWord16OffAddr# smallPrimesAddr# i#) in+      case m `bigNatQuotRemWord#` p# of+        (# mp, 0## #) ->+          let !(# k, r #) = splitOff 1 mp in+            (NatS# p#, k) <: goBigNat r (i + 1)+          where+            splitOff !k x = case x `bigNatQuotRemWord#` p# of+              (# xp, 0## #) -> splitOff (k + 1) xp+              _             -> (# k, x #)+        _ -> goBigNat m (i + 1)++    goWord :: Word# -> Int -> ([(Natural, Word)], Maybe Natural)+    goWord 1## !_ = ([], Nothing)+    goWord m#  !i+      | i >= smallPrimesLength+      = if isTrue# (m# `leWord#` 4294967295##) -- 65536 * 65536 - 1+        then ([(NatS# m#, 1)], Nothing)+        else ([], Just (NatS# m#))+    goWord m# i@(I# i#)+      = let p# =+#if MIN_VERSION_base(4,16,0)+              word16ToWord#+#endif+              (indexWord16OffAddr# smallPrimesAddr# i#) in+      if isTrue# (m# `ltWord#` (p# `timesWord#` p#))+        then ([(NatS# m#, 1)], Nothing)+        else case m# `quotRemWord#` p# of+          (# mp#, 0## #) ->+            let !(# k#, r# #) = splitOff 1## mp# in+              (NatS# p#, W# k#) <: goWord r# (i + 1)+            where+              splitOff k# x# = case x# `quotRemWord#` p# of+                (# xp#, 0## #) -> splitOff (k# `plusWord#` 1##) xp#+                _              -> (# k#, x# #)+          _ -> goWord m# (i + 1)  -- | For a given estimated decimal length of the smallest prime factor -- ("tier") return parameters B1, B2 and the number of curves to try
Math/NumberTheory/Primes/Factorisation/TrialDivision.hs view
@@ -3,8 +3,6 @@ -- Copyright:   (c) 2011 Daniel Fischer -- Licence:     MIT -- Maintainer:  Daniel Fischer <daniel.is.fischer@googlemail.com>--- Stability:   Provisional--- Portability: Non-portable (GHC extensions) -- -- Factorisation and primality testing using trial division. --@@ -15,23 +13,23 @@ module Math.NumberTheory.Primes.Factorisation.TrialDivision     ( trialDivisionWith     , trialDivisionTo-    , trialDivisionPrimeWith     , trialDivisionPrimeTo     ) where -import Math.NumberTheory.Primes.Sieve.Eratosthenes-import Math.NumberTheory.Powers.Squares+import Math.NumberTheory.Primes.Sieve.Eratosthenes (primeList, primeSieve, psieveList)+import Math.NumberTheory.Roots+import Math.NumberTheory.Primes.Types import Math.NumberTheory.Utils  -- | Factorise an 'Integer' using a given list of numbers considered prime. --   If the list is not a list of primes containing all relevant primes, the --   result could be surprising.-trialDivisionWith :: [Integer] -> Integer -> [(Integer,Int)]+trialDivisionWith :: [Integer] -> Integer -> [(Integer, Word)] trialDivisionWith prs n     | n < 0     = trialDivisionWith prs (-n)     | n == 0    = error "trialDivision of 0"     | n == 1    = []-    | otherwise = go n (integerSquareRoot' n) prs+    | otherwise = go n (integerSquareRoot n) prs       where         go !m !r (p:ps)             | r < p     = [(m,1)]@@ -40,18 +38,18 @@                   (0,_) -> go m r ps                   (k,q) -> (p,k) : if q == 1                                      then []-                                     else go q (integerSquareRoot' q) ps+                                     else go q (integerSquareRoot q) ps         go m _ _    = [(m,1)]  -- | @'trialDivisionTo' bound n@ produces a factorisation of @n@ using the --   primes @<= bound@. If @n@ has prime divisors @> bound@, the last entry --   in the list is the product of all these. If @n <= bound^2@, this is a --   full factorisation, but very slow if @n@ has large prime divisors.-trialDivisionTo :: Integer -> Integer -> [(Integer,Int)]+trialDivisionTo :: Integer -> Integer -> [(Integer, Word)] trialDivisionTo bd     | bd < 100      = trialDivisionTo 100-    | bd < 10000000 = trialDivisionWith (primeList $ primeSieve bd)-    | otherwise     = trialDivisionWith (takeWhile (<= bd) $ (psieveList >>= primeList))+    | bd < 10000000 = trialDivisionWith (map unPrime $ primeList $ primeSieve bd)+    | otherwise     = trialDivisionWith (takeWhile (<= bd) $ map unPrime $ psieveList >>= primeList)  -- | Check whether a number is coprime to all of the numbers in the list --   (assuming that list contains only numbers > 1 and is ascending).@@ -59,7 +57,7 @@ trialDivisionPrimeWith prs n     | n < 0     = trialDivisionPrimeWith prs (-n)     | n < 2     = False-    | otherwise = go n (integerSquareRoot' n) prs+    | otherwise = go n (integerSquareRoot n) prs       where         go !m !r (p:ps) = r < p || m `rem` p /= 0 && go m r ps         go _ _ _ = True@@ -69,5 +67,5 @@ trialDivisionPrimeTo :: Integer -> Integer -> Bool trialDivisionPrimeTo bd     | bd < 100      = trialDivisionPrimeTo 100-    | bd < 10000000 = trialDivisionPrimeWith (primeList $ primeSieve bd)-    | otherwise     = trialDivisionPrimeWith (takeWhile (<= bd) $ (psieveList >>= primeList))+    | bd < 10000000 = trialDivisionPrimeWith (map unPrime $ primeList $ primeSieve bd)+    | otherwise     = trialDivisionPrimeWith (takeWhile (<= bd) $ map unPrime $ psieveList >>= primeList)
− Math/NumberTheory/Primes/Heap.hs 
@@ -1,366 +0,0 @@--- |--- Module:      Math.NumberTheory.Primes.Heap--- Copyright:   (c) 2011 Daniel Fischer--- Licence:     MIT--- Maintainer:  Daniel Fischer <daniel.is.fischer@googlemail.com>--- Stability:   Provisional--- Portability: Non-portable (GHC extensions)------ Prime generation using a priority queue for the composites.--- The algorithm is basically the one described in--- <http://www.cs.hmc.edu/~oneill/papers/Sieve-JFP.pdf>, 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 (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-
+ Math/NumberTheory/Primes/IntSet.hs view
@@ -0,0 +1,344 @@+-- |+-- Module:      Math.NumberTheory.Primes.IntSet+-- Copyright:   (c) 2020 Andrew Lelechenko+-- Licence:     MIT+-- Maintainer:  Andrew Lelechenko <andrew.lelechenko@gmail.com>+--+-- A newtype wrapper around 'IntSet'.+--+-- This module is intended to be imported qualified, e. g.,+--+-- > import Math.NumberTheory.Primes.IntSet (PrimeIntSet)+-- > import qualified Math.NumberTheory.Primes.IntSet as PrimeIntSet+--++{-# LANGUAGE BangPatterns               #-}+{-# LANGUAGE CPP                        #-}+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE TypeApplications           #-}+{-# LANGUAGE TypeFamilies               #-}++module Math.NumberTheory.Primes.IntSet+  ( -- * Set type+    PrimeIntSet+  , unPrimeIntSet+  -- * Construction+  -- | Use 'Data.Monoid.mempty' to create an empty set.+  , singleton+  , fromList+  , fromAscList+  , fromDistinctAscList+  -- * Insertion+  , insert+  -- * Deletion+  , delete+  -- * Query+  , member+  , notMember+  , lookupEQ+  , lookupLT+  , lookupGT+  , lookupLE+  , lookupGE+  , null+  , size+  , isSubsetOf+  , isProperSubsetOf+  , disjoint+  -- * Combine+  -- | Use 'Data.Semigroup.<>' for unions.+  , difference+  , (\\)+  , symmetricDifference+  , intersection+  -- * Filter+  , filter+  , partition+  , split+  , splitMember+  , splitLookupEQ+  , splitRoot+  -- * Folds+  , foldr+  , foldl+  , foldr'+  , foldl'+  -- * Min/Max+  , deleteMin+  , deleteMax+  , minView+  , maxView+  -- * Conversion+  , toAscList+  , toDescList+  ) where++import Prelude (Eq, Ord, Show, Monoid, Bool, Maybe(..), Int, otherwise)+import Control.DeepSeq (NFData)+import Data.Coerce (coerce)+import Data.Data (Data)+import Data.IntSet (IntSet)+import qualified Data.IntSet.Internal as IS+import Data.Semigroup (Semigroup)+import qualified GHC.Exts (IsList(..))++import Math.NumberTheory.Primes.Types (Prime(..))++#if !MIN_VERSION_containers(0,8,0)+import Prelude ((>), (/=), (==), (-), Word)+import Data.Function (on)+import Math.NumberTheory.Utils.FromIntegral (wordToInt, intToWord)+import Data.Bits (Bits(..))+import Utils.Containers.Internal.BitUtil (highestBitMask)+#endif++-- | A set of 'Prime' integers.+newtype PrimeIntSet = PrimeIntSet {+  -- | Convert to a set of integers.+  unPrimeIntSet :: IntSet+  }+  deriving (Eq, Ord, Data, Show, Semigroup, Monoid, NFData)++instance GHC.Exts.IsList PrimeIntSet where+  type Item PrimeIntSet = Prime Int+  fromList = coerce IS.fromList+  toList = coerce IS.toList++-- | Build a singleton set.+singleton :: Prime Int -> PrimeIntSet+singleton = coerce IS.singleton++-- | Build a set from a list of primes.+fromList :: [Prime Int] -> PrimeIntSet+fromList = coerce IS.fromList++-- | Build a set from an ascending list of primes+-- (the precondition is not checked).+fromAscList :: [Prime Int] -> PrimeIntSet+fromAscList = coerce IS.fromAscList++-- | Build a set from an ascending list of distinct primes+-- (the precondition is not checked).+fromDistinctAscList :: [Prime Int] -> PrimeIntSet+fromDistinctAscList = coerce IS.fromDistinctAscList++-- | Insert a prime into the set.+insert :: Prime Int -> PrimeIntSet -> PrimeIntSet+insert = coerce IS.insert++-- | Delete an integer from the set.+delete :: Int -> PrimeIntSet -> PrimeIntSet+delete = coerce IS.delete++-- | Check whether the given prime is a member of the set.+member :: Prime Int -> PrimeIntSet -> Bool+member = coerce IS.member++-- | Check whether the given prime is not a member of the set.+notMember :: Prime Int -> PrimeIntSet -> Bool+notMember = coerce IS.notMember++-- | Find a prime in the set,+-- equal to the given integer, if any exists.+lookupEQ :: Int -> PrimeIntSet -> Maybe (Prime Int)+lookupEQ x xs+  | coerce member x xs = Just (Prime x)+  | otherwise          = Nothing++-- | Find the largest prime in the set,+-- smaller than the given integer, if any exists.+lookupLT :: Int -> PrimeIntSet -> Maybe (Prime Int)+lookupLT = coerce IS.lookupLT++-- | Find the smallest prime in the set,+-- greater than the given integer, if any exists.+lookupGT :: Int -> PrimeIntSet -> Maybe (Prime Int)+lookupGT = coerce IS.lookupGT++-- | Find the largest prime in the set,+-- smaller or equal to the given integer, if any exists.+lookupLE :: Int -> PrimeIntSet -> Maybe (Prime Int)+lookupLE = coerce IS.lookupLE++-- | Find the smallest prime in the set,+-- greater or equal to the given integer, if any exists.+lookupGE :: Int -> PrimeIntSet -> Maybe (Prime Int)+lookupGE = coerce IS.lookupGE++-- | Check whether the set is empty.+null :: PrimeIntSet -> Bool+null = coerce IS.null++-- | Cardinality of the set.+size :: PrimeIntSet -> Int+size = coerce IS.size++-- | Check whether the first argument is a subset of the second one.+isSubsetOf :: PrimeIntSet -> PrimeIntSet -> Bool+isSubsetOf = coerce IS.isSubsetOf++-- | Check whether the first argument is a proper subset of the second one.+isProperSubsetOf :: PrimeIntSet -> PrimeIntSet -> Bool+isProperSubsetOf = coerce IS.isProperSubsetOf++-- | Check whether two sets are disjoint.+disjoint :: PrimeIntSet -> PrimeIntSet -> Bool+disjoint = coerce IS.disjoint++-- | Difference between a set of primes and a set of integers.+difference :: PrimeIntSet -> IntSet -> PrimeIntSet+difference = coerce IS.difference++-- | An alias to 'difference'.+(\\) :: PrimeIntSet -> IntSet -> PrimeIntSet+(\\) = coerce (IS.\\)++infixl 9 \\{- -}++-- | Symmetric difference of two sets of primes.+symmetricDifference :: PrimeIntSet -> PrimeIntSet -> PrimeIntSet+#if MIN_VERSION_containers(0,8,0)+symmetricDifference = coerce IS.symmetricDifference+#else+symmetricDifference = coerce symmDiff+#endif++-- | Intersection of a set of primes and a set of integers.+intersection :: PrimeIntSet -> IntSet -> PrimeIntSet+intersection = coerce IS.intersection++-- | Filter primes satisfying a predicate.+filter :: (Prime Int -> Bool) -> PrimeIntSet -> PrimeIntSet+filter = coerce IS.filter++-- | Partition primes according to a predicate.+partition :: (Prime Int -> Bool) -> PrimeIntSet -> (PrimeIntSet, PrimeIntSet)+partition = coerce IS.partition++-- | Split into primes strictly less and strictly greater+-- than the first argument.+split :: Int -> PrimeIntSet -> (PrimeIntSet, PrimeIntSet)+split = coerce IS.split++-- | Simultaneous 'split' and 'member'.+splitMember :: Prime Int -> PrimeIntSet -> (PrimeIntSet, Bool, PrimeIntSet)+splitMember = coerce IS.splitMember++-- | Simultaneous 'split' and 'lookupEQ'.+splitLookupEQ :: Int -> PrimeIntSet -> (PrimeIntSet, Maybe (Prime Int), PrimeIntSet)+splitLookupEQ x xs = (lt, if eq then Just (Prime x) else Nothing, gt)+  where+    (lt, eq, gt) = coerce IS.splitMember x xs++-- | Decompose a set into pieces based on the structure of the underlying tree.+splitRoot :: PrimeIntSet -> [PrimeIntSet]+splitRoot = coerce IS.splitRoot++-- | Fold a set using the given right-associative operator.+foldr :: forall b. (Prime Int -> b -> b) -> b -> PrimeIntSet -> b+foldr = coerce (IS.foldr @b)++-- | Fold a set using the given left-associative operator.+foldl :: forall a. (a -> Prime Int -> a) -> a -> PrimeIntSet -> a+foldl = coerce (IS.foldl @a)++-- | A strict version of 'foldr'.+foldr' :: forall b. (Prime Int -> b -> b) -> b -> PrimeIntSet -> b+foldr' = coerce (IS.foldr' @b)++-- | A strict version of 'foldl'.+foldl' :: forall a. (a -> Prime Int -> a) -> a -> PrimeIntSet -> a+foldl' = coerce (IS.foldl' @a)++-- | Delete the smallest prime in the set.+deleteMin :: PrimeIntSet -> PrimeIntSet+deleteMin = coerce IS.deleteMin++-- | Delete the largest prime in the set.+deleteMax :: PrimeIntSet -> PrimeIntSet+deleteMax = coerce IS.deleteMax++-- | Split a set into the smallest prime and the rest, if non-empty.+minView :: PrimeIntSet -> Maybe (Prime Int, PrimeIntSet)+minView = coerce IS.minView++-- | Split a set into the largest prime and the rest, if non-empty.+maxView :: PrimeIntSet -> Maybe (Prime Int, PrimeIntSet)+maxView = coerce IS.maxView++-- | Convert the set to a list of ascending primes.+toAscList :: PrimeIntSet -> [Prime Int]+toAscList = coerce IS.toAscList++-- | Convert the set to a list of descending primes.+toDescList :: PrimeIntSet -> [Prime Int]+toDescList = coerce IS.toDescList++-------------------------------------------------------------------------------+-- IntSet helpers++#if !MIN_VERSION_containers(0,8,0)++-- | Symmetric difference of two sets.+-- Implementation is inspired by 'Data.IntSet.union'+-- and 'Data.IntSet.difference'.+symmDiff :: IntSet -> IntSet -> IntSet+symmDiff t1 t2 = case t1 of+  IS.Bin p1 m1 l1 r1 -> case t2 of+    IS.Bin p2 m2 l2 r2+      | shorter m1 m2 -> symmDiff1+      | shorter m2 m1 -> symmDiff2+      | p1 == p2      -> bin p1 m1 (symmDiff l1 l2) (symmDiff r1 r2)+      | otherwise     -> link p1 t1 p2 t2+      where+        symmDiff1+          | mask p2 m1 /= p1 = link p1 t1 p2 t2+          | p2 .&. m1 == 0   = bin p1 m1 (symmDiff l1 t2) r1+          | otherwise        = bin p1 m1 l1 (symmDiff r1 t2)+        symmDiff2+          | mask p1 m2 /= p2 = link p1 t1 p2 t2+          | p1 .&. m2 == 0   = bin p2 m2 (symmDiff t1 l2) r2+          | otherwise        = bin p2 m2 l2 (symmDiff t1 r2)+    IS.Tip kx bm -> symmDiffBM kx bm t1+    IS.Nil -> t1+  IS.Tip kx bm -> symmDiffBM kx bm t2+  IS.Nil -> t2++shorter :: Int -> Int -> Bool+shorter = (>) `on` intToWord++symmDiffBM :: Int -> Word -> IntSet -> IntSet+symmDiffBM !kx !bm t = case t of+  IS.Bin p m l r+    | mask kx m /= p -> link kx (IS.Tip kx bm) p t+    | kx .&. m == 0  -> bin p m (symmDiffBM kx bm l) r+    | otherwise      -> bin p m l (symmDiffBM kx bm r)+  IS.Tip kx' bm'+    | kx' == kx -> if bm' == bm then IS.Nil else IS.Tip kx (bm' `xor` bm)+    | otherwise -> link kx (IS.Tip kx bm) kx' t+  IS.Nil -> IS.Tip kx bm++link :: Int -> IntSet -> Int -> IntSet -> IntSet+link p1 t1 p2 t2+  | p1 .&. m == 0 = IS.Bin p m t1 t2+  | otherwise     = IS.Bin p m t2 t1+  where+    m = wordToInt (highestBitMask (intToWord p1 `xor` intToWord p2))+    p = mask p1 m+{-# INLINE link #-}++bin :: Int -> Int -> IntSet -> IntSet -> IntSet+bin p m l r = case r of+  IS.Nil -> l+  _ -> case l of+    IS.Nil -> r+    _ -> IS.Bin p m l r+{-# INLINE bin #-}++mask :: Int -> Int -> Int+mask i m = i .&. (complement (m - 1) `xor` m)+{-# INLINE mask #-}++#endif
− Math/NumberTheory/Primes/Sieve.hs 
@@ -1,62 +0,0 @@--- |--- Module:      Math.NumberTheory.Primes.Sieve--- Copyright:   (c) 2011 Daniel Fischer--- Licence:     MIT--- Maintainer:  Daniel Fischer <daniel.is.fischer@googlemail.com>--- Stability:   Provisional--- Portability: Non-portable (GHC extensions)------ Prime generation using a sieve.--- Currently, an enhanced sieve of Eratosthenes is used, switching to an--- Atkin sieve is planned (if I get around to implementing it and it's not slower).------ The sieve used is segmented, with a chunk size chosen to give good (enough)--- cache locality while still getting something substantial done per chunk.--- However, that means we must store data for primes up to the square root of--- where sieving is done, thus sieving primes up to @n@ requires--- @/O/(sqrt n/log n)@ space.-module Math.NumberTheory.Primes.Sieve-    ( -- * Limitations-      -- $limits--      -- * Sieves and lists-      primes-    , sieveFrom-    , PrimeSieve-    , primeSieve-    , psieveList-    , psieveFrom-    , primeList-    ) where--import Math.NumberTheory.Primes.Sieve.Eratosthenes---- $limits------ There are three factors limiting the range of these sieves.------ (1) Memory------ (2) Overflow------ (3) The internal representation of the state------ An Eratosthenes type sieve needs to store the primes up to the square root of--- the currently sieved region, thus requires @/O/(sqrt n\/log n)@ space.We store @16@ bytes--- of information per prime, thus a Gigabyte of memory takes you to about @1.6*10^18@.--- The @log@ doesn't change much in that range, so as a first approximation, doubling--- the storage increases the sieve range by a factor of four.------ On a 64-bit system, this is (currently) the only limitation to be concerned with, but--- with more than four Terabyte of memory, the fact that the internal representation--- currently limits the sieve range to about @6.8*10^25@ could become relevant.--- Overflow in array indexing doesn't become a concern before memory and internal--- representation would allow to sieve past @10^37@.------ On a 32-bit system, the internal representation imposes no additional limits,--- but overflow has to be reckoned with. On the one hand, the fact that arrays are--- 'Int'-indexed restricts the size of the prime store, on the other hand, overflow--- in calculating the indices to cross off multiples is possible before running out--- of memory. The former limits the upper bound of the monolithic 'primeSieve' to--- shortly above @8*10^9@, the latter limits the range of the segmented sieves to--- about @1.7*10^18@.
Math/NumberTheory/Primes/Sieve/Eratosthenes.hs view
@@ -3,66 +3,69 @@ -- Copyright:   (c) 2011 Daniel Fischer -- Licence:     MIT -- Maintainer:  Daniel Fischer <daniel.is.fischer@googlemail.com>--- Stability:   Provisional--- Portability: Non-portable (GHC extensions) -- -- Sieve ---{-# LANGUAGE CPP, BangPatterns, FlexibleContexts #-}+{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE LambdaCase          #-}+{-# LANGUAGE ScopedTypeVariables #-}+ {-# OPTIONS_GHC -fspec-constr-count=8 #-}-{-# OPTIONS_HADDOCK hide #-} module Math.NumberTheory.Primes.Sieve.Eratosthenes     ( primes-    , sieveFrom     , psieveFrom     , PrimeSieve(..)     , psieveList     , primeList     , primeSieve-    , nthPrimeCt-    , countFromTo-    , countAll-    , countToNth-    , sieveBytes     , sieveBits-    , sieveWords     , sieveRange     , sieveTo     ) where -#include "MachDeps.h"--import Control.Monad.ST-import Data.Array.ST import Control.Monad (when)+import Control.Monad.ST+import Data.Bit import Data.Bits-#if __GLASGOW_HASKELL__ < 709 || WORD_SIZE_IN_BITS == 32+import Data.Coerce+import Data.Proxy+import qualified Data.Vector.Unboxed as U+import qualified Data.Vector.Unboxed.Mutable as MU import Data.Word-#endif -import Math.NumberTheory.Powers.Squares (integerSquareRoot)-import Math.NumberTheory.Unsafe-import Math.NumberTheory.Utils-import Math.NumberTheory.Primes.Counting.Approximate import Math.NumberTheory.Primes.Sieve.Indexing+import Math.NumberTheory.Primes.Types+import Math.NumberTheory.Roots+import Math.NumberTheory.Utils.FromIntegral -#define IX_MASK     0xFFFFF-#define IX_BITS     20-#define IX_J_MASK   0x7FFFFF-#define IX_J_BITS   23-#define J_MASK      7-#define J_BITS      3-#define SIEVE_KB    128+iXMASK :: Num a => a+iXMASK   = 0xFFFFF +iXBITS :: Int+iXBITS   = 20++iXJMASK :: Num a => a+iXJMASK = 0x7FFFFF++iXJBITS :: Int+iXJBITS = 23++jMASK :: Int+jMASK    = 7++jBITS :: Int+jBITS    = 3+ -- Sieve in 128K chunks. -- Large enough to get something done per chunk -- and hopefully small enough to fit in the cache. sieveBytes :: Int-sieveBytes = SIEVE_KB*1024+sieveBytes = 128 * 1024  -- Number of bits per chunk. sieveBits :: Int-sieveBits = 8*sieveBytes+sieveBits = 8 * sieveBytes  -- Last index of chunk. lastIndex :: Int@@ -70,27 +73,10 @@  -- Range of a chunk. sieveRange :: Int-sieveRange = 30*sieveBytes--sieveWords :: Int-sieveWords = sieveBytes `quot` SIZEOF_HSWORD--#if SIZEOF_HSWORD == 8-type CacheWord = Word-#define RMASK 63-#define WSHFT 6-#define TOPB 32-#define TOPM 0xFFFFFFFF-#else-type CacheWord = Word64-#define RMASK 31-#define WSHFT 5-#define TOPB 16-#define TOPM 0xFFFF-#endif+sieveRange = 30 * sieveBytes  -- | Compact store of primality flags.-data PrimeSieve = PS !Integer {-# UNPACK #-} !(UArray Int Bool)+data PrimeSieve = PS !Integer {-# UNPACK #-} !(U.Vector Bit)  -- | Sieve primes up to (and including) a bound (or 7, if bound is smaller). --   For small enough bounds, this is more efficient than@@ -102,29 +88,65 @@ --   is often within memory limits, so don't give bounds larger than --   @8*10^9@ there. primeSieve :: Integer -> PrimeSieve-primeSieve bound = PS 0 (runSTUArray $ sieveTo bound)+primeSieve bound = PS 0 (runST $ sieveTo bound >>= U.unsafeFreeze)  -- | 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 -> [Prime a]+primeList ps@(PS v _)+  | doesNotFit (Proxy :: Proxy a) v+              = [] -- has an overflow already happened?+  | v == 0    = (coerce :: [a] -> [Prime a])+              $ takeWhileIncreasing $ 2 : 3 : 5 : primeListInternal ps+  | otherwise = (coerce :: [a] -> [Prime a])+              $ 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 (unBit . U.unsafeIndex bs) [lo..hi]+  where+    (lo, hi) = (0, U.length bs - 1) +-- | 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+-- [Prime 2,Prime 3,Prime 5,Prime 7,Prime 11,Prime 13,Prime 17,Prime 19,Prime 23,Prime 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+--+-- >>> primes !! 1000000 :: Prime Int -- (5.32 secs, 6,945,267,496 bytes)+-- Prime 15485867+-- >>> primes !! 1000000 :: Prime Int -- (5.19 secs, 6,945,267,496 bytes)+-- Prime 15485867+--+-- against+--+-- >>> let primes' = primes :: [Prime Int]+-- >>> primes' !! 1000000 :: Prime Int -- (5.29 secs, 6,945,269,856 bytes)+-- Prime 15485867+-- >>> primes' !! 1000000 :: Prime Int -- (0.02 secs, 336,232 bytes)+-- Prime 15485867+primes :: Integral a => [Prime a]+primes+  = (coerce :: [a] -> [Prime a])+  $ 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.@@ -133,35 +155,36 @@   where     plim = 4801     -- prime #647, 644 of them to use     sqlim = plim*plim-    cache = runSTUArray $ do-        sieve <- sieveTo 4801-        new <- unsafeNewArray_ (0,1287) :: ST s (STUArray s Int CacheWord)+    cache = runST $ do+        sieve <- sieveTo (4801 :: Integer)+        new <- MU.unsafeNew 1288 :: ST s (MU.MVector s Word64)         let fill j indx               | 1279 < indx = return new    -- index of 4801 = 159*30 + 31 ~> 159*8+7               | otherwise = do-                p <- unsafeRead sieve indx+                Bit p <- MU.unsafeRead sieve indx                 if p                   then do-                    let !i = indx .&. J_MASK-                        k = indx `shiftR` J_BITS-                        strt1 = (k*(30*k + 2*rho i) + byte i) `shiftL` J_BITS + fromIntegral (idx i)-                        !strt = fromIntegral (strt1 .&. IX_MASK)-                        !skip = fromIntegral (strt1 `shiftR` IX_BITS)-                        !ixes = fromIntegral indx `shiftL` IX_J_BITS + strt `shiftL` J_BITS + fromIntegral i-                    unsafeWrite new j skip-                    unsafeWrite new (j+1) ixes+                    let !i = indx .&. jMASK+                        k = indx `shiftR` jBITS+                        strt1 = (k*(30*k + 2*rho i) + byte i) `shiftL` jBITS + idx i+                        !strt = intToWord64 (strt1 .&. iXMASK)+                        !skip = intToWord64 (strt1 `shiftR` iXBITS)+                        !ixes = intToWord64 indx `shiftL` iXJBITS + strt `shiftL` jBITS + intToWord64 i+                    MU.unsafeWrite new j skip+                    MU.unsafeWrite new (j+1) ixes                     fill (j+2) (indx+1)                   else fill j (indx+1)-        fill 0 0+        vec <- fill 0 0+        U.unsafeFreeze vec -makeSieves :: Integer -> Integer -> Integer -> Integer -> UArray Int CacheWord -> [PrimeSieve]+makeSieves :: Integer -> Integer -> Integer -> Integer -> U.Vector Word64 -> [PrimeSieve] makeSieves plim sqlim bitOff valOff cache   | valOff' < sqlim =       let (nc, bs) = runST $ do-            cch <- unsafeThaw cache :: ST s (STUArray s Int CacheWord)+            cch <- U.unsafeThaw cache :: ST s (MU.MVector s Word64)             bs0 <- slice cch-            fcch <- unsafeFreeze cch-            fbs0 <- unsafeFreeze bs0+            fcch <- U.unsafeFreeze cch+            fbs0 <- U.unsafeFreeze bs0             return (fcch, fbs0)       in PS valOff bs : makeSieves plim sqlim bitOff' valOff' nc   | otherwise       =@@ -170,162 +193,121 @@           (nc,bs) = runST $ do             cch <- growCache bitOff plim cache             bs0 <- slice cch-            fcch <- unsafeFreeze cch-            fbs0 <- unsafeFreeze bs0+            fcch <- U.unsafeFreeze cch+            fbs0 <- U.unsafeFreeze bs0             return (fcch, fbs0)       in PS valOff bs : makeSieves plim' sqlim' bitOff' valOff' nc     where-      valOff' = valOff + fromIntegral sieveRange-      bitOff' = bitOff + fromIntegral sieveBits+      valOff' = valOff + intToInteger sieveRange+      bitOff' = bitOff + intToInteger sieveBits -slice :: STUArray s Int CacheWord -> ST s (STUArray s Int Bool)+slice :: MU.MVector s Word64 -> ST s (MU.MVector s Bit) slice cache = do-    hi <- snd `fmap` getBounds cache-    sieve <- newArray (0,lastIndex) True+    let hi = MU.length cache - 1+    sieve <- MU.replicate (lastIndex + 1) (Bit True)     let treat pr           | hi < pr     = return sieve           | otherwise   = do-            w <- unsafeRead cache pr+            w <- MU.unsafeRead cache pr             if w /= 0-              then unsafeWrite cache pr (w-1)+              then MU.unsafeWrite cache pr (w-1)               else do-                ixes <- unsafeRead cache (pr+1)-                let !stj = fromIntegral ixes .&. IX_J_MASK   -- position of multiple and index of cofactor-                    !ixw = fromIntegral (ixes `shiftR` IX_J_BITS)  -- prime data, up to 41 bits-                    !i = ixw .&. J_MASK+                ixes <- MU.unsafeRead cache (pr+1)+                let !stj = word64ToInt ixes .&. iXJMASK   -- position of multiple and index of cofactor+                    !ixw = word64ToInt (ixes `shiftR` iXJBITS)  -- prime data, up to 41 bits+                    !i = ixw .&. jMASK                     !k = ixw - i        -- On 32-bits, k > 44717396 means overflow is possible in tick-                    !o = i `shiftL` J_BITS-                    !j = stj .&. J_MASK          -- index of cofactor-                    !s = stj `shiftR` J_BITS     -- index of first multiple to tick off+                    !o = i `shiftL` jBITS+                    !j = stj .&. jMASK          -- index of cofactor+                    !s = stj `shiftR` jBITS     -- index of first multiple to tick off                 (n, u) <- tick k o j s-                let !skip = fromIntegral (n `shiftR` IX_BITS)-                    !strt = fromIntegral (n .&. IX_MASK)-                unsafeWrite cache pr skip-                unsafeWrite cache (pr+1) ((ixes .&. complement IX_J_MASK) .|. strt `shiftL` J_BITS .|. fromIntegral u)+                let !skip = intToWord64 (n `shiftR` iXBITS)+                    !strt = intToWord64 (n .&. iXMASK)+                MU.unsafeWrite cache pr skip+                MU.unsafeWrite cache (pr+1) ((ixes .&. complement iXJMASK) .|. strt `shiftL` jBITS .|. intToWord64 u)             treat (pr+2)         tick stp off j ix           | lastIndex < ix  = return (ix - sieveBits, j)           | otherwise       = do-            p <- unsafeRead sieve ix-            when p (unsafeWrite sieve ix False)-            tick stp off ((j+1) .&. J_MASK) (ix + stp*delta j + tau (off+j))+            Bit p <- MU.unsafeRead sieve ix+            when p (MU.unsafeWrite sieve ix (Bit False))+            tick stp off ((j+1) .&. jMASK) (ix + stp*delta j + tau (off+j))     treat 0  -- | Sieve up to bound in one go.-sieveTo :: Integer -> ST s (STUArray s Int Bool)+sieveTo :: Integer -> ST s (MU.MVector s Bit) sieveTo bound = arr   where     (bytes,lidx) = idxPr bound     !mxidx = 8*bytes+lidx     mxval :: Integer-    mxval = 30*fromIntegral bytes + fromIntegral (rho lidx)+    mxval = 30*intToInteger bytes + intToInteger (rho lidx)     !mxsve = integerSquareRoot mxval     (kr,r) = idxPr mxsve     !svbd = 8*kr+r     arr = do-        ar <- newArray (0,mxidx) True+        ar <- MU.replicate (mxidx + 1) (Bit True)         let start k i = 8*(k*(30*k+2*rho i) + byte i) + idx i             tick stp off j ix               | mxidx < ix = return ()               | otherwise  = do-                p <- unsafeRead ar ix-                when p (unsafeWrite ar ix False)-                tick stp off ((j+1) .&. J_MASK) (ix + stp*delta j + tau (off+j))+                Bit p <- MU.unsafeRead ar ix+                when p (MU.unsafeWrite ar ix (Bit False))+                tick stp off ((j+1) .&. jMASK) (ix + stp*delta j + tau (off+j))             sift ix               | svbd < ix = return ar               | otherwise = do-                p <- unsafeRead ar ix-                when p  (do let i = ix .&. J_MASK-                                k = ix `shiftR` J_BITS-                                !off = i `shiftL` J_BITS+                Bit p <- MU.unsafeRead ar ix+                when p  (do let i = ix .&. jMASK+                                k = ix `shiftR` jBITS+                                !off = i `shiftL` jBITS                                 !stp = ix - i                             tick stp off i (start k i))                 sift (ix+1)         sift 0 -growCache :: Integer -> Integer -> UArray Int CacheWord -> ST s (STUArray s Int CacheWord)+growCache :: Integer -> Integer -> U.Vector Word64 -> ST s (MU.MVector s Word64) growCache offset plim old = do-    let (_,num) = bounds old+    let num = U.length old - 1         (bt,ix) = idxPr plim         !start  = 8*bt+ix+1         !nlim   = plim+4800     sieve <- sieveTo nlim       -- Implement SieveFromTo for this, it's pretty wasteful when nlim isn't-    (_,hi) <- getBounds sieve   -- very small anymore+    let hi = MU.length sieve - 1     more <- countFromToWd start hi sieve-    new <- unsafeNewArray_ (0,num+2*more) :: ST s (STUArray s Int CacheWord)+    new <- MU.unsafeNew (1 + num + 2 * more) :: ST s (MU.MVector s Word64)     let copy i           | num < i   = return ()           | otherwise = do-            unsafeWrite new i (old `unsafeAt` i)+            MU.unsafeWrite new i (old `U.unsafeIndex` i)             copy (i+1)     copy 0     let fill j indx           | hi < indx = return new           | otherwise = do-            p <- unsafeRead sieve indx+            Bit p <- MU.unsafeRead sieve indx             if p               then do-                let !i = indx .&. J_MASK+                let !i = indx .&. jMASK                     k :: Integer-                    k = fromIntegral (indx `shiftR` J_BITS)-                    strt0 = ((k*(30*k + fromIntegral (2*rho i))-                                + fromIntegral (byte i)) `shiftL` J_BITS)-                                    + fromIntegral (idx i)+                    k = intToInteger (indx `shiftR` jBITS)+                    strt0 = ((k*(30*k + intToInteger (2*rho i))+                                + intToInteger (byte i)) `shiftL` jBITS)+                                    + intToInteger (idx i)                     strt1 = strt0 - offset-                    !strt = fromIntegral strt1 .&. IX_MASK-                    !skip = fromIntegral (strt1 `shiftR` IX_BITS)-                    !ixes = fromIntegral indx `shiftL` IX_J_BITS .|. strt `shiftL` J_BITS .|. fromIntegral i-                unsafeWrite new j skip-                unsafeWrite new (j+1) ixes+                    !strt = integerToWord64 strt1 .&. iXMASK+                    !skip = integerToWord64 (strt1 `shiftR` iXBITS)+                    !ixes = intToWord64 indx `shiftL` iXJBITS .|. strt `shiftL` jBITS .|. intToWord64 i+                MU.unsafeWrite new j skip+                MU.unsafeWrite new (j+1) ixes                 fill (j+2) (indx+1)               else fill j (indx+1)     fill (num+1) start --- Danger: relies on start and end being the first resp. last--- index in a Word--- Do not use except in growCache and psieveFrom {-# INLINE countFromToWd #-}-countFromToWd :: Int -> Int -> STUArray s Int Bool -> ST s Int-countFromToWd start end ba = do-    wa <- (castSTUArray :: STUArray s Int Bool -> ST s (STUArray s Int Word)) ba-    let !sb = start `shiftR` WSHFT-        !eb = end `shiftR` WSHFT-        count !acc i-          | eb < i    = return acc-          | otherwise = do-            w <- unsafeRead wa i-            count (acc + bitCountWord w) (i+1)-    count 0 sb---- count set bits between two indices (inclusive)--- start and end must both be valid indices and start <= end-countFromTo :: Int -> Int -> STUArray s Int Bool -> ST s Int-countFromTo start end ba = do-    wa <- (castSTUArray :: STUArray s Int Bool -> ST s (STUArray s Int Word)) ba-    let !sb = start `shiftR` WSHFT-        !si = start .&. RMASK-        !eb = end `shiftR` WSHFT-        !ei = end .&. RMASK-        count !acc i-            | i == eb = do-                w <- unsafeRead wa i-                return (acc + bitCountWord (w `shiftL` (RMASK - ei)))-            | otherwise = do-                w <- unsafeRead wa i-                count (acc + bitCountWord w) (i+1)-    if sb < eb-      then do-          w <- unsafeRead wa sb-          count (bitCountWord (w `shiftR` si)) (sb+1)-      else do-          w <- unsafeRead wa sb-          let !w1 = w `shiftR` si-          return (bitCountWord (w1 `shiftL` (RMASK - ei + si)))---- | @'sieveFrom' n@ creates the list of primes not less than @n@.-sieveFrom :: Integer -> [Integer]-sieveFrom n = case psieveFrom n of-                        ps -> dropWhile (< n) (ps >>= primeList)+countFromToWd :: Int -> Int -> MU.MVector s Bit -> ST s Int+countFromToWd start end =+  fmap countBits . U.unsafeFreeze . MU.slice start (end - start + 1)  -- | @'psieveFrom' n@ creates the list of 'PrimeSieve's starting roughly --   at @n@. Due to the organisation of the sieve, the list may contain@@ -335,124 +317,125 @@ 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       ssr = integerSquareRoot (start-1) + 1-      end1 = start - 6 + fromIntegral sieveRange+      end1 = start - 6 + intToInteger sieveRange       plim0 = integerSquareRoot end1       plim = plim0 + 4801 - (plim0 `rem` 4800)       sqlim = plim*plim-      cache = runSTUArray $ do+      cache = runST $ do           sieve <- sieveTo plim-          (lo,hi) <- getBounds sieve+          let (lo,hi) = (0, MU.length sieve - 1)           pct <- countFromToWd lo hi sieve-          new <- unsafeNewArray_ (0,2*pct-1) ::  ST s (STUArray s Int CacheWord)+          new <- MU.unsafeNew (2 * pct) ::  ST s (MU.MVector s Word64)           let fill j indx                 | hi < indx = return new                 | otherwise = do-                  isPr <- unsafeRead sieve indx+                  Bit isPr <- MU.unsafeRead sieve indx                   if isPr                     then do-                      let !i = indx .&. J_MASK-                          !moff = i `shiftL` J_BITS+                      let !i = indx .&. jMASK+                          !moff = i `shiftL` jBITS                           k :: Integer-                          k = fromIntegral (indx `shiftR` J_BITS)-                          p = 30*k+fromIntegral (rho i)+                          k = intToInteger (indx `shiftR` jBITS)+                          p = 30*k+intToInteger (rho i)                           q0 = (start-1) `quot` p-                          (skp0,q1) = q0 `quotRem` fromIntegral sieveRange+                          (skp0,q1) = q0 `quotRem` intToInteger sieveRange                           (b0,r0)                               | q1 == 0   = (-1,6)                               | q1 < 7    = (-1,7)-                              | otherwise = idxPr (fromIntegral q1 :: Int)+                              | otherwise = idxPr (integerToInt q1 :: Int)                           (b1,r1) | r0 == 7 = (b0+1,0)                                   | otherwise = (b0,r0+1)-                          b2 = skp0*fromIntegral sieveBytes + fromIntegral b1-                          strt0 = ((k*(30*b2 + fromIntegral (rho r1))-                                        + b2 * fromIntegral (rho i)-                                        + fromIntegral (mu (moff + r1))) `shiftL` J_BITS)-                                            + fromIntegral (nu (moff + r1))-                          strt1 = ((k*(30*k + fromIntegral (2*rho i))-                                      + fromIntegral (byte i)) `shiftL` J_BITS)-                                          + fromIntegral (idx i)+                          b2 = skp0*intToInteger sieveBytes + intToInteger b1+                          strt0 = ((k*(30*b2 + intToInteger (rho r1))+                                        + b2 * intToInteger (rho i)+                                        + intToInteger (mu (moff + r1))) `shiftL` jBITS)+                                            + intToInteger (nu (moff + r1))+                          strt1 = ((k*(30*k + intToInteger (2*rho i))+                                      + intToInteger (byte i)) `shiftL` jBITS)+                                          + intToInteger (idx i)                           (strt2,r2)                               | p < ssr   = (strt0 - bitOff,r1)                               | otherwise = (strt1 - bitOff, i)-                          !strt = fromIntegral strt2 .&. IX_MASK-                          !skip = fromIntegral (strt2 `shiftR` IX_BITS)-                          !ixes = fromIntegral indx `shiftL` IX_J_BITS .|. strt `shiftL` J_BITS .|. fromIntegral r2-                      unsafeWrite new j skip-                      unsafeWrite new (j+1) ixes+                          !strt = integerToWord64 strt2 .&. iXMASK+                          !skip = integerToWord64 (strt2 `shiftR` iXBITS)+                          !ixes = intToWord64 indx `shiftL` iXJBITS .|. strt `shiftL` jBITS .|. intToWord64 r2+                      MU.unsafeWrite new j skip+                      MU.unsafeWrite new (j+1) ixes                       fill (j+2) (indx+1)                     else fill j (indx+1)-          fill 0 0+          vec <- fill 0 0+          U.unsafeFreeze vec --- prime counting+{-# INLINE delta #-}+delta :: Int -> Int+delta = U.unsafeIndex deltas -nthPrimeCt :: Integer -> Integer-nthPrimeCt 1      = 2-nthPrimeCt 2      = 3-nthPrimeCt 3      = 5-nthPrimeCt 4      = 7-nthPrimeCt 5      = 11-nthPrimeCt 6      = 13-nthPrimeCt n-  | n < 1       = error "nthPrimeCt: negative argument"-  | n < 200000  = let bd0 = nthPrimeApprox n-                      bnd = bd0 + bd0 `quot` 32 + 37-                      !sv = primeSieve bnd-                  in countToNth (n-3) [sv]-  | otherwise   = countToNth (n-3) (psieveFrom (fromIntegral $ fromInteger n .&. (7 :: Int)))+deltas :: U.Vector Int+deltas = U.fromList [4,2,4,2,4,6,2,6] --- find the n-th set bit in a list of PrimeSieves,--- aka find the (n+3)-rd prime-countToNth :: Integer -> [PrimeSieve] -> Integer-countToNth !n ps = runST (countDown n ps)+{-# INLINE tau #-}+tau :: Int -> Int+tau = U.unsafeIndex taus -countDown :: Integer -> [PrimeSieve] -> ST s Integer-countDown !n (ps@(PS v0 bs) : more)-  | n > 278734 || (v0 /= 0 && n > 253000) = do-    ct <- countAll ps-    countDown (n - fromIntegral ct) more-  | otherwise = do-    stu <- unsafeThaw bs-    wa <- (castSTUArray :: STUArray s Int Bool -> ST s (STUArray s Int Word)) stu-    let go !k i-          | i == sieveWords  = countDown k more-          | otherwise   = do-            w <- unsafeRead wa i-            let !bc = fromIntegral $ bitCountWord w-            if bc < k-                then go (k-bc) (i+1)-                else let !j = fromIntegral (bc - k)-                         !px = top w j (fromIntegral bc)-                     in return (v0 + toPrim (px+(i `shiftL` WSHFT)))-    go n 0-countDown _ [] = error "Prime stream ended prematurely"+taus :: U.Vector Int+taus = U.fromList+        [  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+        ] --- count all set bits in a chunk, do it wordwise for speed.-countAll :: PrimeSieve -> ST s Int-countAll (PS _ bs) = do-    stu <- unsafeThaw bs-    wa <- (castSTUArray :: STUArray s Int Bool -> ST s (STUArray s Int Word)) stu-    let go !ct i-            | i == sieveWords = return ct-            | otherwise = do-                w <- unsafeRead wa i-                go (ct + bitCountWord w) (i+1)-    go 0 0+{-# INLINE byte #-}+byte :: Int -> Int+byte = U.unsafeIndex startByte --- Find the j-th highest of bc set bits in the Word w.-top :: Word -> Int -> Int -> Int-top w j bc = go 0 TOPB TOPM bn w-    where-      !bn = bc-j-      go !_ _ !_ !_ 0 = error "Too few bits set"-      go bs 0 _ _ wd = if wd .&. 1 == 0 then error "Too few bits, shift 0" else bs-      go bs a msk ix wd =-        case bitCountWord (wd .&. msk) of-          lc | lc < ix  -> go (bs+a) a msk (ix-lc) (wd `uncheckedShiftR` a)-             | otherwise ->-               let !na = a `shiftR` 1-               in go bs na (msk `uncheckedShiftR` na) ix wd+startByte :: U.Vector Int+startByte = U.fromList [1,3,5,9,11,17,27,31]++{-# INLINE idx #-}+idx :: Int -> Int+idx = U.unsafeIndex startIdx++startIdx :: U.Vector Int+startIdx = U.fromList [4,7,4,4,7,4,7,7]++{-# INLINE mu #-}+mu :: Int -> Int+mu = U.unsafeIndex mArr++{-# INLINE nu #-}+nu :: Int -> Int+nu = U.unsafeIndex nArr++mArr :: U.Vector Int+mArr = U.fromList+        [ 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 :: U.Vector Int+nArr = U.fromList+        [ 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+        ]
Math/NumberTheory/Primes/Sieve/Indexing.hs view
@@ -3,141 +3,41 @@ -- Copyright:   (c) 2011 Daniel Fischer -- Licence:     MIT -- Maintainer:  Daniel Fischer <daniel.is.fischer@googlemail.com>--- Stability:   Provisional--- Portability: Non-portable (GHC extensions) ---{-# OPTIONS_HADDOCK hide #-}+-- Auxiliary stuff, conversion between number and index,+-- remainders modulo 30 and related things. module Math.NumberTheory.Primes.Sieve.Indexing     ( idxPr     , toPrim-    , toIdx     , rho-    , delta-    , tau-    , byte-    , idx-    , mu-    , nu     ) where -import Data.Array.Unboxed import Data.Bits--import Math.NumberTheory.Unsafe---- Auxiliary stuff, conversion between number and index,--- remainders modulo 30 and related things.+import qualified Data.Vector.Unboxed as U --- {-# SPECIALISE idxPr :: Integer -> (Int,Int),---                         Int -> (Int,Int),---                         Word -> (Int,Int)---   #-} {-# INLINE idxPr #-} idxPr :: Integral a => a -> (Int,Int) idxPr n0     | n0 < 7    = (0, 0)     | otherwise = (fromIntegral bytes0, rm3)   where-    n = if (fromIntegral n0 .&. 1 == (1 :: Int))-            then n0 else (n0-1)+    n = if fromIntegral n0 .&. 1 == (1 :: Int)+            then n0 else n0 - 1     (bytes0,rm0) = (n-7) `quotRem` 30     rm1 = fromIntegral rm0     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-        ]+rho = U.unsafeIndex residues -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-        ]+residues :: U.Vector Int+residues = U.fromList [7,11,13,17,19,23,29,31]
− Math/NumberTheory/Primes/Sieve/Misc.hs 
@@ -1,405 +0,0 @@--- |--- Module:      Math.NumberTheory.Primes.Sieve.Misc--- Copyright:   (c) 2011 Daniel Fischer--- Licence:     MIT--- Maintainer:  Daniel Fischer <daniel.is.fischer@googlemail.com>--- 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--{--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 @&#960;(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 @&#8484;/(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 @&#955;(n)@ (or @&#968;(n)@), the smallest positive---   integer @e@ such that for all @a@ with @gcd a n == 1@ the congruence @a^e &#8801; 1 (mod n)@ holds,---   in other words, the (smallest) exponent of the group of units in @&#8484;/(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)
+ Math/NumberTheory/Primes/Small.hs view
@@ -0,0 +1,56 @@+-- |+-- Module:      Math.NumberTheory.Primes.Small+-- Copyright:   (c) 2019 Andrew Lelechenko+-- Licence:     MIT+-- Maintainer:  Andrew Lelechenko <andrew.lelechenko@gmail.com>+--+-- This is an internal module,+-- defining an array of precalculated primes < 2^16.+--++{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MagicHash    #-}++module Math.NumberTheory.Primes.Small+  ( smallPrimesPtr+  , smallPrimesLength+  , smallPrimesFromTo+  ) where++import GHC.Exts hiding (fromList)+import GHC.Word++smallPrimesFromTo :: Word16 -> Word16 -> [Word16]+smallPrimesFromTo from to = go k0#+  where+    !(Ptr smallPrimesAddr#) = smallPrimesPtr+    !(D# fromD#) = fromIntegral from+    k0#+      | from <= 5+      = 0#+      | otherwise+      = double2Int# (fromD# /## logDouble# fromD#)++    go k#+      | I# k# >= smallPrimesLength+      = []+      | p > to+      = []+      | p < from+      = go (k# +# 1#)+      | otherwise+      = p : go (k# +# 1#)+      where+        p = W16# (indexWord16OffAddr# smallPrimesAddr# k#)++-- length smallPrimes+smallPrimesLength :: Int+smallPrimesLength = 6542++-- concatMap (\x -> map Data.Char.chr [x `mod` 256, x `quot` 256]) smallPrimes+smallPrimesPtr :: Ptr Word16+smallPrimesPtr = Ptr "\STX\NUL\ETX\NUL\ENQ\NUL\a\NUL\v\NUL\r\NUL\DC1\NUL\DC3\NUL\ETB\NUL\GS\NUL\US\NUL%\NUL)\NUL+\NUL/\NUL5\NUL;\NUL=\NULC\NULG\NULI\NULO\NULS\NULY\NULa\NULe\NULg\NULk\NULm\NULq\NUL\DEL\NUL\131\NUL\137\NUL\139\NUL\149\NUL\151\NUL\157\NUL\163\NUL\167\NUL\173\NUL\179\NUL\181\NUL\191\NUL\193\NUL\197\NUL\199\NUL\211\NUL\223\NUL\227\NUL\229\NUL\233\NUL\239\NUL\241\NUL\251\NUL\SOH\SOH\a\SOH\r\SOH\SI\SOH\NAK\SOH\EM\SOH\ESC\SOH%\SOH3\SOH7\SOH9\SOH=\SOHK\SOHQ\SOH[\SOH]\SOHa\SOHg\SOHo\SOHu\SOH{\SOH\DEL\SOH\133\SOH\141\SOH\145\SOH\153\SOH\163\SOH\165\SOH\175\SOH\177\SOH\183\SOH\187\SOH\193\SOH\201\SOH\205\SOH\207\SOH\211\SOH\223\SOH\231\SOH\235\SOH\243\SOH\247\SOH\253\SOH\t\STX\v\STX\GS\STX#\STX-\STX3\STX9\STX;\STXA\STXK\STXQ\STXW\STXY\STX_\STXe\STXi\STXk\STXw\STX\129\STX\131\STX\135\STX\141\STX\147\STX\149\STX\161\STX\165\STX\171\STX\179\STX\189\STX\197\STX\207\STX\215\STX\221\STX\227\STX\231\STX\239\STX\245\STX\249\STX\SOH\ETX\ENQ\ETX\DC3\ETX\GS\ETX)\ETX+\ETX5\ETX7\ETX;\ETX=\ETXG\ETXU\ETXY\ETX[\ETX_\ETXm\ETXq\ETXs\ETXw\ETX\139\ETX\143\ETX\151\ETX\161\ETX\169\ETX\173\ETX\179\ETX\185\ETX\199\ETX\203\ETX\209\ETX\215\ETX\223\ETX\229\ETX\241\ETX\245\ETX\251\ETX\253\ETX\a\EOT\t\EOT\SI\EOT\EM\EOT\ESC\EOT%\EOT'\EOT-\EOT?\EOTC\EOTE\EOTI\EOTO\EOTU\EOT]\EOTc\EOTi\EOT\DEL\EOT\129\EOT\139\EOT\147\EOT\157\EOT\163\EOT\169\EOT\177\EOT\189\EOT\193\EOT\199\EOT\205\EOT\207\EOT\213\EOT\225\EOT\235\EOT\253\EOT\255\EOT\ETX\ENQ\t\ENQ\v\ENQ\DC1\ENQ\NAK\ENQ\ETB\ENQ\ESC\ENQ'\ENQ)\ENQ/\ENQQ\ENQW\ENQ]\ENQe\ENQw\ENQ\129\ENQ\143\ENQ\147\ENQ\149\ENQ\153\ENQ\159\ENQ\167\ENQ\171\ENQ\173\ENQ\179\ENQ\191\ENQ\201\ENQ\203\ENQ\207\ENQ\209\ENQ\213\ENQ\219\ENQ\231\ENQ\243\ENQ\251\ENQ\a\ACK\r\ACK\DC1\ACK\ETB\ACK\US\ACK#\ACK+\ACK/\ACK=\ACKA\ACKG\ACKI\ACKM\ACKS\ACKU\ACK[\ACKe\ACKy\ACK\DEL\ACK\131\ACK\133\ACK\157\ACK\161\ACK\163\ACK\173\ACK\185\ACK\187\ACK\197\ACK\205\ACK\211\ACK\217\ACK\223\ACK\241\ACK\247\ACK\251\ACK\253\ACK\t\a\DC3\a\US\a'\a7\aE\aK\aO\aQ\aU\aW\aa\am\as\ay\a\139\a\141\a\157\a\159\a\181\a\187\a\195\a\201\a\205\a\207\a\211\a\219\a\225\a\235\a\237\a\247\a\ENQ\b\SI\b\NAK\b!\b#\b'\b)\b3\b?\bA\bQ\bS\bY\b]\b_\bi\bq\b\131\b\155\b\159\b\165\b\173\b\189\b\191\b\195\b\203\b\219\b\221\b\225\b\233\b\239\b\245\b\249\b\ENQ\t\a\t\GS\t#\t%\t+\t/\t5\tC\tI\tM\tO\tU\tY\t_\tk\tq\tw\t\133\t\137\t\143\t\155\t\163\t\169\t\173\t\199\t\217\t\227\t\235\t\239\t\245\t\247\t\253\t\DC3\n\US\n!\n1\n9\n=\nI\nW\na\nc\ng\no\nu\n{\n\DEL\n\129\n\133\n\139\n\147\n\151\n\153\n\159\n\169\n\171\n\181\n\189\n\193\n\207\n\217\n\229\n\231\n\237\n\241\n\243\n\ETX\v\DC1\v\NAK\v\ESC\v#\v)\v-\v?\vG\vQ\vW\v]\ve\vo\v{\v\137\v\141\v\147\v\153\v\155\v\183\v\185\v\195\v\203\v\207\v\221\v\225\v\233\v\245\v\251\v\a\f\v\f\DC1\f%\f/\f1\fA\f[\f_\fa\fm\fs\fw\f\131\f\137\f\145\f\149\f\157\f\179\f\181\f\185\f\187\f\199\f\227\f\229\f\235\f\241\f\247\f\251\f\SOH\r\ETX\r\SI\r\DC3\r\US\r!\r+\r-\r=\r?\rO\rU\ri\ry\r\129\r\133\r\135\r\139\r\141\r\163\r\171\r\183\r\189\r\199\r\201\r\205\r\211\r\213\r\219\r\229\r\231\r\243\r\253\r\255\r\t\SO\ETB\SO\GS\SO!\SO'\SO/\SO5\SO;\SOK\SOW\SOY\SO]\SOk\SOq\SOu\SO}\SO\135\SO\143\SO\149\SO\155\SO\177\SO\183\SO\185\SO\195\SO\209\SO\213\SO\219\SO\237\SO\239\SO\249\SO\a\SI\v\SI\r\SI\ETB\SI%\SI)\SI1\SIC\SIG\SIM\SIO\SIS\SIY\SI[\SIg\SIk\SI\DEL\SI\149\SI\161\SI\163\SI\167\SI\173\SI\179\SI\181\SI\187\SI\209\SI\211\SI\217\SI\233\SI\239\SI\251\SI\253\SI\ETX\DLE\SI\DLE\US\DLE!\DLE%\DLE+\DLE9\DLE=\DLE?\DLEQ\DLEi\DLEs\DLEy\DLE{\DLE\133\DLE\135\DLE\145\DLE\147\DLE\157\DLE\163\DLE\165\DLE\175\DLE\177\DLE\187\DLE\193\DLE\201\DLE\231\DLE\241\DLE\243\DLE\253\DLE\ENQ\DC1\v\DC1\NAK\DC1'\DC1-\DC19\DC1E\DC1G\DC1Y\DC1_\DC1c\DC1i\DC1o\DC1\129\DC1\131\DC1\141\DC1\155\DC1\161\DC1\165\DC1\167\DC1\171\DC1\195\DC1\197\DC1\209\DC1\215\DC1\231\DC1\239\DC1\245\DC1\251\DC1\r\DC2\GS\DC2\US\DC2#\DC2)\DC2+\DC21\DC27\DC2A\DC2G\DC2S\DC2_\DC2q\DC2s\DC2y\DC2}\DC2\143\DC2\151\DC2\175\DC2\179\DC2\181\DC2\185\DC2\191\DC2\193\DC2\205\DC2\209\DC2\223\DC2\253\DC2\a\DC3\r\DC3\EM\DC3'\DC3-\DC37\DC3C\DC3E\DC3I\DC3O\DC3W\DC3]\DC3g\DC3i\DC3m\DC3{\DC3\129\DC3\135\DC3\139\DC3\145\DC3\147\DC3\157\DC3\159\DC3\175\DC3\187\DC3\195\DC3\213\DC3\217\DC3\223\DC3\235\DC3\237\DC3\243\DC3\249\DC3\255\DC3\ESC\DC4!\DC4/\DC43\DC4;\DC4E\DC4M\DC4Y\DC4k\DC4o\DC4q\DC4u\DC4\141\DC4\153\DC4\159\DC4\161\DC4\177\DC4\183\DC4\189\DC4\203\DC4\213\DC4\227\DC4\231\DC4\ENQ\NAK\v\NAK\DC1\NAK\ETB\NAK\US\NAK%\NAK)\NAK+\NAK7\NAK=\NAKA\NAKC\NAKI\NAK_\NAKe\NAKg\NAKk\NAK}\NAK\DEL\NAK\131\NAK\143\NAK\145\NAK\151\NAK\155\NAK\181\NAK\187\NAK\193\NAK\197\NAK\205\NAK\215\NAK\247\NAK\a\SYN\t\SYN\SI\SYN\DC3\SYN\NAK\SYN\EM\SYN\ESC\SYN%\SYN3\SYN9\SYN=\SYNE\SYNO\SYNU\SYNi\SYNm\SYNo\SYNu\SYN\147\SYN\151\SYN\159\SYN\169\SYN\175\SYN\181\SYN\189\SYN\195\SYN\207\SYN\211\SYN\217\SYN\219\SYN\225\SYN\229\SYN\235\SYN\237\SYN\247\SYN\249\SYN\t\ETB\SI\ETB#\ETB'\ETB3\ETBA\ETB]\ETBc\ETBw\ETB{\ETB\141\ETB\149\ETB\155\ETB\159\ETB\165\ETB\179\ETB\185\ETB\191\ETB\201\ETB\203\ETB\213\ETB\225\ETB\233\ETB\243\ETB\245\ETB\255\ETB\a\CAN\DC3\CAN\GS\CAN5\CAN7\CAN;\CANC\CANI\CANM\CANU\CANg\CANq\CANw\CAN}\CAN\DEL\CAN\133\CAN\143\CAN\155\CAN\157\CAN\167\CAN\173\CAN\179\CAN\185\CAN\193\CAN\199\CAN\209\CAN\215\CAN\217\CAN\223\CAN\229\CAN\235\CAN\245\CAN\253\CAN\NAK\EM\ESC\EM1\EM3\EME\EMI\EMQ\EM[\EMy\EM\129\EM\147\EM\151\EM\153\EM\163\EM\169\EM\171\EM\177\EM\181\EM\199\EM\207\EM\219\EM\237\EM\253\EM\ETX\SUB\ENQ\SUB\DC1\SUB\ETB\SUB!\SUB#\SUB-\SUB/\SUB5\SUB?\SUBM\SUBQ\SUBi\SUBk\SUB{\SUB}\SUB\135\SUB\137\SUB\147\SUB\167\SUB\171\SUB\173\SUB\177\SUB\185\SUB\201\SUB\207\SUB\213\SUB\215\SUB\227\SUB\243\SUB\251\SUB\255\SUB\ENQ\ESC#\ESC%\ESC/\ESC1\ESC7\ESC;\ESCA\ESCG\ESCO\ESCU\ESCY\ESCe\ESCk\ESCs\ESC\DEL\ESC\131\ESC\145\ESC\157\ESC\167\ESC\191\ESC\197\ESC\209\ESC\215\ESC\217\ESC\239\ESC\247\ESC\t\FS\DC3\FS\EM\FS'\FS+\FS-\FS3\FS=\FSE\FSK\FSO\FSU\FSs\FS\129\FS\139\FS\141\FS\153\FS\163\FS\165\FS\181\FS\183\FS\201\FS\225\FS\243\FS\249\FS\t\GS\ESC\GS!\GS#\GS5\GS9\GS?\GSA\GSK\GSS\GS]\GSc\GSi\GSq\GSu\GS{\GS}\GS\135\GS\137\GS\149\GS\153\GS\159\GS\165\GS\167\GS\179\GS\183\GS\197\GS\215\GS\219\GS\225\GS\245\GS\249\GS\SOH\RS\a\RS\v\RS\DC3\RS\ETB\RS%\RS+\RS/\RS=\RSI\RSM\RSO\RSm\RSq\RS\137\RS\143\RS\149\RS\161\RS\173\RS\187\RS\193\RS\197\RS\199\RS\203\RS\221\RS\227\RS\239\RS\247\RS\253\RS\SOH\US\r\US\SI\US\ESC\US9\USI\USK\USQ\USg\USu\US{\US\133\US\145\US\151\US\153\US\157\US\165\US\175\US\181\US\187\US\211\US\225\US\231\US\235\US\243\US\255\US\DC1 \ESC \GS ' ) - 3 G M Q _ c e i w } \137 \161 \171 \177 \185 \195 \197 \227 \231 \237 \239 \251 \255 \r!\DC3!5!A!I!O!Y![!_!s!}!\133!\149!\151!\161!\175!\179!\181!\193!\199!\215!\221!\229!\233!\241!\245!\251!\ETX\"\t\"\SI\"\ESC\"!\"%\"+\"1\"9\"K\"O\"c\"g\"s\"u\"\DEL\"\133\"\135\"\145\"\157\"\159\"\163\"\183\"\189\"\219\"\225\"\229\"\237\"\247\"\ETX#\t#\v#'#)#/#3#5#E#Q#S#Y#c#k#\131#\143#\149#\167#\173#\177#\191#\197#\201#\213#\221#\227#\239#\243#\249#\ENQ$\v$\ETB$\EM$)$=$A$C$M$_$g$k$y$}$\DEL$\133$\155$\161$\175$\181$\187$\197$\203$\205$\215$\217$\221$\223$\245$\247$\251$\SOH%\a%\DC3%\EM%'%1%=%C%K%O%s%\129%\141%\147%\151%\157%\159%\171%\177%\189%\205%\207%\217%\225%\247%\249%\ENQ&\v&\SI&\NAK&'&)&5&;&?&K&S&Y&e&i&o&{&\129&\131&\143&\155&\159&\173&\179&\195&\201&\203&\213&\221&\239&\245&\ETB'\EM'5'7'M'S'U'_'k'm's'w'\DEL'\149'\155'\157'\167'\175'\179'\185'\193'\197'\209'\227'\239'\ETX(\a(\r(\DC3(\ESC(\US(!(1(=(?(I(Q([(](a(g(u(\129(\151(\159(\187(\189(\193(\213(\217(\219(\223(\237(\247(\ETX)\ENQ)\DC1)!)#)?)G)])e)i)o)u)\131)\135)\143)\155)\161)\167)\171)\191)\195)\213)\215)\227)\233)\237)\243)\SOH*\DC3*\GS*%*/*O*U*_*e*k*m*s*\131*\137*\139*\151*\157*\185*\187*\197*\205*\221*\227*\235*\241*\251*\DC3+'+1+3+=+?+K+O+U+i+m+o+{+\141+\151+\153+\163+\165+\169+\189+\205+\231+\235+\243+\249+\253+\t,\SI,\ETB,#,/,5,9,A,W,Y,i,w,\129,\135,\147,\159,\173,\179,\183,\203,\207,\219,\225,\227,\233,\239,\255,\a-\GS-\US-;-C-I-M-a-e-q-\137-\157-\161-\169-\179-\181-\197-\199-\211-\223-\SOH.\ETX.\a.\r.\EM.\US.%.-.3.7.9.?.W.[.o.y.\DEL.\133.\147.\151.\157.\163.\165.\177.\183.\193.\195.\205.\211.\231.\235.\ENQ/\t/\v/\DC1/'/)/A/E/K/M/Q/W/o/u/}/\129/\131/\165/\171/\179/\195/\207/\209/\219/\221/\231/\237/\245/\249/\SOH0\r0#0)070;0U0Y0[0g0q0y0}0\133\&0\145\&0\149\&0\163\&0\169\&0\185\&0\191\&0\199\&0\203\&0\209\&0\215\&0\223\&0\229\&0\239\&0\251\&0\253\&0\ETX1\t1\EM1!1'1-191C1E1K1]1a1g1m1s1\DEL1\145\&1\153\&1\159\&1\169\&1\177\&1\195\&1\199\&1\213\&1\219\&1\237\&1\247\&1\255\&1\t2\NAK2\ETB2\GS2)252Y2]2c2k2o2u2w2{2\141\&2\153\&2\159\&2\167\&2\173\&2\179\&2\183\&2\201\&2\203\&2\207\&2\209\&2\233\&2\237\&2\243\&2\249\&2\a3%3+3/353A3G3[3_3g3k3s3y3\DEL3\131\&3\161\&3\163\&3\173\&3\185\&3\193\&3\203\&3\211\&3\235\&3\241\&3\253\&3\SOH4\SI4\DC34\EM4\ESC474E4U4W4c4i4m4\129\&4\139\&4\145\&4\151\&4\157\&4\165\&4\175\&4\187\&4\201\&4\211\&4\225\&4\241\&4\255\&4\t5\ETB5\GS5-535;5A5Q5e5o5q5w5{5}5\129\&5\141\&5\143\&5\153\&5\155\&5\161\&5\183\&5\189\&5\191\&5\195\&5\213\&5\221\&5\231\&5\239\&5\ENQ6\a6\DC16#6165676;6M6O6S6Y6a6k6m6\139\&6\143\&6\173\&6\175\&6\185\&6\187\&6\205\&6\209\&6\227\&6\233\&6\247\&6\SOH7\ETX7\a7\ESC7?7E7I7O7]7a7u7\DEL7\141\&7\163\&7\169\&7\171\&7\201\&7\213\&7\223\&7\241\&7\243\&7\247\&7\ENQ8\v8!83858A8G8K8S8W8_8e8o8q8}8\143\&8\153\&8\167\&8\183\&8\197\&8\201\&8\207\&8\213\&8\215\&8\221\&8\225\&8\227\&8\255\&8\SOH9\GS9#9%9)9/9=9A9M9[9k9y9}9\131\&9\139\&9\145\&9\149\&9\155\&9\161\&9\167\&9\175\&9\179\&9\187\&9\191\&9\205\&9\221\&9\229\&9\235\&9\239\&9\251\&9\ETX:\DC3:\NAK:\US:':+:1:K:Q:[:c:g:m:y:\135:\165:\169:\183:\205:\213:\225:\229:\235:\243:\253:\ETX;\DC1;\ESC;!;#;-;9;E;S;Y;_;q;{;\129;\137;\155;\159;\165;\167;\173;\183;\185;\195;\203;\209;\215;\225;\227;\245;\255;\SOH<\r<\DC1<\ETB<\US<)<5<C<O<S<[<e<k<q<\133<\137<\151<\167<\181<\191<\199<\209<\221<\223<\241<\247<\ETX=\r=\EM=\ESC=\US=!=-=3=7=?=C=o=s=u=y={=\133=\145=\151=\157=\171=\175=\181=\187=\193=\201=\207=\243=\ENQ>\t>\SI>\DC1>\GS>#>)>/>3>A>W>c>e>w>\129>\135>\161>\185>\189>\191>\195>\197>\201>\215>\219>\225>\231>\239>\255>\v?\r?7?;?=?A?Y?_?e?g?y?}?\139?\145?\173?\191?\205?\211?\221?\233?\235?\241?\253?\ESC@!@%@+@1@?@C@E@]@a@g@m@\135@\145@\163@\169@\177@\183@\189@\219@\223@\235@\247@\249@\tA\vA\DC1A\NAKA!A3A5A;A?AYAeAkAwA{A\147A\171A\183A\189A\191A\203A\231A\239A\243A\249A\ENQB\aB\EMB\USB#B)B/BCBSBUB[BaBsB}B\131B\133B\137B\145B\151B\157B\181B\197B\203B\211B\221B\227B\241B\aC\SIC\USC%C'C3C7C9COCWCiC\139C\141C\147C\165C\169C\175C\181C\189C\199C\207C\225C\231C\235C\237C\241C\249C\tD\vD\ETBD#D)D;D?DEDKDQDSDYDeDoD\131D\143D\161D\165D\171D\173D\189D\191D\201D\215D\219D\249D\251D\ENQE\DC1E\DC3E+E1EAEIESEUEaEwE}E\DELE\143E\163E\173E\175E\187E\199E\217E\227E\239E\245E\247E\SOHF\ETXF\tF\DC3F%F'F3F9F=FCFEF]FyF{F\DELF\129F\139F\141F\157F\169F\177F\199F\201F\207F\211F\213F\223F\229F\249F\ENQG\SIG\ETBG#G)G/G5G9GKGMGQG]GoGqG}G\131G\135G\137G\153G\165G\177G\191G\195G\203G\221G\225G\237G\251G\SOHH\aH\vH\DC3H\EMH\GSH1H=HGHUHYH[HkHmHyH\151H\155H\161H\185H\205H\229H\239H\247H\ETXI\rI\EMI\USI+I7I=IEIUIcIiImIsI\151I\171I\181I\211I\223I\225I\229I\231I\ETXJ\SIJ\GSJ#J9JAJEJWJ]JkJ}J\129J\135J\137J\143J\177J\195J\197J\213J\219J\237J\239J\aK\vK\rK\DC3K\USK%K1K;KCKIKYKeKmKwK\133K\173K\179K\181K\187K\191K\203K\217K\221K\223K\227K\229K\233K\241K\247K\SOHL\aL\rL\SIL\NAKL\ESCL!L-L3LKLULWLaLgLsLyL\DELL\141L\147L\153L\205L\225L\231L\241L\243L\253L\ENQM\SIM\ESCM'M)M/M3MAMQMYMeMkM\129M\131M\141M\149M\155M\177M\179M\201M\207M\215M\225M\237M\249M\251M\ENQN\vN\ETBN\EMN\GSN+N5N7N=NONSN_NgNyN\133N\139N\145N\149N\155N\161N\175N\179N\181N\193N\205N\209N\215N\233N\251N\aO\tO\EMO%O-O?OIOcOgOmOuO{O\129O\133O\135O\145O\165O\169O\175O\183O\187O\207O\217O\219O\253O\255O\ETXP\ESCP\GSP)P5P?PEPGPSPqPwP\131P\147P\159P\161P\183P\201P\213P\227P\237P\239P\251P\aQ\vQ\rQ\DC1Q\ETBQ#Q%Q5QGQIQqQyQ\137Q\143Q\151Q\161Q\163Q\167Q\185Q\193Q\203Q\211Q\223Q\227Q\245Q\247Q\tR\DC3R\NAKR\EMR\ESCR\USR'RCRERKRaRmRsR\129R\147R\151R\157R\165R\171R\177R\187R\195R\199R\201R\219R\229R\235R\255R\NAKS\GSS#SASESGSKS]ScS\129S\131S\135S\143S\149S\153S\159S\171S\185S\219S\233S\239S\243S\245S\251S\255S\rT\DC1T\DC3T\EMT5T7T;TATITSTUT_TaTkTmTqT\143T\145T\157T\169T\179T\197T\209T\223T\233T\235T\247T\253T\aU\rU\ESCU'U+U9U=UOUQU[UcUgUoUyU\133U\151U\169U\177U\183U\201U\217U\231U\237U\243U\253U\vV\SIV\NAKV\ETBV#V/V3V9V?VKVMV]V_VkVqVuV\131V\137V\141V\143V\155V\173V\177V\213V\231V\243V\255V\SOHW\ENQW\aW\vW\DC3W\USW#WGWMW_WaWmWwW}W\137W\161W\169W\175W\181W\197W\209W\211W\229W\239W\ETXX\rX\SIX\NAKX'X+X-XUX[X]XmXoXsX{X\141X\151X\163X\169X\171X\181X\189X\193X\199X\211X\213X\223X\241X\249X\255X\ETXY\ETBY\ESCY!YEYKYMYWY]YuY{Y\137Y\153Y\159Y\177Y\179Y\189Y\209Y\219Y\227Y\233Y\237Y\243Y\245Y\255Y\SOHZ\rZ\DC1Z\DC3Z\ETBZ\USZ)Z/Z;ZMZ[ZgZwZ\DELZ\133Z\149Z\157Z\161Z\163Z\169Z\187Z\211Z\229Z\239Z\251Z\253Z\SOH[\SI[\EM[\US[%[+[=[I[K[g[y[\135[\151[\163[\177[\201[\213[\235[\241[\243[\253[\ENQ\\\t\\\v\\\SI\\\GS\\)\\/\\3\\9\\G\\K\\M\\Q\\o\\u\\w\\}\\\135\\\137\\\167\\\189\\\191\\\195\\\201\\\209\\\215\\\221\\\237\\\249\\\ENQ]\v]\DC3]\ETB]\EM]1]=]A]G]O]U][]e]g]m]y]\149]\163]\169]\173]\185]\193]\199]\211]\215]\221]\235]\241]\253]\a^\r^\DC3^\ESC^!^'^+^-^1^9^E^I^W^i^s^u^\133^\139^\159^\165^\175^\183^\187^\217^\253^\t_\DC1_'_3_5_;_G_W_]_c_e_w_{_\149_\153_\161_\179_\189_\197_\207_\213_\227_\231_\251_\DC1`#`/`7`S`_`e`k`s`y`\133`\157`\173`\187`\191`\205`\217`\223`\233`\245`\ta\SIa\DC3a\ESCa-a9aKaUaWa[aoaya\135a\139a\145a\147a\157a\181a\199a\201a\205a\225a\241a\255a\tb\ETBb\GSb!b'b;bAbKbQbSb_beb\131b\141b\149b\155b\159b\165b\173b\213b\215b\219b\221b\233b\251b\255b\ENQc\rc\ETBc\GSc/cAcCcOc_cgcmcqcwc}c\DELc\179c\193c\197c\217c\233c\235c\239c\245c\SOHd\ETXd\td\NAKd!d'd+d9dCdIdOd]dgdud\133d\141d\147d\159d\163d\171d\193d\199d\201d\219d\241d\247d\249d\ve\DC1e!e/e9e?eKeMeSeWe_eqe}e\141e\143e\147e\161e\165e\173e\185e\197e\227e\243e\251e\255e\SOHf\af\GSf)f1f;fAfGfMf[fafsf}f\137f\139f\149f\151f\155f\181f\185f\197f\205f\209f\227f\235f\245f\ETXg\DC3g\EMg\USg'g1g7g?gEgQg[gogyg\129g\133g\145g\171g\189g\193g\205g\223g\229g\ETXh\th\DC1h\ETBh-h9h;h?hEhKhMhWhYh]hchihkhqh\135h\153h\159h\177h\189h\197h\209h\215h\225h\237h\239h\255h\SOHi\vi\ri\ETBi)i/iCiGiIiOieikiqi\131i\137i\151i\163i\179i\181i\187i\193i\197i\211i\223i\227i\229i\247i\aj+j7j=jKjgjijuj{j\135j\141j\145j\147j\163j\193j\201j\225j\231j\ENQk\SIk\DC1k#k'k-k9kAkWkYk_kuk\135k\137k\147k\149k\159k\189k\191k\219k\225k\239k\255k\ENQl\EMl)l+l1l5lUlYl[l_lelglslwl}l\131l\143l\145l\151l\155l\161l\169l\175l\179l\199l\203l\235l\245l\253l\rm\SIm%m'm+m1m9m?mOm]mamsm{m\DELm\147m\153m\165m\177m\183m\193m\195m\205m\207m\219m\247m\ETXn\NAKn\ETBn)n3n;nEnunwn{n\129n\137n\147n\149n\159n\189n\191n\227n\233n\243n\249n\251n\ro\DC1o\ETBo\USo/o=oMoSoaoeoyo}o\131o\133o\143o\155o\157o\163o\175o\181o\187o\191o\203o\205o\211o\215o\227o\233o\241o\245o\247o\253o\SIp\EMp\USp'p3p9pOpQpWpcpupyp\135p\141p\145p\165p\171p\187p\195p\199p\207p\229p\237p\249p\255p\ENQq\NAKq!q3qQqYq]q_qcqiq\131q\135q\149q\173q\195q\201q\203q\209q\219q\225q\239q\245q\251q\ar\DC1r\ETBr\EMr%r/r;rCrUrgrqrwr\DELr\143r\149r\155r\163r\179r\199r\203r\205r\215r\217r\227r\239r\245r\253r\ETXs\rs!s+s=sWs[sas\DELs\129s\133s\141s\147s\159s\171s\189s\193s\201s\223s\229s\231s\243s\NAKt\ESCt-t9t?tAt]tkt{t\137t\141t\155t\167t\171t\177t\183t\185t\221t\225t\231t\251t\au\USu%u;u=uMu_ukuwu\137u\139u\145u\151u\157u\161u\167u\181u\185u\187u\209u\217u\229u\235u\245u\251u\ETXv\SIv!v-v3v=v?vUvcvivovsv\133v\139v\159v\181v\183v\195v\219v\223v\241v\ETXw\ENQw\ESCw\GSw!w-w5wAwKwYw]w_wqw\129w\167w\173w\179w\185w\197w\207w\213w\225w\233w\239w\243w\249w\ax%x+x5x=xSxYxaxmxwxyx\131x\133x\139x\149x\151x\161x\173x\191x\211x\217x\221x\229x\251x\SOHy\ay%y+y9y?yKyWy]ygyiysy\145y\147y\163y\171y\175y\177y\183y\201y\205y\207y\213y\217y\243y\247y\255y\ENQz\SIz\DC1z\NAKz\ESCz#z'z-zKzWzYz_zeziz}z\147z\155z\159z\161z\165z\237z\245z\249z\SOH{\ETB{\EM{\GS{+{5{7{;{O{U{_{q{w{\139{\155{\161{\169{\175{\179{\199{\211{\233{\235{\239{\241{\253{\a|\EM|\ESC|1|7|I|g|i|s|\129|\139|\147|\163|\213|\219|\229|\237|\247|\ETX}\t}\ESC}\GS}3}9};}?}E}M}S}Y}c}u}w}\141}\143}\159}\173}\183}\189}\191}\203}\213}\233}\237}\251}\SOH~\ENQ~)~+~/~5~A~C~G~U~a~g~k~q~s~y~}~\145~\155~\157~\167~\173~\185~\187~\211~\223~\235~\241~\247~\251~\DC3\DEL\NAK\DEL\EM\DEL1\DEL3\DEL9\DEL=\DELC\DELK\DEL[\DELa\DELc\DELm\DELy\DEL\135\DEL\141\DEL\175\DEL\181\DEL\195\DEL\201\DEL\205\DEL\207\DEL\237\DEL\ETX\128\v\128\SI\128\NAK\128\GS\128!\128#\128?\128A\128G\128K\128e\128w\128\141\128\143\128\149\128\165\128\171\128\173\128\189\128\201\128\203\128\215\128\219\128\225\128\231\128\245\128\255\128\ENQ\129\r\129\EM\129\GS\129/\129\&1\129;\129C\129S\129Y\129_\129}\129\DEL\129\137\129\155\129\157\129\167\129\175\129\179\129\187\129\199\129\223\129\a\130\t\130\NAK\130\US\130%\130\&1\130\&3\130?\130C\130E\130I\130O\130a\130o\130{\130\129\130\133\130\147\130\177\130\181\130\189\130\199\130\207\130\213\130\223\130\241\130\249\130\253\130\v\131\ESC\131!\131)\131-\131\&3\131\&5\131?\131A\131M\131Q\131S\131W\131]\131e\131i\131o\131\143\131\167\131\177\131\185\131\203\131\213\131\215\131\221\131\231\131\233\131\237\131\255\131\ENQ\132\DC1\132\DC3\132#\132%\132;\132A\132G\132O\132a\132e\132w\132\131\132\139\132\145\132\149\132\169\132\175\132\205\132\227\132\239\132\241\132\247\132\t\133\r\133K\133O\133Q\133]\133c\133m\133o\133{\133\135\133\163\133\165\133\169\133\183\133\205\133\211\133\213\133\219\133\225\133\235\133\249\133\253\133\255\133\t\134\SI\134\ETB\134!\134/\134\&9\134?\134A\134M\134c\134u\134}\134\135\134\153\134\165\134\167\134\179\134\183\134\195\134\197\134\207\134\209\134\215\134\233\134\239\134\245\134\ETB\135\GS\135\US\135+\135/\135\&5\135G\135Y\135[\135k\135q\135w\135\DEL\135\133\135\143\135\161\135\169\135\179\135\187\135\197\135\199\135\203\135\221\135\247\135\ETX\136\EM\136\ESC\136\US\136!\136\&7\136=\136C\136Q\136a\136g\136{\136\133\136\145\136\147\136\165\136\207\136\211\136\235\136\237\136\243\136\253\136\t\137\v\137\DC1\137\ESC\137#\137'\137-\137\&9\137E\137M\137Q\137W\137c\137\129\137\149\137\155\137\179\137\185\137\195\137\207\137\209\137\219\137\239\137\245\137\251\137\255\137\v\138\EM\138#\138\&5\138A\138I\138O\138[\138_\138m\138w\138y\138\133\138\163\138\179\138\181\138\193\138\199\138\203\138\205\138\209\138\215\138\241\138\245\138\a\139\t\139\r\139\DC3\139!\139W\139]\139\145\139\147\139\163\139\169\139\175\139\187\139\213\139\217\139\219\139\225\139\247\139\253\139\255\139\v\140\ETB\140\GS\140'\140\&9\140;\140G\140S\140]\140o\140{\140\129\140\137\140\143\140\153\140\159\140\167\140\171\140\173\140\177\140\197\140\221\140\227\140\233\140\243\140\SOH\141\v\141\r\141#\141)\141\&7\141A\141[\141_\141q\141y\141\133\141\145\141\155\141\167\141\173\141\181\141\197\141\203\141\211\141\217\141\223\141\245\141\247\141\SOH\142\NAK\142\US\142%\142Q\142c\142i\142s\142u\142y\142\DEL\142\141\142\145\142\171\142\175\142\177\142\189\142\199\142\207\142\211\142\219\142\231\142\235\142\247\142\255\142\NAK\143\GS\143#\143-\143?\143E\143K\143S\143Y\143e\143i\143q\143\131\143\141\143\153\143\159\143\171\143\173\143\179\143\183\143\185\143\201\143\213\143\225\143\239\143\249\143\a\144\r\144\ETB\144#\144%\144\&1\144\&7\144;\144A\144C\144O\144S\144m\144s\144\133\144\139\144\149\144\155\144\157\144\175\144\185\144\193\144\197\144\223\144\233\144\253\144\ETX\145\DC3\145'\145\&3\145=\145E\145O\145Q\145a\145g\145{\145\133\145\153\145\157\145\187\145\189\145\193\145\201\145\217\145\219\145\237\145\241\145\243\145\249\145\ETX\146\NAK\146!\146/\146A\146G\146W\146k\146q\146u\146}\146\131\146\135\146\141\146\153\146\161\146\171\146\173\146\185\146\191\146\195\146\197\146\203\146\213\146\215\146\231\146\243\146\SOH\147\v\147\DC1\147\EM\147\US\147;\147=\147C\147U\147s\147\149\147\151\147\167\147\179\147\181\147\199\147\215\147\221\147\229\147\239\147\247\147\SOH\148\t\148\DC3\148?\148E\148K\148O\148c\148g\148i\148m\148{\148\151\148\159\148\165\148\181\148\195\148\225\148\231\148\ENQ\149\t\149\ETB\149!\149'\149-\149\&5\149\&9\149K\149W\149]\149_\149u\149\129\149\137\149\143\149\155\149\159\149\173\149\177\149\183\149\185\149\189\149\207\149\227\149\233\149\249\149\US\150/\150\&1\150\&5\150;\150=\150e\150\143\150\157\150\161\150\167\150\169\150\193\150\203\150\209\150\211\150\229\150\239\150\251\150\253\150\r\151\SI\151\NAK\151%\151+\151\&3\151\&7\151\&9\151C\151I\151Q\151[\151]\151o\151\DEL\151\135\151\147\151\165\151\177\151\183\151\195\151\205\151\211\151\217\151\235\151\247\151\ENQ\152\t\152\v\152\NAK\152)\152/\152;\152A\152Q\152k\152o\152\129\152\131\152\135\152\167\152\177\152\185\152\191\152\195\152\201\152\207\152\221\152\227\152\245\152\249\152\251\152\r\153\ETB\153\US\153)\153\&1\153;\153=\153A\153G\153I\153S\153}\153\133\153\145\153\149\153\155\153\173\153\175\153\191\153\199\153\203\153\205\153\215\153\229\153\241\153\251\153\SI\154\DC3\154\ESC\154%\154K\154O\154U\154W\154a\154u\154\DEL\154\139\154\145\154\157\154\183\154\195\154\199\154\207\154\235\154\243\154\247\154\255\154\ETB\155\GS\155'\155/\155\&5\155E\155Q\155Y\155c\155o\155w\155\141\155\147\155\149\155\159\155\161\155\167\155\177\155\183\155\189\155\197\155\203\155\207\155\221\155\249\155\SOH\156\DC1\156#\156+\156/\156\&5\156I\156M\156_\156e\156g\156\DEL\156\151\156\157\156\163\156\175\156\187\156\191\156\193\156\215\156\217\156\227\156\233\156\241\156\253\156\SOH\157\NAK\157'\157-\157\&1\157=\157U\157[\157a\157\151\157\159\157\165\157\169\157\195\157\231\157\235\157\237\157\241\157\v\158\ETB\158#\158'\158-\158\&3\158;\158G\158Q\158S\158_\158o\158\129\158\135\158\143\158\149\158\161\158\179\158\189\158\191\158\245\158\249\158\251\158\ENQ\159#\159/\159\&7\159;\159C\159S\159a\159m\159s\159w\159}\159\137\159\143\159\145\159\149\159\163\159\175\159\179\159\193\159\199\159\223\159\229\159\235\159\245\159\SOH\160\r\160!\160\&3\160\&9\160?\160O\160W\160[\160a\160u\160y\160\153\160\157\160\171\160\181\160\183\160\189\160\201\160\217\160\219\160\223\160\229\160\241\160\243\160\253\160\ENQ\161\v\161\SI\161\DC1\161\ESC\161)\161/\161\&5\161A\161S\161u\161}\161\135\161\141\161\165\161\171\161\173\161\183\161\195\161\197\161\227\161\237\161\251\161\a\162\DC3\162#\162)\162/\162\&1\162C\162G\162M\162k\162y\162}\162\131\162\137\162\139\162\145\162\149\162\155\162\169\162\175\162\179\162\187\162\197\162\209\162\215\162\247\162\SOH\163\t\163\US\163!\163+\163\&1\163I\163Q\163U\163s\163y\163{\163\135\163\151\163\159\163\165\163\169\163\175\163\183\163\199\163\213\163\219\163\225\163\229\163\231\163\241\163\253\163\255\163\SI\164\GS\164!\164#\164'\164;\164M\164W\164Y\164c\164i\164u\164\147\164\155\164\173\164\185\164\195\164\197\164\203\164\209\164\213\164\225\164\237\164\239\164\243\164\255\164\DC1\165)\165+\165\&5\165;\165C\165S\165[\165a\165m\165w\165\133\165\139\165\151\165\157\165\163\165\167\165\169\165\193\165\197\165\203\165\211\165\217\165\221\165\223\165\227\165\233\165\247\165\251\165\ETX\166\r\166%\166=\166I\166K\166Q\166]\166s\166\145\166\147\166\153\166\171\166\181\166\187\166\193\166\201\166\205\166\207\166\213\166\223\166\231\166\241\166\247\166\255\166\SI\167\NAK\167#\167)\167-\167E\167M\167W\167Y\167e\167k\167o\167\147\167\149\167\171\167\177\167\185\167\191\167\201\167\209\167\215\167\227\167\237\167\251\167\ENQ\168\v\168\GS\168)\168+\168\&7\168;\168U\168_\168m\168}\168\143\168\151\168\169\168\181\168\193\168\199\168\215\168\229\168\253\168\a\169\DC3\169\ESC\169\&1\169\&7\169\&9\169C\169\DEL\169\133\169\135\169\139\169\147\169\163\169\177\169\187\169\193\169\217\169\223\169\235\169\253\169\NAK\170\ETB\170\&5\170\&9\170;\170G\170M\170W\170Y\170]\170k\170q\170\129\170\131\170\141\170\149\170\171\170\191\170\197\170\201\170\233\170\239\170\SOH\171\ENQ\171\a\171\v\171\r\171\DC1\171\EM\171M\171[\171q\171s\171\137\171\157\171\167\171\175\171\185\171\187\171\193\171\197\171\211\171\215\171\221\171\241\171\245\171\251\171\253\171\t\172\NAK\172\ESC\172'\172\&7\172\&9\172E\172O\172W\172[\172a\172c\172\DEL\172\139\172\147\172\157\172\169\172\171\172\175\172\189\172\217\172\225\172\231\172\235\172\237\172\241\172\247\172\249\172\ENQ\173?\173E\173S\173]\173_\173e\173\129\173\161\173\165\173\195\173\203\173\209\173\213\173\219\173\231\173\243\173\245\173\249\173\255\173\ENQ\174\DC3\174#\174+\174I\174M\174O\174Y\174a\174g\174k\174q\174\139\174\143\174\155\174\157\174\167\174\185\174\197\174\209\174\227\174\229\174\233\174\245\174\253\174\t\175\DC3\175'\175+\175\&3\175C\175O\175W\175]\175m\175u\175\DEL\175\139\175\153\175\159\175\163\175\171\175\183\175\187\175\207\175\213\175\253\175\ENQ\176\NAK\176\ESC\176?\176A\176G\176K\176Q\176S\176i\176{\176}\176\135\176\141\176\177\176\191\176\203\176\207\176\225\176\233\176\237\176\251\176\ENQ\177\a\177\DC1\177\EM\177\GS\177\US\177\&1\177A\177M\177[\177e\177s\177y\177\DEL\177\169\177\179\177\185\177\191\177\211\177\221\177\229\177\241\177\245\177\SOH\178\DC3\178\NAK\178\US\178-\178?\178I\178[\178c\178i\178m\178{\178\129\178\139\178\169\178\183\178\189\178\195\178\199\178\211\178\249\178\253\178\255\178\ETX\179\t\179\DC1\179\GS\179'\179-\179?\179E\179w\179}\179\129\179\135\179\147\179\155\179\165\179\197\179\203\179\225\179\227\179\237\179\249\179\v\180\r\180\DC3\180\ETB\180\&5\180=\180C\180I\180[\180e\180g\180k\180w\180\139\180\149\180\157\180\181\180\191\180\193\180\199\180\221\180\227\180\229\180\247\180\SOH\181\r\181\SI\181-\181?\181K\181g\181i\181o\181s\181y\181\135\181\141\181\153\181\163\181\171\181\175\181\187\181\213\181\223\181\231\181\237\181\253\181\255\181\t\182\ESC\182)\182/\182\&3\182\&9\182G\182W\182Y\182_\182c\182o\182\131\182\135\182\155\182\159\182\165\182\177\182\179\182\215\182\219\182\225\182\227\182\237\182\239\182\ENQ\183\r\183\DC3\183\GS\183)\183\&5\183G\183U\183m\183\145\183\149\183\169\183\193\183\203\183\209\183\211\183\239\183\245\183\a\184\SI\184\DC3\184\EM\184!\184'\184+\184-\184\&9\184U\184g\184u\184\133\184\147\184\165\184\175\184\183\184\189\184\193\184\199\184\205\184\213\184\235\184\247\184\249\184\ETX\185\NAK\185\ESC\185\GS\185/\185\&9\185;\185G\185Q\185c\185\131\185\137\185\141\185\147\185\153\185\161\185\167\185\173\185\183\185\203\185\209\185\221\185\231\185\239\185\249\185\a\186\r\186\ETB\186%\186)\186+\186A\186S\186U\186_\186a\186e\186y\186}\186\DEL\186\161\186\163\186\175\186\181\186\191\186\193\186\203\186\221\186\227\186\241\186\253\186\t\187\US\187'\187-\187=\187C\187K\187O\187[\187a\187i\187m\187\145\187\151\187\157\187\177\187\201\187\207\187\219\187\237\187\247\187\249\187\ETX\188\GS\188#\188\&3\188;\188A\188E\188]\188o\188w\188\131\188\143\188\153\188\171\188\183\188\185\188\209\188\213\188\225\188\243\188\255\188\r\189\ETB\189\EM\189\GS\189\&5\189A\189O\189Y\189_\189a\189g\189k\189q\189\139\189\143\189\149\189\155\189\157\189\179\189\187\189\205\189\209\189\227\189\235\189\239\189\a\190\t\190\NAK\190!\190%\190'\190[\190]\190o\190u\190y\190\DEL\190\139\190\141\190\147\190\159\190\169\190\177\190\181\190\183\190\207\190\217\190\219\190\229\190\231\190\243\190\249\190\v\191\&3\191\&9\191M\191]\191_\191k\191q\191{\191\135\191\137\191\141\191\147\191\161\191\173\191\185\191\207\191\213\191\221\191\225\191\227\191\243\191\ENQ\192\DC1\192\DC3\192\EM\192)\192/\192\&1\192\&7\192;\192G\192e\192m\192}\192\DEL\192\145\192\155\192\179\192\181\192\187\192\211\192\215\192\217\192\239\192\241\192\SOH\193\ETX\193\t\193\NAK\193\EM\193+\193\&3\193\&7\193E\193I\193[\193s\193y\193{\193\129\193\139\193\141\193\151\193\189\193\195\193\205\193\219\193\225\193\231\193\255\193\ETX\194\ENQ\194\DC1\194!\194/\194?\194K\194M\194S\194]\194w\194{\194}\194\137\194\143\194\147\194\159\194\167\194\179\194\189\194\207\194\213\194\227\194\255\194\SOH\195\a\195\DC1\195\DC3\195\ETB\195%\195G\195I\195O\195e\195g\195q\195\DEL\195\131\195\133\195\149\195\157\195\167\195\173\195\181\195\191\195\199\195\203\195\209\195\211\195\227\195\233\195\239\195\SOH\196\US\196-\196\&3\196\&7\196U\196W\196a\196o\196s\196\135\196\145\196\153\196\157\196\165\196\183\196\187\196\201\196\207\196\211\196\235\196\241\196\247\196\t\197\ESC\197\GS\197A\197G\197Q\197_\197k\197o\197u\197w\197\149\197\155\197\159\197\161\197\167\197\195\197\215\197\219\197\239\197\251\197\DC3\198#\198\&5\198A\198O\198U\198Y\198e\198\133\198\145\198\151\198\161\198\169\198\179\198\185\198\203\198\205\198\221\198\235\198\241\198\a\199\r\199\EM\199\ESC\199-\199\&1\199\&9\199W\199c\199g\199s\199u\199\DEL\199\165\199\187\199\189\199\193\199\207\199\213\199\225\199\249\199\253\199\255\199\ETX\200\DC1\200\GS\200'\200)\200\&9\200?\200S\200W\200k\200\129\200\141\200\143\200\147\200\149\200\161\200\183\200\207\200\213\200\219\200\221\200\227\200\231\200\237\200\239\200\249\200\ENQ\201\DC1\201\ETB\201\EM\201\US\201/\201\&7\201=\201A\201S\201_\201k\201y\201}\201\137\201\143\201\151\201\157\201\175\201\181\201\191\201\203\201\217\201\223\201\227\201\235\201\SOH\202\a\202\t\202%\202\&7\202\&9\202K\202U\202[\202i\202s\202u\202\DEL\202\141\202\147\202\157\202\159\202\181\202\187\202\195\202\201\202\217\202\229\202\237\202\ETX\203\ENQ\203\t\203\ETB\203)\203\&5\203;\203S\203Y\203c\203e\203q\203\135\203\153\203\159\203\179\203\185\203\195\203\209\203\213\203\215\203\221\203\233\203\255\203\r\204\EM\204\GS\204#\204+\204A\204C\204M\204Y\204a\204\137\204\139\204\145\204\155\204\163\204\167\204\209\204\229\204\233\204\t\205\NAK\205\US\205%\205\&1\205=\205?\205I\205Q\205W\205[\205c\205g\205\129\205\147\205\151\205\159\205\187\205\193\205\211\205\217\205\229\205\231\205\241\205\247\205\253\205\v\206\NAK\206!\206/\206G\206M\206Q\206e\206{\206}\206\143\206\147\206\153\206\165\206\167\206\183\206\201\206\215\206\221\206\227\206\231\206\237\206\245\206\a\207\v\207\EM\207\&7\207;\207M\207U\207_\207a\207e\207m\207y\207}\207\137\207\155\207\157\207\169\207\179\207\181\207\197\207\205\207\209\207\239\207\241\207\247\207\DC3\208\NAK\208\US\208!\208\&3\208=\208K\208O\208i\208o\208\129\208\133\208\153\208\159\208\163\208\171\208\189\208\193\208\205\208\231\208\255\208\ETX\209\ETB\209-\209/\209A\209W\209Y\209]\209i\209k\209q\209w\209}\209\129\209\135\209\149\209\153\209\177\209\189\209\195\209\213\209\215\209\227\209\255\209\r\210\DC1\210\ETB\210\US\210\&5\210;\210G\210Y\210a\210e\210y\210\DEL\210\131\210\137\210\139\210\157\210\163\210\167\210\179\210\191\210\199\210\227\210\233\210\241\210\251\210\253\210\NAK\211!\211+\211C\211K\211U\211i\211u\211{\211\135\211\147\211\151\211\165\211\177\211\201\211\235\211\253\211\ENQ\212\SI\212\NAK\212'\212/\212\&3\212;\212K\212Y\212_\212c\212i\212\129\212\131\212\137\212\141\212\147\212\149\212\165\212\171\212\177\212\197\212\221\212\225\212\227\212\231\212\245\212\249\212\v\213\r\213\DC3\213\US\213#\213\&1\213\&5\213\&7\213I\213Y\213_\213e\213g\213w\213\139\213\145\213\151\213\181\213\185\213\193\213\199\213\223\213\239\213\245\213\251\213\ETX\214\SI\214-\214\&1\214C\214U\214]\214a\214{\214\133\214\135\214\157\214\165\214\175\214\189\214\195\214\199\214\217\214\225\214\237\214\t\215\v\215\DC1\215\NAK\215!\215'\215?\215E\215M\215W\215k\215{\215\131\215\161\215\167\215\173\215\177\215\179\215\189\215\203\215\209\215\219\215\251\215\DC1\216#\216%\216)\216+\216/\216\&7\216M\216U\216g\216s\216\143\216\145\216\161\216\173\216\191\216\205\216\215\216\233\216\245\216\251\216\ESC\217%\217\&3\217\&9\217C\217E\217O\217Q\217W\217m\217o\217s\217y\217\129\217\139\217\145\217\159\217\165\217\169\217\181\217\211\217\235\217\241\217\247\217\255\217\ENQ\218\t\218\v\218\SI\218\NAK\218\GS\218#\218)\218?\218Q\218Y\218]\218_\218q\218w\218{\218}\218\141\218\159\218\179\218\189\218\195\218\201\218\231\218\233\218\245\218\DC1\219\ETB\219\GS\219#\219%\219\&1\219;\219C\219U\219g\219k\219s\219\133\219\143\219\145\219\173\219\175\219\185\219\199\219\203\219\205\219\235\219\247\219\r\220'\220\&1\220\&9\220?\220I\220Q\220a\220o\220u\220{\220\133\220\147\220\153\220\157\220\159\220\169\220\181\220\183\220\189\220\199\220\207\220\211\220\213\220\223\220\249\220\SI\221\NAK\221\ETB\221#\221\&5\221\&9\221S\221W\221_\221i\221o\221}\221\135\221\137\221\155\221\161\221\171\221\191\221\197\221\203\221\207\221\231\221\233\221\237\221\245\221\251\221\v\222\EM\222)\222;\222=\222A\222M\222O\222Y\222[\222a\222m\222w\222}\222\131\222\151\222\157\222\161\222\167\222\205\222\209\222\215\222\227\222\241\222\245\222\SOH\223\t\223\DC3\223\US\223+\223\&3\223\&7\223=\223K\223U\223[\223g\223i\223s\223\133\223\135\223\153\223\163\223\171\223\181\223\183\223\195\223\199\223\213\223\241\223\243\223\ETX\224\ENQ\224\ETB\224\GS\224'\224-\224\&5\224E\224S\224q\224{\224\143\224\149\224\159\224\183\224\185\224\213\224\215\224\227\224\243\224\249\224\SOH\225%\225)\225\&1\225\&5\225C\225O\225Y\225a\225m\225q\225w\225\DEL\225\131\225\137\225\151\225\173\225\181\225\187\225\191\225\193\225\203\225\209\225\229\225\239\225\247\225\253\225\ETX\226\EM\226+\226-\226=\226C\226W\226[\226u\226y\226\135\226\157\226\171\226\175\226\187\226\193\226\201\226\205\226\211\226\217\226\243\226\253\226\255\226\DC1\227#\227'\227)\227\&9\227;\227M\227Q\227W\227_\227c\227i\227u\227w\227}\227\131\227\159\227\197\227\201\227\209\227\225\227\251\227\255\227\SOH\228\v\228\ETB\228\EM\228#\228+\228\&1\228;\228G\228I\228S\228U\228m\228q\228\143\228\169\228\175\228\181\228\199\228\205\228\211\228\233\228\235\228\245\228\a\229!\229%\229\&7\229?\229E\229K\229W\229g\229m\229u\229\133\229\139\229\147\229\163\229\165\229\207\229\t\230\DC1\230\NAK\230\ESC\230\GS\230!\230)\230\&9\230?\230S\230W\230c\230o\230u\230\129\230\131\230\141\230\143\230\149\230\171\230\173\230\183\230\189\230\197\230\203\230\213\230\227\230\233\230\239\230\243\230\ENQ\231\r\231\ETB\231\US\231/\231=\231G\231I\231S\231U\231a\231g\231k\231\DEL\231\137\231\145\231\197\231\205\231\215\231\221\231\223\231\233\231\241\231\251\231\SOH\232\a\232\SI\232\EM\232\ESC\232\&1\232\&3\232\&7\232=\232K\232O\232Q\232i\232u\232y\232\147\232\165\232\169\232\175\232\189\232\219\232\225\232\229\232\235\232\237\232\ETX\233\v\233\SI\233\NAK\233\ETB\233-\233\&3\233;\233K\233Q\233_\233c\233i\233{\233\131\233\143\233\149\233\161\233\185\233\215\233\231\233\239\233\DC1\234\EM\234/\234\&5\234C\234M\234_\234m\234q\234}\234\133\234\137\234\173\234\179\234\185\234\187\234\197\234\199\234\203\234\223\234\229\234\235\234\245\234\SOH\235\a\235\t\235\&1\235\&9\235?\235[\235a\235c\235o\235\129\235\133\235\157\235\171\235\177\235\183\235\193\235\213\235\223\235\237\235\253\235\v\236\ESC\236!\236)\236M\236Q\236]\236i\236o\236{\236\173\236\185\236\191\236\195\236\201\236\207\236\215\236\221\236\231\236\233\236\243\236\245\236\a\237\DC1\237\US\237/\237\&7\237=\237A\237U\237Y\237[\237e\237k\237y\237\139\237\149\237\187\237\197\237\215\237\217\237\227\237\229\237\241\237\245\237\247\237\251\237\t\238\SI\238\EM\238!\238I\238O\238c\238g\238s\238{\238\129\238\163\238\171\238\193\238\201\238\213\238\223\238\225\238\241\238\ESC\239'\239/\239E\239M\239c\239k\239q\239\147\239\149\239\155\239\159\239\173\239\179\239\195\239\197\239\219\239\225\239\233\239\SOH\240\ETB\240\GS\240\US\240+\240/\240\&5\240C\240G\240O\240g\240k\240q\240w\240y\240\143\240\163\240\169\240\173\240\187\240\191\240\197\240\203\240\211\240\217\240\227\240\233\240\241\240\247\240\a\241\NAK\241\ESC\241!\241\&7\241=\241U\241u\241{\241\141\241\147\241\165\241\175\241\183\241\213\241\231\241\237\241\253\241\t\242\SI\242\ESC\242\GS\242#\242'\242\&3\242;\242A\242W\242_\242e\242i\242w\242\129\242\147\242\167\242\177\242\179\242\185\242\189\242\191\242\219\242\237\242\239\242\249\242\255\242\ENQ\243\v\243\EM\243A\243Y\243[\243_\243g\243s\243w\243\139\243\143\243\175\243\193\243\209\243\215\243\251\243\ETX\244\t\244\r\244\DC3\244!\244%\244+\244E\244K\244U\244c\244u\244\DEL\244\133\244\139\244\153\244\163\244\169\244\175\244\189\244\195\244\219\244\223\244\237\244\ETX\245\v\245\ETB\245!\245)\245\&5\245G\245Q\245c\245k\245\131\245\141\245\149\245\153\245\177\245\183\245\201\245\207\245\209\245\219\245\249\245\251\245\ENQ\246\a\246\v\246\r\246\&5\246\&7\246S\246[\246a\246g\246y\246\DEL\246\137\246\151\246\155\246\173\246\203\246\221\246\223\246\235\246\t\247\SI\247-\247\&1\247C\247O\247Q\247U\247c\247i\247s\247y\247\129\247\135\247\145\247\157\247\159\247\165\247\177\247\187\247\189\247\207\247\211\247\231\247\235\247\241\247\255\247\ENQ\248\v\248!\248'\248-\248\&5\248G\248Y\248c\248e\248o\248q\248w\248{\248\129\248\141\248\159\248\161\248\171\248\179\248\183\248\201\248\203\248\209\248\215\248\221\248\231\248\239\248\249\248\255\248\DC1\249\GS\249%\249\&1\249\&7\249;\249A\249O\249_\249a\249m\249q\249w\249\157\249\163\249\169\249\185\249\205\249\233\249\253\249\a\250\r\250\DC3\250!\250%\250?\250C\250Q\250[\250m\250{\250\151\250\153\250\157\250\171\250\187\250\189\250\217\250\223\250\231\250\237\250\SI\251\ETB\251\ESC\251-\251/\251?\251G\251M\251u\251}\251\143\251\147\251\177\251\183\251\195\251\197\251\227\251\233\251\243\251\SOH\252)\252\&7\252A\252C\252O\252Y\252a\252e\252m\252s\252y\252\149\252\151\252\155\252\167\252\181\252\197\252\205\252\235\252\251\252\r\253\SI\253\EM\253+\253\&1\253Q\253U\253g\253m\253o\253{\253\133\253\151\253\153\253\159\253\169\253\183\253\201\253\229\253\235\253\243\253\ETX\254\ENQ\254\t\254\GS\254'\254/\254A\254K\254M\254W\254_\254c\254i\254u\254{\254\143\254\147\254\149\254\155\254\159\254\179\254\189\254\215\254\233\254\243\254\245\254\a\255\r\255\GS\255+\255/\255I\255M\255[\255e\255q\255\DEL\255\133\255\139\255\143\255\157\255\167\255\169\255\199\255\217\255\239\255\241\255"#++-- smallPrimes :: [Word16]+-- smallPrimes =+--   [2,3,5,7,11,13,17,19,23,29,31,37,41,43,47,53,59,61,67,71,73,79,83,89,97,101,103,107,109,113,127,131,137,139,149,151,157,163,167,173,179,181,191,193,197,199,211,223,227,229,233,239,241,251,257,263,269,271,277,281,283,293,307,311,313,317,331,337,347,349,353,359,367,373,379,383,389,397,401,409,419,421,431,433,439,443,449,457,461,463,467,479,487,491,499,503,509,521,523,541,547,557,563,569,571,577,587,593,599,601,607,613,617,619,631,641,643,647,653,659,661,673,677,683,691,701,709,719,727,733,739,743,751,757,761,769,773,787,797,809,811,821,823,827,829,839,853,857,859,863,877,881,883,887,907,911,919,929,937,941,947,953,967,971,977,983,991,997,1009,1013,1019,1021,1031,1033,1039,1049,1051,1061,1063,1069,1087,1091,1093,1097,1103,1109,1117,1123,1129,1151,1153,1163,1171,1181,1187,1193,1201,1213,1217,1223,1229,1231,1237,1249,1259,1277,1279,1283,1289,1291,1297,1301,1303,1307,1319,1321,1327,1361,1367,1373,1381,1399,1409,1423,1427,1429,1433,1439,1447,1451,1453,1459,1471,1481,1483,1487,1489,1493,1499,1511,1523,1531,1543,1549,1553,1559,1567,1571,1579,1583,1597,1601,1607,1609,1613,1619,1621,1627,1637,1657,1663,1667,1669,1693,1697,1699,1709,1721,1723,1733,1741,1747,1753,1759,1777,1783,1787,1789,1801,1811,1823,1831,1847,1861,1867,1871,1873,1877,1879,1889,1901,1907,1913,1931,1933,1949,1951,1973,1979,1987,1993,1997,1999,2003,2011,2017,2027,2029,2039,2053,2063,2069,2081,2083,2087,2089,2099,2111,2113,2129,2131,2137,2141,2143,2153,2161,2179,2203,2207,2213,2221,2237,2239,2243,2251,2267,2269,2273,2281,2287,2293,2297,2309,2311,2333,2339,2341,2347,2351,2357,2371,2377,2381,2383,2389,2393,2399,2411,2417,2423,2437,2441,2447,2459,2467,2473,2477,2503,2521,2531,2539,2543,2549,2551,2557,2579,2591,2593,2609,2617,2621,2633,2647,2657,2659,2663,2671,2677,2683,2687,2689,2693,2699,2707,2711,2713,2719,2729,2731,2741,2749,2753,2767,2777,2789,2791,2797,2801,2803,2819,2833,2837,2843,2851,2857,2861,2879,2887,2897,2903,2909,2917,2927,2939,2953,2957,2963,2969,2971,2999,3001,3011,3019,3023,3037,3041,3049,3061,3067,3079,3083,3089,3109,3119,3121,3137,3163,3167,3169,3181,3187,3191,3203,3209,3217,3221,3229,3251,3253,3257,3259,3271,3299,3301,3307,3313,3319,3323,3329,3331,3343,3347,3359,3361,3371,3373,3389,3391,3407,3413,3433,3449,3457,3461,3463,3467,3469,3491,3499,3511,3517,3527,3529,3533,3539,3541,3547,3557,3559,3571,3581,3583,3593,3607,3613,3617,3623,3631,3637,3643,3659,3671,3673,3677,3691,3697,3701,3709,3719,3727,3733,3739,3761,3767,3769,3779,3793,3797,3803,3821,3823,3833,3847,3851,3853,3863,3877,3881,3889,3907,3911,3917,3919,3923,3929,3931,3943,3947,3967,3989,4001,4003,4007,4013,4019,4021,4027,4049,4051,4057,4073,4079,4091,4093,4099,4111,4127,4129,4133,4139,4153,4157,4159,4177,4201,4211,4217,4219,4229,4231,4241,4243,4253,4259,4261,4271,4273,4283,4289,4297,4327,4337,4339,4349,4357,4363,4373,4391,4397,4409,4421,4423,4441,4447,4451,4457,4463,4481,4483,4493,4507,4513,4517,4519,4523,4547,4549,4561,4567,4583,4591,4597,4603,4621,4637,4639,4643,4649,4651,4657,4663,4673,4679,4691,4703,4721,4723,4729,4733,4751,4759,4783,4787,4789,4793,4799,4801,4813,4817,4831,4861,4871,4877,4889,4903,4909,4919,4931,4933,4937,4943,4951,4957,4967,4969,4973,4987,4993,4999,5003,5009,5011,5021,5023,5039,5051,5059,5077,5081,5087,5099,5101,5107,5113,5119,5147,5153,5167,5171,5179,5189,5197,5209,5227,5231,5233,5237,5261,5273,5279,5281,5297,5303,5309,5323,5333,5347,5351,5381,5387,5393,5399,5407,5413,5417,5419,5431,5437,5441,5443,5449,5471,5477,5479,5483,5501,5503,5507,5519,5521,5527,5531,5557,5563,5569,5573,5581,5591,5623,5639,5641,5647,5651,5653,5657,5659,5669,5683,5689,5693,5701,5711,5717,5737,5741,5743,5749,5779,5783,5791,5801,5807,5813,5821,5827,5839,5843,5849,5851,5857,5861,5867,5869,5879,5881,5897,5903,5923,5927,5939,5953,5981,5987,6007,6011,6029,6037,6043,6047,6053,6067,6073,6079,6089,6091,6101,6113,6121,6131,6133,6143,6151,6163,6173,6197,6199,6203,6211,6217,6221,6229,6247,6257,6263,6269,6271,6277,6287,6299,6301,6311,6317,6323,6329,6337,6343,6353,6359,6361,6367,6373,6379,6389,6397,6421,6427,6449,6451,6469,6473,6481,6491,6521,6529,6547,6551,6553,6563,6569,6571,6577,6581,6599,6607,6619,6637,6653,6659,6661,6673,6679,6689,6691,6701,6703,6709,6719,6733,6737,6761,6763,6779,6781,6791,6793,6803,6823,6827,6829,6833,6841,6857,6863,6869,6871,6883,6899,6907,6911,6917,6947,6949,6959,6961,6967,6971,6977,6983,6991,6997,7001,7013,7019,7027,7039,7043,7057,7069,7079,7103,7109,7121,7127,7129,7151,7159,7177,7187,7193,7207,7211,7213,7219,7229,7237,7243,7247,7253,7283,7297,7307,7309,7321,7331,7333,7349,7351,7369,7393,7411,7417,7433,7451,7457,7459,7477,7481,7487,7489,7499,7507,7517,7523,7529,7537,7541,7547,7549,7559,7561,7573,7577,7583,7589,7591,7603,7607,7621,7639,7643,7649,7669,7673,7681,7687,7691,7699,7703,7717,7723,7727,7741,7753,7757,7759,7789,7793,7817,7823,7829,7841,7853,7867,7873,7877,7879,7883,7901,7907,7919,7927,7933,7937,7949,7951,7963,7993,8009,8011,8017,8039,8053,8059,8069,8081,8087,8089,8093,8101,8111,8117,8123,8147,8161,8167,8171,8179,8191,8209,8219,8221,8231,8233,8237,8243,8263,8269,8273,8287,8291,8293,8297,8311,8317,8329,8353,8363,8369,8377,8387,8389,8419,8423,8429,8431,8443,8447,8461,8467,8501,8513,8521,8527,8537,8539,8543,8563,8573,8581,8597,8599,8609,8623,8627,8629,8641,8647,8663,8669,8677,8681,8689,8693,8699,8707,8713,8719,8731,8737,8741,8747,8753,8761,8779,8783,8803,8807,8819,8821,8831,8837,8839,8849,8861,8863,8867,8887,8893,8923,8929,8933,8941,8951,8963,8969,8971,8999,9001,9007,9011,9013,9029,9041,9043,9049,9059,9067,9091,9103,9109,9127,9133,9137,9151,9157,9161,9173,9181,9187,9199,9203,9209,9221,9227,9239,9241,9257,9277,9281,9283,9293,9311,9319,9323,9337,9341,9343,9349,9371,9377,9391,9397,9403,9413,9419,9421,9431,9433,9437,9439,9461,9463,9467,9473,9479,9491,9497,9511,9521,9533,9539,9547,9551,9587,9601,9613,9619,9623,9629,9631,9643,9649,9661,9677,9679,9689,9697,9719,9721,9733,9739,9743,9749,9767,9769,9781,9787,9791,9803,9811,9817,9829,9833,9839,9851,9857,9859,9871,9883,9887,9901,9907,9923,9929,9931,9941,9949,9967,9973,10007,10009,10037,10039,10061,10067,10069,10079,10091,10093,10099,10103,10111,10133,10139,10141,10151,10159,10163,10169,10177,10181,10193,10211,10223,10243,10247,10253,10259,10267,10271,10273,10289,10301,10303,10313,10321,10331,10333,10337,10343,10357,10369,10391,10399,10427,10429,10433,10453,10457,10459,10463,10477,10487,10499,10501,10513,10529,10531,10559,10567,10589,10597,10601,10607,10613,10627,10631,10639,10651,10657,10663,10667,10687,10691,10709,10711,10723,10729,10733,10739,10753,10771,10781,10789,10799,10831,10837,10847,10853,10859,10861,10867,10883,10889,10891,10903,10909,10937,10939,10949,10957,10973,10979,10987,10993,11003,11027,11047,11057,11059,11069,11071,11083,11087,11093,11113,11117,11119,11131,11149,11159,11161,11171,11173,11177,11197,11213,11239,11243,11251,11257,11261,11273,11279,11287,11299,11311,11317,11321,11329,11351,11353,11369,11383,11393,11399,11411,11423,11437,11443,11447,11467,11471,11483,11489,11491,11497,11503,11519,11527,11549,11551,11579,11587,11593,11597,11617,11621,11633,11657,11677,11681,11689,11699,11701,11717,11719,11731,11743,11777,11779,11783,11789,11801,11807,11813,11821,11827,11831,11833,11839,11863,11867,11887,11897,11903,11909,11923,11927,11933,11939,11941,11953,11959,11969,11971,11981,11987,12007,12011,12037,12041,12043,12049,12071,12073,12097,12101,12107,12109,12113,12119,12143,12149,12157,12161,12163,12197,12203,12211,12227,12239,12241,12251,12253,12263,12269,12277,12281,12289,12301,12323,12329,12343,12347,12373,12377,12379,12391,12401,12409,12413,12421,12433,12437,12451,12457,12473,12479,12487,12491,12497,12503,12511,12517,12527,12539,12541,12547,12553,12569,12577,12583,12589,12601,12611,12613,12619,12637,12641,12647,12653,12659,12671,12689,12697,12703,12713,12721,12739,12743,12757,12763,12781,12791,12799,12809,12821,12823,12829,12841,12853,12889,12893,12899,12907,12911,12917,12919,12923,12941,12953,12959,12967,12973,12979,12983,13001,13003,13007,13009,13033,13037,13043,13049,13063,13093,13099,13103,13109,13121,13127,13147,13151,13159,13163,13171,13177,13183,13187,13217,13219,13229,13241,13249,13259,13267,13291,13297,13309,13313,13327,13331,13337,13339,13367,13381,13397,13399,13411,13417,13421,13441,13451,13457,13463,13469,13477,13487,13499,13513,13523,13537,13553,13567,13577,13591,13597,13613,13619,13627,13633,13649,13669,13679,13681,13687,13691,13693,13697,13709,13711,13721,13723,13729,13751,13757,13759,13763,13781,13789,13799,13807,13829,13831,13841,13859,13873,13877,13879,13883,13901,13903,13907,13913,13921,13931,13933,13963,13967,13997,13999,14009,14011,14029,14033,14051,14057,14071,14081,14083,14087,14107,14143,14149,14153,14159,14173,14177,14197,14207,14221,14243,14249,14251,14281,14293,14303,14321,14323,14327,14341,14347,14369,14387,14389,14401,14407,14411,14419,14423,14431,14437,14447,14449,14461,14479,14489,14503,14519,14533,14537,14543,14549,14551,14557,14561,14563,14591,14593,14621,14627,14629,14633,14639,14653,14657,14669,14683,14699,14713,14717,14723,14731,14737,14741,14747,14753,14759,14767,14771,14779,14783,14797,14813,14821,14827,14831,14843,14851,14867,14869,14879,14887,14891,14897,14923,14929,14939,14947,14951,14957,14969,14983,15013,15017,15031,15053,15061,15073,15077,15083,15091,15101,15107,15121,15131,15137,15139,15149,15161,15173,15187,15193,15199,15217,15227,15233,15241,15259,15263,15269,15271,15277,15287,15289,15299,15307,15313,15319,15329,15331,15349,15359,15361,15373,15377,15383,15391,15401,15413,15427,15439,15443,15451,15461,15467,15473,15493,15497,15511,15527,15541,15551,15559,15569,15581,15583,15601,15607,15619,15629,15641,15643,15647,15649,15661,15667,15671,15679,15683,15727,15731,15733,15737,15739,15749,15761,15767,15773,15787,15791,15797,15803,15809,15817,15823,15859,15877,15881,15887,15889,15901,15907,15913,15919,15923,15937,15959,15971,15973,15991,16001,16007,16033,16057,16061,16063,16067,16069,16073,16087,16091,16097,16103,16111,16127,16139,16141,16183,16187,16189,16193,16217,16223,16229,16231,16249,16253,16267,16273,16301,16319,16333,16339,16349,16361,16363,16369,16381,16411,16417,16421,16427,16433,16447,16451,16453,16477,16481,16487,16493,16519,16529,16547,16553,16561,16567,16573,16603,16607,16619,16631,16633,16649,16651,16657,16661,16673,16691,16693,16699,16703,16729,16741,16747,16759,16763,16787,16811,16823,16829,16831,16843,16871,16879,16883,16889,16901,16903,16921,16927,16931,16937,16943,16963,16979,16981,16987,16993,17011,17021,17027,17029,17033,17041,17047,17053,17077,17093,17099,17107,17117,17123,17137,17159,17167,17183,17189,17191,17203,17207,17209,17231,17239,17257,17291,17293,17299,17317,17321,17327,17333,17341,17351,17359,17377,17383,17387,17389,17393,17401,17417,17419,17431,17443,17449,17467,17471,17477,17483,17489,17491,17497,17509,17519,17539,17551,17569,17573,17579,17581,17597,17599,17609,17623,17627,17657,17659,17669,17681,17683,17707,17713,17729,17737,17747,17749,17761,17783,17789,17791,17807,17827,17837,17839,17851,17863,17881,17891,17903,17909,17911,17921,17923,17929,17939,17957,17959,17971,17977,17981,17987,17989,18013,18041,18043,18047,18049,18059,18061,18077,18089,18097,18119,18121,18127,18131,18133,18143,18149,18169,18181,18191,18199,18211,18217,18223,18229,18233,18251,18253,18257,18269,18287,18289,18301,18307,18311,18313,18329,18341,18353,18367,18371,18379,18397,18401,18413,18427,18433,18439,18443,18451,18457,18461,18481,18493,18503,18517,18521,18523,18539,18541,18553,18583,18587,18593,18617,18637,18661,18671,18679,18691,18701,18713,18719,18731,18743,18749,18757,18773,18787,18793,18797,18803,18839,18859,18869,18899,18911,18913,18917,18919,18947,18959,18973,18979,19001,19009,19013,19031,19037,19051,19069,19073,19079,19081,19087,19121,19139,19141,19157,19163,19181,19183,19207,19211,19213,19219,19231,19237,19249,19259,19267,19273,19289,19301,19309,19319,19333,19373,19379,19381,19387,19391,19403,19417,19421,19423,19427,19429,19433,19441,19447,19457,19463,19469,19471,19477,19483,19489,19501,19507,19531,19541,19543,19553,19559,19571,19577,19583,19597,19603,19609,19661,19681,19687,19697,19699,19709,19717,19727,19739,19751,19753,19759,19763,19777,19793,19801,19813,19819,19841,19843,19853,19861,19867,19889,19891,19913,19919,19927,19937,19949,19961,19963,19973,19979,19991,19993,19997,20011,20021,20023,20029,20047,20051,20063,20071,20089,20101,20107,20113,20117,20123,20129,20143,20147,20149,20161,20173,20177,20183,20201,20219,20231,20233,20249,20261,20269,20287,20297,20323,20327,20333,20341,20347,20353,20357,20359,20369,20389,20393,20399,20407,20411,20431,20441,20443,20477,20479,20483,20507,20509,20521,20533,20543,20549,20551,20563,20593,20599,20611,20627,20639,20641,20663,20681,20693,20707,20717,20719,20731,20743,20747,20749,20753,20759,20771,20773,20789,20807,20809,20849,20857,20873,20879,20887,20897,20899,20903,20921,20929,20939,20947,20959,20963,20981,20983,21001,21011,21013,21017,21019,21023,21031,21059,21061,21067,21089,21101,21107,21121,21139,21143,21149,21157,21163,21169,21179,21187,21191,21193,21211,21221,21227,21247,21269,21277,21283,21313,21317,21319,21323,21341,21347,21377,21379,21383,21391,21397,21401,21407,21419,21433,21467,21481,21487,21491,21493,21499,21503,21517,21521,21523,21529,21557,21559,21563,21569,21577,21587,21589,21599,21601,21611,21613,21617,21647,21649,21661,21673,21683,21701,21713,21727,21737,21739,21751,21757,21767,21773,21787,21799,21803,21817,21821,21839,21841,21851,21859,21863,21871,21881,21893,21911,21929,21937,21943,21961,21977,21991,21997,22003,22013,22027,22031,22037,22039,22051,22063,22067,22073,22079,22091,22093,22109,22111,22123,22129,22133,22147,22153,22157,22159,22171,22189,22193,22229,22247,22259,22271,22273,22277,22279,22283,22291,22303,22307,22343,22349,22367,22369,22381,22391,22397,22409,22433,22441,22447,22453,22469,22481,22483,22501,22511,22531,22541,22543,22549,22567,22571,22573,22613,22619,22621,22637,22639,22643,22651,22669,22679,22691,22697,22699,22709,22717,22721,22727,22739,22741,22751,22769,22777,22783,22787,22807,22811,22817,22853,22859,22861,22871,22877,22901,22907,22921,22937,22943,22961,22963,22973,22993,23003,23011,23017,23021,23027,23029,23039,23041,23053,23057,23059,23063,23071,23081,23087,23099,23117,23131,23143,23159,23167,23173,23189,23197,23201,23203,23209,23227,23251,23269,23279,23291,23293,23297,23311,23321,23327,23333,23339,23357,23369,23371,23399,23417,23431,23447,23459,23473,23497,23509,23531,23537,23539,23549,23557,23561,23563,23567,23581,23593,23599,23603,23609,23623,23627,23629,23633,23663,23669,23671,23677,23687,23689,23719,23741,23743,23747,23753,23761,23767,23773,23789,23801,23813,23819,23827,23831,23833,23857,23869,23873,23879,23887,23893,23899,23909,23911,23917,23929,23957,23971,23977,23981,23993,24001,24007,24019,24023,24029,24043,24049,24061,24071,24077,24083,24091,24097,24103,24107,24109,24113,24121,24133,24137,24151,24169,24179,24181,24197,24203,24223,24229,24239,24247,24251,24281,24317,24329,24337,24359,24371,24373,24379,24391,24407,24413,24419,24421,24439,24443,24469,24473,24481,24499,24509,24517,24527,24533,24547,24551,24571,24593,24611,24623,24631,24659,24671,24677,24683,24691,24697,24709,24733,24749,24763,24767,24781,24793,24799,24809,24821,24841,24847,24851,24859,24877,24889,24907,24917,24919,24923,24943,24953,24967,24971,24977,24979,24989,25013,25031,25033,25037,25057,25073,25087,25097,25111,25117,25121,25127,25147,25153,25163,25169,25171,25183,25189,25219,25229,25237,25243,25247,25253,25261,25301,25303,25307,25309,25321,25339,25343,25349,25357,25367,25373,25391,25409,25411,25423,25439,25447,25453,25457,25463,25469,25471,25523,25537,25541,25561,25577,25579,25583,25589,25601,25603,25609,25621,25633,25639,25643,25657,25667,25673,25679,25693,25703,25717,25733,25741,25747,25759,25763,25771,25793,25799,25801,25819,25841,25847,25849,25867,25873,25889,25903,25913,25919,25931,25933,25939,25943,25951,25969,25981,25997,25999,26003,26017,26021,26029,26041,26053,26083,26099,26107,26111,26113,26119,26141,26153,26161,26171,26177,26183,26189,26203,26209,26227,26237,26249,26251,26261,26263,26267,26293,26297,26309,26317,26321,26339,26347,26357,26371,26387,26393,26399,26407,26417,26423,26431,26437,26449,26459,26479,26489,26497,26501,26513,26539,26557,26561,26573,26591,26597,26627,26633,26641,26647,26669,26681,26683,26687,26693,26699,26701,26711,26713,26717,26723,26729,26731,26737,26759,26777,26783,26801,26813,26821,26833,26839,26849,26861,26863,26879,26881,26891,26893,26903,26921,26927,26947,26951,26953,26959,26981,26987,26993,27011,27017,27031,27043,27059,27061,27067,27073,27077,27091,27103,27107,27109,27127,27143,27179,27191,27197,27211,27239,27241,27253,27259,27271,27277,27281,27283,27299,27329,27337,27361,27367,27397,27407,27409,27427,27431,27437,27449,27457,27479,27481,27487,27509,27527,27529,27539,27541,27551,27581,27583,27611,27617,27631,27647,27653,27673,27689,27691,27697,27701,27733,27737,27739,27743,27749,27751,27763,27767,27773,27779,27791,27793,27799,27803,27809,27817,27823,27827,27847,27851,27883,27893,27901,27917,27919,27941,27943,27947,27953,27961,27967,27983,27997,28001,28019,28027,28031,28051,28057,28069,28081,28087,28097,28099,28109,28111,28123,28151,28163,28181,28183,28201,28211,28219,28229,28277,28279,28283,28289,28297,28307,28309,28319,28349,28351,28387,28393,28403,28409,28411,28429,28433,28439,28447,28463,28477,28493,28499,28513,28517,28537,28541,28547,28549,28559,28571,28573,28579,28591,28597,28603,28607,28619,28621,28627,28631,28643,28649,28657,28661,28663,28669,28687,28697,28703,28711,28723,28729,28751,28753,28759,28771,28789,28793,28807,28813,28817,28837,28843,28859,28867,28871,28879,28901,28909,28921,28927,28933,28949,28961,28979,29009,29017,29021,29023,29027,29033,29059,29063,29077,29101,29123,29129,29131,29137,29147,29153,29167,29173,29179,29191,29201,29207,29209,29221,29231,29243,29251,29269,29287,29297,29303,29311,29327,29333,29339,29347,29363,29383,29387,29389,29399,29401,29411,29423,29429,29437,29443,29453,29473,29483,29501,29527,29531,29537,29567,29569,29573,29581,29587,29599,29611,29629,29633,29641,29663,29669,29671,29683,29717,29723,29741,29753,29759,29761,29789,29803,29819,29833,29837,29851,29863,29867,29873,29879,29881,29917,29921,29927,29947,29959,29983,29989,30011,30013,30029,30047,30059,30071,30089,30091,30097,30103,30109,30113,30119,30133,30137,30139,30161,30169,30181,30187,30197,30203,30211,30223,30241,30253,30259,30269,30271,30293,30307,30313,30319,30323,30341,30347,30367,30389,30391,30403,30427,30431,30449,30467,30469,30491,30493,30497,30509,30517,30529,30539,30553,30557,30559,30577,30593,30631,30637,30643,30649,30661,30671,30677,30689,30697,30703,30707,30713,30727,30757,30763,30773,30781,30803,30809,30817,30829,30839,30841,30851,30853,30859,30869,30871,30881,30893,30911,30931,30937,30941,30949,30971,30977,30983,31013,31019,31033,31039,31051,31063,31069,31079,31081,31091,31121,31123,31139,31147,31151,31153,31159,31177,31181,31183,31189,31193,31219,31223,31231,31237,31247,31249,31253,31259,31267,31271,31277,31307,31319,31321,31327,31333,31337,31357,31379,31387,31391,31393,31397,31469,31477,31481,31489,31511,31513,31517,31531,31541,31543,31547,31567,31573,31583,31601,31607,31627,31643,31649,31657,31663,31667,31687,31699,31721,31723,31727,31729,31741,31751,31769,31771,31793,31799,31817,31847,31849,31859,31873,31883,31891,31907,31957,31963,31973,31981,31991,32003,32009,32027,32029,32051,32057,32059,32063,32069,32077,32083,32089,32099,32117,32119,32141,32143,32159,32173,32183,32189,32191,32203,32213,32233,32237,32251,32257,32261,32297,32299,32303,32309,32321,32323,32327,32341,32353,32359,32363,32369,32371,32377,32381,32401,32411,32413,32423,32429,32441,32443,32467,32479,32491,32497,32503,32507,32531,32533,32537,32561,32563,32569,32573,32579,32587,32603,32609,32611,32621,32633,32647,32653,32687,32693,32707,32713,32717,32719,32749,32771,32779,32783,32789,32797,32801,32803,32831,32833,32839,32843,32869,32887,32909,32911,32917,32933,32939,32941,32957,32969,32971,32983,32987,32993,32999,33013,33023,33029,33037,33049,33053,33071,33073,33083,33091,33107,33113,33119,33149,33151,33161,33179,33181,33191,33199,33203,33211,33223,33247,33287,33289,33301,33311,33317,33329,33331,33343,33347,33349,33353,33359,33377,33391,33403,33409,33413,33427,33457,33461,33469,33479,33487,33493,33503,33521,33529,33533,33547,33563,33569,33577,33581,33587,33589,33599,33601,33613,33617,33619,33623,33629,33637,33641,33647,33679,33703,33713,33721,33739,33749,33751,33757,33767,33769,33773,33791,33797,33809,33811,33827,33829,33851,33857,33863,33871,33889,33893,33911,33923,33931,33937,33941,33961,33967,33997,34019,34031,34033,34039,34057,34061,34123,34127,34129,34141,34147,34157,34159,34171,34183,34211,34213,34217,34231,34253,34259,34261,34267,34273,34283,34297,34301,34303,34313,34319,34327,34337,34351,34361,34367,34369,34381,34403,34421,34429,34439,34457,34469,34471,34483,34487,34499,34501,34511,34513,34519,34537,34543,34549,34583,34589,34591,34603,34607,34613,34631,34649,34651,34667,34673,34679,34687,34693,34703,34721,34729,34739,34747,34757,34759,34763,34781,34807,34819,34841,34843,34847,34849,34871,34877,34883,34897,34913,34919,34939,34949,34961,34963,34981,35023,35027,35051,35053,35059,35069,35081,35083,35089,35099,35107,35111,35117,35129,35141,35149,35153,35159,35171,35201,35221,35227,35251,35257,35267,35279,35281,35291,35311,35317,35323,35327,35339,35353,35363,35381,35393,35401,35407,35419,35423,35437,35447,35449,35461,35491,35507,35509,35521,35527,35531,35533,35537,35543,35569,35573,35591,35593,35597,35603,35617,35671,35677,35729,35731,35747,35753,35759,35771,35797,35801,35803,35809,35831,35837,35839,35851,35863,35869,35879,35897,35899,35911,35923,35933,35951,35963,35969,35977,35983,35993,35999,36007,36011,36013,36017,36037,36061,36067,36073,36083,36097,36107,36109,36131,36137,36151,36161,36187,36191,36209,36217,36229,36241,36251,36263,36269,36277,36293,36299,36307,36313,36319,36341,36343,36353,36373,36383,36389,36433,36451,36457,36467,36469,36473,36479,36493,36497,36523,36527,36529,36541,36551,36559,36563,36571,36583,36587,36599,36607,36629,36637,36643,36653,36671,36677,36683,36691,36697,36709,36713,36721,36739,36749,36761,36767,36779,36781,36787,36791,36793,36809,36821,36833,36847,36857,36871,36877,36887,36899,36901,36913,36919,36923,36929,36931,36943,36947,36973,36979,36997,37003,37013,37019,37021,37039,37049,37057,37061,37087,37097,37117,37123,37139,37159,37171,37181,37189,37199,37201,37217,37223,37243,37253,37273,37277,37307,37309,37313,37321,37337,37339,37357,37361,37363,37369,37379,37397,37409,37423,37441,37447,37463,37483,37489,37493,37501,37507,37511,37517,37529,37537,37547,37549,37561,37567,37571,37573,37579,37589,37591,37607,37619,37633,37643,37649,37657,37663,37691,37693,37699,37717,37747,37781,37783,37799,37811,37813,37831,37847,37853,37861,37871,37879,37889,37897,37907,37951,37957,37963,37967,37987,37991,37993,37997,38011,38039,38047,38053,38069,38083,38113,38119,38149,38153,38167,38177,38183,38189,38197,38201,38219,38231,38237,38239,38261,38273,38281,38287,38299,38303,38317,38321,38327,38329,38333,38351,38371,38377,38393,38431,38447,38449,38453,38459,38461,38501,38543,38557,38561,38567,38569,38593,38603,38609,38611,38629,38639,38651,38653,38669,38671,38677,38693,38699,38707,38711,38713,38723,38729,38737,38747,38749,38767,38783,38791,38803,38821,38833,38839,38851,38861,38867,38873,38891,38903,38917,38921,38923,38933,38953,38959,38971,38977,38993,39019,39023,39041,39043,39047,39079,39089,39097,39103,39107,39113,39119,39133,39139,39157,39161,39163,39181,39191,39199,39209,39217,39227,39229,39233,39239,39241,39251,39293,39301,39313,39317,39323,39341,39343,39359,39367,39371,39373,39383,39397,39409,39419,39439,39443,39451,39461,39499,39503,39509,39511,39521,39541,39551,39563,39569,39581,39607,39619,39623,39631,39659,39667,39671,39679,39703,39709,39719,39727,39733,39749,39761,39769,39779,39791,39799,39821,39827,39829,39839,39841,39847,39857,39863,39869,39877,39883,39887,39901,39929,39937,39953,39971,39979,39983,39989,40009,40013,40031,40037,40039,40063,40087,40093,40099,40111,40123,40127,40129,40151,40153,40163,40169,40177,40189,40193,40213,40231,40237,40241,40253,40277,40283,40289,40343,40351,40357,40361,40387,40423,40427,40429,40433,40459,40471,40483,40487,40493,40499,40507,40519,40529,40531,40543,40559,40577,40583,40591,40597,40609,40627,40637,40639,40693,40697,40699,40709,40739,40751,40759,40763,40771,40787,40801,40813,40819,40823,40829,40841,40847,40849,40853,40867,40879,40883,40897,40903,40927,40933,40939,40949,40961,40973,40993,41011,41017,41023,41039,41047,41051,41057,41077,41081,41113,41117,41131,41141,41143,41149,41161,41177,41179,41183,41189,41201,41203,41213,41221,41227,41231,41233,41243,41257,41263,41269,41281,41299,41333,41341,41351,41357,41381,41387,41389,41399,41411,41413,41443,41453,41467,41479,41491,41507,41513,41519,41521,41539,41543,41549,41579,41593,41597,41603,41609,41611,41617,41621,41627,41641,41647,41651,41659,41669,41681,41687,41719,41729,41737,41759,41761,41771,41777,41801,41809,41813,41843,41849,41851,41863,41879,41887,41893,41897,41903,41911,41927,41941,41947,41953,41957,41959,41969,41981,41983,41999,42013,42017,42019,42023,42043,42061,42071,42073,42083,42089,42101,42131,42139,42157,42169,42179,42181,42187,42193,42197,42209,42221,42223,42227,42239,42257,42281,42283,42293,42299,42307,42323,42331,42337,42349,42359,42373,42379,42391,42397,42403,42407,42409,42433,42437,42443,42451,42457,42461,42463,42467,42473,42487,42491,42499,42509,42533,42557,42569,42571,42577,42589,42611,42641,42643,42649,42667,42677,42683,42689,42697,42701,42703,42709,42719,42727,42737,42743,42751,42767,42773,42787,42793,42797,42821,42829,42839,42841,42853,42859,42863,42899,42901,42923,42929,42937,42943,42953,42961,42967,42979,42989,43003,43013,43019,43037,43049,43051,43063,43067,43093,43103,43117,43133,43151,43159,43177,43189,43201,43207,43223,43237,43261,43271,43283,43291,43313,43319,43321,43331,43391,43397,43399,43403,43411,43427,43441,43451,43457,43481,43487,43499,43517,43541,43543,43573,43577,43579,43591,43597,43607,43609,43613,43627,43633,43649,43651,43661,43669,43691,43711,43717,43721,43753,43759,43777,43781,43783,43787,43789,43793,43801,43853,43867,43889,43891,43913,43933,43943,43951,43961,43963,43969,43973,43987,43991,43997,44017,44021,44027,44029,44041,44053,44059,44071,44087,44089,44101,44111,44119,44123,44129,44131,44159,44171,44179,44189,44201,44203,44207,44221,44249,44257,44263,44267,44269,44273,44279,44281,44293,44351,44357,44371,44381,44383,44389,44417,44449,44453,44483,44491,44497,44501,44507,44519,44531,44533,44537,44543,44549,44563,44579,44587,44617,44621,44623,44633,44641,44647,44651,44657,44683,44687,44699,44701,44711,44729,44741,44753,44771,44773,44777,44789,44797,44809,44819,44839,44843,44851,44867,44879,44887,44893,44909,44917,44927,44939,44953,44959,44963,44971,44983,44987,45007,45013,45053,45061,45077,45083,45119,45121,45127,45131,45137,45139,45161,45179,45181,45191,45197,45233,45247,45259,45263,45281,45289,45293,45307,45317,45319,45329,45337,45341,45343,45361,45377,45389,45403,45413,45427,45433,45439,45481,45491,45497,45503,45523,45533,45541,45553,45557,45569,45587,45589,45599,45613,45631,45641,45659,45667,45673,45677,45691,45697,45707,45737,45751,45757,45763,45767,45779,45817,45821,45823,45827,45833,45841,45853,45863,45869,45887,45893,45943,45949,45953,45959,45971,45979,45989,46021,46027,46049,46051,46061,46073,46091,46093,46099,46103,46133,46141,46147,46153,46171,46181,46183,46187,46199,46219,46229,46237,46261,46271,46273,46279,46301,46307,46309,46327,46337,46349,46351,46381,46399,46411,46439,46441,46447,46451,46457,46471,46477,46489,46499,46507,46511,46523,46549,46559,46567,46573,46589,46591,46601,46619,46633,46639,46643,46649,46663,46679,46681,46687,46691,46703,46723,46727,46747,46751,46757,46769,46771,46807,46811,46817,46819,46829,46831,46853,46861,46867,46877,46889,46901,46919,46933,46957,46993,46997,47017,47041,47051,47057,47059,47087,47093,47111,47119,47123,47129,47137,47143,47147,47149,47161,47189,47207,47221,47237,47251,47269,47279,47287,47293,47297,47303,47309,47317,47339,47351,47353,47363,47381,47387,47389,47407,47417,47419,47431,47441,47459,47491,47497,47501,47507,47513,47521,47527,47533,47543,47563,47569,47581,47591,47599,47609,47623,47629,47639,47653,47657,47659,47681,47699,47701,47711,47713,47717,47737,47741,47743,47777,47779,47791,47797,47807,47809,47819,47837,47843,47857,47869,47881,47903,47911,47917,47933,47939,47947,47951,47963,47969,47977,47981,48017,48023,48029,48049,48073,48079,48091,48109,48119,48121,48131,48157,48163,48179,48187,48193,48197,48221,48239,48247,48259,48271,48281,48299,48311,48313,48337,48341,48353,48371,48383,48397,48407,48409,48413,48437,48449,48463,48473,48479,48481,48487,48491,48497,48523,48527,48533,48539,48541,48563,48571,48589,48593,48611,48619,48623,48647,48649,48661,48673,48677,48679,48731,48733,48751,48757,48761,48767,48779,48781,48787,48799,48809,48817,48821,48823,48847,48857,48859,48869,48871,48883,48889,48907,48947,48953,48973,48989,48991,49003,49009,49019,49031,49033,49037,49043,49057,49069,49081,49103,49109,49117,49121,49123,49139,49157,49169,49171,49177,49193,49199,49201,49207,49211,49223,49253,49261,49277,49279,49297,49307,49331,49333,49339,49363,49367,49369,49391,49393,49409,49411,49417,49429,49433,49451,49459,49463,49477,49481,49499,49523,49529,49531,49537,49547,49549,49559,49597,49603,49613,49627,49633,49639,49663,49667,49669,49681,49697,49711,49727,49739,49741,49747,49757,49783,49787,49789,49801,49807,49811,49823,49831,49843,49853,49871,49877,49891,49919,49921,49927,49937,49939,49943,49957,49991,49993,49999,50021,50023,50033,50047,50051,50053,50069,50077,50087,50093,50101,50111,50119,50123,50129,50131,50147,50153,50159,50177,50207,50221,50227,50231,50261,50263,50273,50287,50291,50311,50321,50329,50333,50341,50359,50363,50377,50383,50387,50411,50417,50423,50441,50459,50461,50497,50503,50513,50527,50539,50543,50549,50551,50581,50587,50591,50593,50599,50627,50647,50651,50671,50683,50707,50723,50741,50753,50767,50773,50777,50789,50821,50833,50839,50849,50857,50867,50873,50891,50893,50909,50923,50929,50951,50957,50969,50971,50989,50993,51001,51031,51043,51047,51059,51061,51071,51109,51131,51133,51137,51151,51157,51169,51193,51197,51199,51203,51217,51229,51239,51241,51257,51263,51283,51287,51307,51329,51341,51343,51347,51349,51361,51383,51407,51413,51419,51421,51427,51431,51437,51439,51449,51461,51473,51479,51481,51487,51503,51511,51517,51521,51539,51551,51563,51577,51581,51593,51599,51607,51613,51631,51637,51647,51659,51673,51679,51683,51691,51713,51719,51721,51749,51767,51769,51787,51797,51803,51817,51827,51829,51839,51853,51859,51869,51871,51893,51899,51907,51913,51929,51941,51949,51971,51973,51977,51991,52009,52021,52027,52051,52057,52067,52069,52081,52103,52121,52127,52147,52153,52163,52177,52181,52183,52189,52201,52223,52237,52249,52253,52259,52267,52289,52291,52301,52313,52321,52361,52363,52369,52379,52387,52391,52433,52453,52457,52489,52501,52511,52517,52529,52541,52543,52553,52561,52567,52571,52579,52583,52609,52627,52631,52639,52667,52673,52691,52697,52709,52711,52721,52727,52733,52747,52757,52769,52783,52807,52813,52817,52837,52859,52861,52879,52883,52889,52901,52903,52919,52937,52951,52957,52963,52967,52973,52981,52999,53003,53017,53047,53051,53069,53077,53087,53089,53093,53101,53113,53117,53129,53147,53149,53161,53171,53173,53189,53197,53201,53231,53233,53239,53267,53269,53279,53281,53299,53309,53323,53327,53353,53359,53377,53381,53401,53407,53411,53419,53437,53441,53453,53479,53503,53507,53527,53549,53551,53569,53591,53593,53597,53609,53611,53617,53623,53629,53633,53639,53653,53657,53681,53693,53699,53717,53719,53731,53759,53773,53777,53783,53791,53813,53819,53831,53849,53857,53861,53881,53887,53891,53897,53899,53917,53923,53927,53939,53951,53959,53987,53993,54001,54011,54013,54037,54049,54059,54083,54091,54101,54121,54133,54139,54151,54163,54167,54181,54193,54217,54251,54269,54277,54287,54293,54311,54319,54323,54331,54347,54361,54367,54371,54377,54401,54403,54409,54413,54419,54421,54437,54443,54449,54469,54493,54497,54499,54503,54517,54521,54539,54541,54547,54559,54563,54577,54581,54583,54601,54617,54623,54629,54631,54647,54667,54673,54679,54709,54713,54721,54727,54751,54767,54773,54779,54787,54799,54829,54833,54851,54869,54877,54881,54907,54917,54919,54941,54949,54959,54973,54979,54983,55001,55009,55021,55049,55051,55057,55061,55073,55079,55103,55109,55117,55127,55147,55163,55171,55201,55207,55213,55217,55219,55229,55243,55249,55259,55291,55313,55331,55333,55337,55339,55343,55351,55373,55381,55399,55411,55439,55441,55457,55469,55487,55501,55511,55529,55541,55547,55579,55589,55603,55609,55619,55621,55631,55633,55639,55661,55663,55667,55673,55681,55691,55697,55711,55717,55721,55733,55763,55787,55793,55799,55807,55813,55817,55819,55823,55829,55837,55843,55849,55871,55889,55897,55901,55903,55921,55927,55931,55933,55949,55967,55987,55997,56003,56009,56039,56041,56053,56081,56087,56093,56099,56101,56113,56123,56131,56149,56167,56171,56179,56197,56207,56209,56237,56239,56249,56263,56267,56269,56299,56311,56333,56359,56369,56377,56383,56393,56401,56417,56431,56437,56443,56453,56467,56473,56477,56479,56489,56501,56503,56509,56519,56527,56531,56533,56543,56569,56591,56597,56599,56611,56629,56633,56659,56663,56671,56681,56687,56701,56711,56713,56731,56737,56747,56767,56773,56779,56783,56807,56809,56813,56821,56827,56843,56857,56873,56891,56893,56897,56909,56911,56921,56923,56929,56941,56951,56957,56963,56983,56989,56993,56999,57037,57041,57047,57059,57073,57077,57089,57097,57107,57119,57131,57139,57143,57149,57163,57173,57179,57191,57193,57203,57221,57223,57241,57251,57259,57269,57271,57283,57287,57301,57329,57331,57347,57349,57367,57373,57383,57389,57397,57413,57427,57457,57467,57487,57493,57503,57527,57529,57557,57559,57571,57587,57593,57601,57637,57641,57649,57653,57667,57679,57689,57697,57709,57713,57719,57727,57731,57737,57751,57773,57781,57787,57791,57793,57803,57809,57829,57839,57847,57853,57859,57881,57899,57901,57917,57923,57943,57947,57973,57977,57991,58013,58027,58031,58043,58049,58057,58061,58067,58073,58099,58109,58111,58129,58147,58151,58153,58169,58171,58189,58193,58199,58207,58211,58217,58229,58231,58237,58243,58271,58309,58313,58321,58337,58363,58367,58369,58379,58391,58393,58403,58411,58417,58427,58439,58441,58451,58453,58477,58481,58511,58537,58543,58549,58567,58573,58579,58601,58603,58613,58631,58657,58661,58679,58687,58693,58699,58711,58727,58733,58741,58757,58763,58771,58787,58789,58831,58889,58897,58901,58907,58909,58913,58921,58937,58943,58963,58967,58979,58991,58997,59009,59011,59021,59023,59029,59051,59053,59063,59069,59077,59083,59093,59107,59113,59119,59123,59141,59149,59159,59167,59183,59197,59207,59209,59219,59221,59233,59239,59243,59263,59273,59281,59333,59341,59351,59357,59359,59369,59377,59387,59393,59399,59407,59417,59419,59441,59443,59447,59453,59467,59471,59473,59497,59509,59513,59539,59557,59561,59567,59581,59611,59617,59621,59627,59629,59651,59659,59663,59669,59671,59693,59699,59707,59723,59729,59743,59747,59753,59771,59779,59791,59797,59809,59833,59863,59879,59887,59921,59929,59951,59957,59971,59981,59999,60013,60017,60029,60037,60041,60077,60083,60089,60091,60101,60103,60107,60127,60133,60139,60149,60161,60167,60169,60209,60217,60223,60251,60257,60259,60271,60289,60293,60317,60331,60337,60343,60353,60373,60383,60397,60413,60427,60443,60449,60457,60493,60497,60509,60521,60527,60539,60589,60601,60607,60611,60617,60623,60631,60637,60647,60649,60659,60661,60679,60689,60703,60719,60727,60733,60737,60757,60761,60763,60773,60779,60793,60811,60821,60859,60869,60887,60889,60899,60901,60913,60917,60919,60923,60937,60943,60953,60961,61001,61007,61027,61031,61043,61051,61057,61091,61099,61121,61129,61141,61151,61153,61169,61211,61223,61231,61253,61261,61283,61291,61297,61331,61333,61339,61343,61357,61363,61379,61381,61403,61409,61417,61441,61463,61469,61471,61483,61487,61493,61507,61511,61519,61543,61547,61553,61559,61561,61583,61603,61609,61613,61627,61631,61637,61643,61651,61657,61667,61673,61681,61687,61703,61717,61723,61729,61751,61757,61781,61813,61819,61837,61843,61861,61871,61879,61909,61927,61933,61949,61961,61967,61979,61981,61987,61991,62003,62011,62017,62039,62047,62053,62057,62071,62081,62099,62119,62129,62131,62137,62141,62143,62171,62189,62191,62201,62207,62213,62219,62233,62273,62297,62299,62303,62311,62323,62327,62347,62351,62383,62401,62417,62423,62459,62467,62473,62477,62483,62497,62501,62507,62533,62539,62549,62563,62581,62591,62597,62603,62617,62627,62633,62639,62653,62659,62683,62687,62701,62723,62731,62743,62753,62761,62773,62791,62801,62819,62827,62851,62861,62869,62873,62897,62903,62921,62927,62929,62939,62969,62971,62981,62983,62987,62989,63029,63031,63059,63067,63073,63079,63097,63103,63113,63127,63131,63149,63179,63197,63199,63211,63241,63247,63277,63281,63299,63311,63313,63317,63331,63337,63347,63353,63361,63367,63377,63389,63391,63397,63409,63419,63421,63439,63443,63463,63467,63473,63487,63493,63499,63521,63527,63533,63541,63559,63577,63587,63589,63599,63601,63607,63611,63617,63629,63647,63649,63659,63667,63671,63689,63691,63697,63703,63709,63719,63727,63737,63743,63761,63773,63781,63793,63799,63803,63809,63823,63839,63841,63853,63857,63863,63901,63907,63913,63929,63949,63977,63997,64007,64013,64019,64033,64037,64063,64067,64081,64091,64109,64123,64151,64153,64157,64171,64187,64189,64217,64223,64231,64237,64271,64279,64283,64301,64303,64319,64327,64333,64373,64381,64399,64403,64433,64439,64451,64453,64483,64489,64499,64513,64553,64567,64577,64579,64591,64601,64609,64613,64621,64627,64633,64661,64663,64667,64679,64693,64709,64717,64747,64763,64781,64783,64793,64811,64817,64849,64853,64871,64877,64879,64891,64901,64919,64921,64927,64937,64951,64969,64997,65003,65011,65027,65029,65033,65053,65063,65071,65089,65099,65101,65111,65119,65123,65129,65141,65147,65167,65171,65173,65179,65183,65203,65213,65239,65257,65267,65269,65287,65293,65309,65323,65327,65353,65357,65371,65381,65393,65407,65413,65419,65423,65437,65447,65449,65479,65497,65519,65521]
Math/NumberTheory/Primes/Testing.hs view
@@ -3,10 +3,9 @@ -- Copyright:   (c) 2011 Daniel Fischer -- Licence:     MIT -- Maintainer:  Daniel Fischer <daniel.is.fischer@googlemail.com>--- Stability:   Provisional--- Portability: Non-portable (GHC extensions) -- -- Primality tests.+ module Math.NumberTheory.Primes.Testing     ( -- * Standard tests       isPrime@@ -16,9 +15,6 @@     , millerRabinV     , isStrongFermatPP     , isFermatPP-      -- * Using a sieve-    , FactorSieve-    , fsIsPrime       -- * Trial division     , trialDivisionPrimeTo     ) where@@ -26,13 +22,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---- | 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-
− Math/NumberTheory/Primes/Testing/Certificates.hs 
@@ -1,36 +0,0 @@--- |--- Module:      Math.NumberTheory.Primes.Testing.Certificates--- Copyright:   (c) 2011 Daniel Fischer--- Licence:     MIT--- Maintainer:  Daniel Fischer <daniel.is.fischer@googlemail.com>--- Stability:   Provisional--- Portability: Non-portable (GHC extensions)------ Certificates for primality or compositeness.-module Math.NumberTheory.Primes.Testing.Certificates-    ( -- * Certificates-      Certificate(..)-    , argueCertificate-    , CompositenessProof-    , composite-    , PrimalityProof-    , cprime-      -- * Arguments-    , CompositenessArgument(..)-    , PrimalityArgument(..)-      -- ** Weaken proofs to arguments-    , arguePrimality-    , argueCompositeness-      -- ** Prove valid arguments-    , verifyPrimalityArgument-    , verifyCompositenessArgument-      -- * Determine and prove whether a number is prime or composite-    , certify-      -- ** Checks for the paranoid-    , checkCertificate-    , checkCompositenessProof-    , checkPrimalityProof-    ) where--import Math.NumberTheory.Primes.Testing.Certificates.Internal-
− Math/NumberTheory/Primes/Testing/Certificates/Internal.hs 
@@ -1,361 +0,0 @@--- |--- Module:      Math.NumberTheory.Primes.Testing.Certificates.Internal--- Copyright:   (c) 2011 Daniel Fischer--- Licence:     MIT--- Maintainer:  Daniel Fischer <daniel.is.fischer@googlemail.com>--- Stability:   Provisional--- Portability: Non-portable (GHC extensions)------ Certificates for primality or compositeness.-{-# LANGUAGE CPP #-}-{-# OPTIONS_HADDOCK hide #-}-module Math.NumberTheory.Primes.Testing.Certificates.Internal-    ( Certificate(..)-    , CompositenessProof(..)-    , PrimalityProof(..)-    , CompositenessArgument(..)-    , PrimalityArgument(..)-    , checkCertificate-    , checkCompositenessProof-    , checkPrimalityProof-    , certify-    , trivial-    , smallCert-    , certifyBPSW-    , argueCertificate-    , arguePrimality-    , argueCompositeness-    , verifyPrimalityArgument-    , verifyCompositenessArgument-    ) where--import Data.List-#if __GLASGOW_HASKELL__ < 709-import Data.Word-#endif-import Data.Bits-import Data.Maybe-import GHC.Integer.GMP.Internals--import Math.NumberTheory.Moduli.Class-import Math.NumberTheory.Utils-import Math.NumberTheory.Primes.Factorisation.TrialDivision-import Math.NumberTheory.Primes.Factorisation.Montgomery-import Math.NumberTheory.Primes.Testing.Probabilistic-import Math.NumberTheory.Primes.Sieve.Eratosthenes-import Math.NumberTheory.Powers.Squares---- | A certificate of either compositeness or primality of an---   'Integer'. Only numbers @> 1@ can be certified, trying to---   create a certificate for other numbers raises an error.-data Certificate-    = Composite !CompositenessProof-    | Prime !PrimalityProof-      deriving Show---- | A proof of compositeness of a positive number. The type is---   abstract to ensure the validity of proofs.-data CompositenessProof-    = Factors { composite :: !Integer           -- ^ The number whose compositeness is proved.-              , firstFactor-              , secondFactor :: !Integer }-    | StrongFermat { composite :: !Integer      -- ^ The number whose compositeness is proved.-                   , witness :: !Integer }-    | LucasSelfridge { composite :: !Integer    -- ^ The number whose compositeness is proved.-                     }-      deriving Show---- | An argument for compositeness of a number (which must be @> 1@).---   'CompositenessProof's translate directly to 'CompositenessArguments',---   correct arguments can be transformed into proofs. This type allows the---   manipulation of proofs while maintaining their correctness.---   The only way to access components of a 'CompositenessProof' except---   the composite is through this type.-data CompositenessArgument-    = Divisors { compo, firstDivisor, secondDivisor :: Integer }-                                                -- ^ @compo == firstDiv*secondDiv@, where all are @> 1@-    | Fermat { compo, fermatBase :: Integer }   -- ^ @compo@ fails the strong Fermat test for @fermatBase@-    | Lucas { compo :: Integer }                -- ^ @compo@ fails the Lucas-Selfridge test-    | Belief { compo :: Integer }               -- ^ No particular reason given-      deriving (Show, Read, Eq, Ord)---- | A proof of primality of a positive number. The type is---   abstract to ensure the validity of proofs.-data PrimalityProof-    = Pocklington { cprime :: !Integer          -- ^ The number whose primality is proved.-                  , factorisedPart, cofactor :: !Integer-                  , knownFactors :: ![(Integer,Int,Integer,PrimalityProof)]-                  }-    | TrialDivision { cprime :: !Integer        -- ^ The number whose primality is proved.-                    , tdLimit :: !Integer }-    | Trivial { cprime :: !Integer              -- ^ The number whose primality is proved.-              }-      deriving Show---- | An argument for primality of a number (which must be @> 1@).---   'PrimalityProof's translate directly to 'PrimalityArguments',---   correct arguments can be transformed into proofs. This type allows the---   manipulation of proofs while maintaining their correctness.---   The only way to access components of a 'PrimalityProof' except---   the prime is through this type.-data PrimalityArgument-    = Pock { aprime :: Integer-           , largeFactor, smallFactor :: Integer-           , factorList :: [(Integer,Int,Integer,PrimalityArgument)]-           }                                 -- ^ A suggested Pocklington certificate-    | Division { aprime, alimit :: Integer } -- ^ Primality should be provable by trial division to @alimit@-    | Obvious { aprime :: Integer }          -- ^ @aprime@ is said to be obviously prime, that holds for primes @< 30@-    | Assumption { aprime :: Integer }       -- ^ Primality assumed-      deriving (Show, Read, Eq, Ord)--argueCertificate :: Certificate -> Either CompositenessArgument PrimalityArgument-argueCertificate (Composite proof) = Left (argueCompositeness proof)-argueCertificate (Prime proof) = Right (arguePrimality proof)---- | @'arguePrimality'@ transforms a proof of primality into an argument for primality.-arguePrimality :: PrimalityProof -> PrimalityArgument-arguePrimality (TrialDivision p l) = Division p l-arguePrimality (Trivial p) = Obvious p-arguePrimality (Pocklington p a b fcts) = Pock p a b (map argue fcts)-  where-    argue (x,y,z,prf) = (x,y,z,arguePrimality prf)---- | @'verifyPrimalityArgument'@ checks the given argument and constructs a proof from---   it, if it is valid. For the explicit arguments, this is simple and resonably fast,---   for an 'Assumption', the verification uses 'certify' and hence may take a long time.-verifyPrimalityArgument :: PrimalityArgument -> Maybe PrimalityProof-verifyPrimalityArgument (Assumption p)-    = case certify p of-        Composite _ -> Nothing-        Prime proof -> Just proof-verifyPrimalityArgument arg-    | checkPrimalityProof prf   = Just prf-    | otherwise                 = Nothing-      where-        prf = primProof arg---- | not exported, this is the one place where invalid proofs can be constructed-primProof :: PrimalityArgument -> PrimalityProof-primProof (Division p l) = TrialDivision p l-primProof (Obvious p) = Trivial p-primProof (Assumption p) = case certify p of-                             Composite _ -> Trivial p   -- we're faking to not raise an error-                             Prime proof -> proof-primProof (Pock p a b fcts) = Pocklington p a b (map prove fcts)-  where-    prove (x,y,z,arg) = (x,y,z,primProof arg)---- | @'argueCompositeness'@ transforms a proof of compositeness into an argument---   for compositeness.-argueCompositeness :: CompositenessProof -> CompositenessArgument-argueCompositeness (Factors c f s) = Divisors c f s-argueCompositeness (StrongFermat c b) = Fermat c b-argueCompositeness (LucasSelfridge c) = Lucas c---- | @'verifyCompositenessArgument'@ checks the given argument and constructs a proof from---   it, if it is valid. For the explicit arguments, this is simple and resonably fast,---   for a 'Belief', the verification uses 'certify' and hence may take a long time.-verifyCompositenessArgument :: CompositenessArgument -> Maybe CompositenessProof-verifyCompositenessArgument (Belief c)-    = case certify c of-        Composite proof -> Just proof-        Prime _ -> Nothing-verifyCompositenessArgument arg-    | checkCompositenessProof prf = Just prf-    | otherwise = Nothing-      where-        prf = compProof arg---- | not exported, here is where invalid proofs can be constructed,---   they must not leak-compProof :: CompositenessArgument -> CompositenessProof-compProof (Divisors c f s) = Factors c f s-compProof (Fermat c b) = StrongFermat c b-compProof (Lucas c) = LucasSelfridge c-compProof (Belief _) = error "Trying to prove by belief"---- | Check the validity of a 'Certificate'. Since it should be impossible---   to construct invalid certificates by the public interface, this should---   never return 'False'.-checkCertificate :: Certificate -> Bool-checkCertificate (Composite cp) = checkCompositenessProof cp-checkCertificate (Prime pp) = checkPrimalityProof pp---- | Check the validity of a 'CompositenessProof'. Since it should be---   impossible to create invalid proofs by the public interface, this---   should never return 'False'.-checkCompositenessProof :: CompositenessProof -> Bool-checkCompositenessProof (Factors c a b) = a > 1 && b > 1 && a*b == c-checkCompositenessProof (StrongFermat c w) = w > 1 && c > w && not (isStrongFermatPP c w)-checkCompositenessProof (LucasSelfridge c) = c > 3 && fromIntegral c .&. (1 :: Int) == 1 && lucasTest c---- | Check the validity of a 'PrimalityProof'. Since it should be---   impossible to create invalid proofs by the public interface, this---   should never return 'False'.-checkPrimalityProof :: PrimalityProof -> Bool-checkPrimalityProof (Trivial n) = isTrivialPrime n-checkPrimalityProof (TrialDivision p b) = p <= b*b && trialDivisionPrimeTo b p-checkPrimalityProof (Pocklington p a b fcts) = b > 0 && a > b && a*b == pm1 && a == ppProd fcts && all verify fcts-  where-    pm1 = p-1-    ppProd pps = product [pf^e | (pf,e,_,_) <- pps]-    verify (pf,_,base,proof) = pf == cprime proof && crit pf base && checkPrimalityProof proof-    crit pf base = gcd p (x-1) == 1 && y == 1-      where-        x = powModInteger base (pm1 `quot` pf) p-        y = powModInteger x pf p---- | @'trivial'@ records a trivially known prime.---   If the argument is not one of them, an error is raised.-trivial :: Integer -> PrimalityProof-trivial n = fromMaybe oops $ maybeTrivial n-  where-    oops = error ("trivial: " ++ show n ++ " isn't a trivially known prime.")---- | @'maybeTrivial'@ finds out if its argument is a trivially known---   prime or not and returns the appropriate.-maybeTrivial :: Integer -> Maybe PrimalityProof-maybeTrivial n-    | isTrivialPrime n  = Just (Trivial n)-    | otherwise         = Nothing---- | @'isTrivialPrime'@ checks whether its argument is a trivially---   known prime.-isTrivialPrime :: Integer -> Bool-isTrivialPrime n = n `elem` trivialPrimes---- | List of trivially known primes.-trivialPrimes :: [Integer]-trivialPrimes = [2,3,5,7,11,13,17,19,23,29]---- | Certify a small number. This is not exposed and should only---   be used where correct. It is always checked after use, though,---   so it shouldn't be able to lie.-smallCert :: Integer -> PrimalityProof-smallCert n-    | n < 30    = Trivial n-    | otherwise = TrialDivision n (integerSquareRoot' n + 1)---- | @'certify' n@ constructs, for @n > 1@, a proof of either---   primality or compositeness of @n@. This may take a very long---   time if the number has no small(ish) prime divisors-certify :: Integer -> Certificate-certify n-    | n < 2     = error "Only numbers larger than 1 can be certified"-    | n < 31    = case trialDivisionWith trivialPrimes n of-                    ((p,_):_) | p < n     -> Composite (Factors n p (n `quot` p))-                              | otherwise -> Prime (Trivial n)-                    _ -> error "Impossible"-    | n < billi = let r2 = integerSquareRoot' n + 2 in-                  case trialDivisionTo r2 n of-                    ((p,_):_) | p < n       -> Composite (Factors n p (n `quot` p))-                              | otherwise   -> Prime (TrialDivision n r2)-                    _ -> error "Impossible"-    | otherwise = case smallFactors 100000 n of-                    ([], Just _) | not (isStrongFermatPP n 2) -> Composite (StrongFermat n 2)-                                 | not (lucasTest n) -> Composite (LucasSelfridge n)-                                 | otherwise -> Prime (certifyBPSW n)       -- if it isn't we error and ask for a report.-                    ((p,_):_, _) | p == n -> Prime (TrialDivision n (min 100000 n))-                                 | otherwise -> Composite (Factors n p (n `quot` p))-                    _ -> error ("***Error factorising " ++ show n ++ "! Please report this to maintainer of arithmoi.")-      where-        billi = 1000000000000---- | Certify a number known to be not too small, having no small prime divisors and having---   passed the Baillie PSW test. So we assume it's prime, erroring if not.---   Since it's presumably a large number, we don't bother with trial division and---   construct a Pocklington certificate.-certifyBPSW :: Integer -> PrimalityProof-certifyBPSW n = Pocklington n a b kfcts-  where-    nm1 = n-1-    h = nm1 `quot` 2-    m3 = fromInteger n .&. (3 :: Int) == 3-    (a,pp,b) = findDecomposition nm1-    kfcts0 = map check pp-    kfcts = foldl' force [] kfcts0-    force xs t@(_,_,_,prf) = prf `seq` (t:xs)-    check (p,e,byTD) = go 2-      where-        go bs-            | bs > h    = error (bpswMessage n)-            | x == 1    = if m3 && (p == 2) then (p,e,n-bs,Trivial 2) else go (bs+1)-            | g /= 1    = error (bpswMessage n ++ found g)-            | y /= 1    = error (bpswMessage n ++ fermat bs)-            | byTD      = (p,e,bs, smallCert p)-            | otherwise = case certify p of-                            Composite cpr -> error ("***Error in factorisation code: " ++ show p-                                                        ++ " was supposed to be prime but isn't.\n"-                                                        ++ "Please report this to the maintainer.\n\n"-                                                        ++ show cpr)-                            Prime ppr ->(p,e,bs,ppr)-              where-                q = nm1 `quot` p-                x = powModInteger bs q n-                y = powModInteger x p n-                g = gcd n (x-1)---- | Find a decomposition of p-1 for the pocklington certificate.---   Usually bloody slow if p-1 has two (or more) /large/ prime divisors.-findDecomposition :: Integer -> (Integer, [(Integer,Int,Bool)], Integer)-findDecomposition n = go 1 n [] prms-  where-    sr = integerSquareRoot' n-    pbd = min 1000000 (sr+20)-    prms = primeList (primeSieve $ pbd)-    go a b afs (p:ps)-        | a > b     = (a,afs,b)-        | otherwise = case splitOff p b of-                        (0,_) -> go a b afs ps-                        (e,q) -> go (a*p^e) q ((p,e,True):afs) ps-    go a b afs []-        | a > b     = (a,afs,b)-        | bailliePSW b  = (b,[(b,1,False)],a)   -- Until a Baillie PSW pseudoprime is found, I'm going with this-        | e == 0    = error ("Error in factorisation, " ++ show p ++ " was found as a factor of " ++ show b ++ " but isn't.")-        | otherwise = go (a*p^e) q ((p,e,False):afs) []-          where-            p = findFactor b 8 6-            (e,q) = splitOff p b---- | Find a factor of a known composite with approximately digits digits,---   starting with curve s. Actually, this may loop infinitely, but the---   loop should not be entered before the heat death of the universe.-findFactor :: Integer -> Int -> Integer -> Integer-findFactor n digits s = case findLoop n lo hi count s of-                          Left t  -> findFactor n (digits+5) t-                          Right f -> f-  where-    (lo,hi,count) = findParms digits---- | Find a factor or say with which curve to continue.-findLoop :: Integer -> Word -> Word -> Word -> Integer -> Either Integer Integer-findLoop _ _  _  0  s = Left s-findLoop n lo hi ct s-    | n <= s+2  = Left 6-    | otherwise = case s `modulo` fromInteger n of-                    InfMod{}   -> error "impossible case"-                    SomeMod sn -> case montgomeryFactorisation lo hi sn of-                      Nothing -> findLoop n lo hi (ct-1) (s+1)-                      Just fct-                        | bailliePSW fct -> Right fct-                        | otherwise -> Right (findFactor fct 8 (s+1))---- | Message in the unlikely case a Baillie PSW pseudoprime is found.-bpswMessage :: Integer -> String-bpswMessage n = unlines-                    [ "\n***Congratulations! You found a Baillie PSW pseudoprime!"-                    , "Please report this finding to the package maintainer,"-                    , "<daniel.is.fischer@googlemail.com>"-                    , "The number in question is:\n"-                    , show n-                    , "\nOther parties like wikipedia might also be interested."-                    , "\nSorry for aborting your programme, but this is a major discovery."-                    ]---- | Found a factor-found :: Integer -> String-found g = "\nA nontrivial divisor is:\n" ++ show g---- | Fermat failure-fermat :: Integer -> String-fermat b = "\nThe Fermat test fails for base\n" ++ show b
Math/NumberTheory/Primes/Testing/Certified.hs view
@@ -3,15 +3,35 @@ -- Copyright:   (c) 2011 Daniel Fischer -- Licence:     MIT -- Maintainer:  Daniel Fischer <daniel.is.fischer@googlemail.com>--- Stability:   Provisional--- Portability: Non-portable (GHC extensions) -- -- Deterministic primality testing.-module Math.NumberTheory.Primes.Testing.Certified (isCertifiedPrime) where -import Math.NumberTheory.Primes.Testing.Probabilistic-import Math.NumberTheory.Primes.Testing.Certificates.Internal+{-# LANGUAGE MagicHash           #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UnboxedTuples       #-}+{-# LANGUAGE ViewPatterns        #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +module Math.NumberTheory.Primes.Testing.Certified+  ( isCertifiedPrime+  ) where++import Prelude hiding (Foldable(..))+import Data.Bits ((.&.))+import Data.Foldable+import Data.Mod+import Data.Proxy+import GHC.Num.Integer+import GHC.TypeNats (SomeNat(..), someNatVal)++import Math.NumberTheory.Roots (integerSquareRoot)+import Math.NumberTheory.Primes (unPrime)+import Math.NumberTheory.Primes.Factorisation.TrialDivision (trialDivisionPrimeTo, trialDivisionTo, trialDivisionWith)+import Math.NumberTheory.Primes.Factorisation.Montgomery (montgomeryFactorisation, smallFactors, findParms)+import Math.NumberTheory.Primes.Testing.Probabilistic (bailliePSW, isPrime, isStrongFermatPP, lucasTest)+import Math.NumberTheory.Primes.Sieve.Eratosthenes (primeList, primeSieve)+import Math.NumberTheory.Utils (splitOff)+ -- | @'isCertifiedPrime' n@ tests primality of @n@, first trial division --   by small primes is performed, then a Baillie PSW test and finally a --   prime certificate is constructed and verified, provided no step before@@ -26,3 +46,173 @@ -- Although it is known that there are no Baillie PSW pseudoprimes below 2^64, -- use the verified bound 10^17, I don't know whether Gilchrist's result has been -- verified yet.++-- | A proof of primality of a positive number. The type is+--   abstract to ensure the validity of proofs.+data PrimalityProof+    = Pocklington { cprime :: !Integer          -- ^ The number whose primality is proved.+                  , _factorisedPart, _cofactor :: !Integer+                  , _knownFactors :: ![(Integer, Word, Integer, PrimalityProof)]+                  }+    | TrialDivision { cprime :: !Integer        -- ^ The number whose primality is proved.+                    , _tdLimit :: !Integer }+    | Trivial { cprime :: !Integer              -- ^ The number whose primality is proved.+              }+      deriving Show++-- | Check the validity of a 'PrimalityProof'. Since it should be+--   impossible to create invalid proofs by the public interface, this+--   should never return 'False'.+checkPrimalityProof :: PrimalityProof -> Bool+checkPrimalityProof (Trivial n) = isTrivialPrime n+checkPrimalityProof (TrialDivision p b) = p <= b*b && trialDivisionPrimeTo b p+checkPrimalityProof (Pocklington p a b fcts) = b > 0 && a > b && a*b == pm1 && a == ppProd fcts && all verify fcts+  where+    pm1 = p-1+    ppProd pps = product [pf^e | (pf,e,_,_) <- pps]+    verify (pf,_,base,proof) = pf == cprime proof && crit pf base && checkPrimalityProof proof+    crit pf base = gcd p (toInteger x-1) == 1 && y == 1+      where+        (# x | #) = integerPowMod# base (pm1 `quot` pf) (fromInteger p)+        (# y | #) = integerPowMod# (toInteger x) pf (fromInteger p)++-- | @'isTrivialPrime'@ checks whether its argument is a trivially+--   known prime.+isTrivialPrime :: Integer -> Bool+isTrivialPrime n = n `elem` trivialPrimes++-- | List of trivially known primes.+trivialPrimes :: [Integer]+trivialPrimes = [2,3,5,7,11,13,17,19,23,29]++-- | Certify a small number. This is not exposed and should only+--   be used where correct. It is always checked after use, though,+--   so it shouldn't be able to lie.+smallCert :: Integer -> PrimalityProof+smallCert n+    | n < 30    = Trivial n+    | otherwise = TrialDivision n (integerSquareRoot n + 1)++-- | @'certify' n@ constructs, for @n > 1@, a proof of either+--   primality or compositeness of @n@. This may take a very long+--   time if the number has no small(ish) prime divisors+certify :: Integer -> Maybe PrimalityProof+certify n+    | n < 2     = error "Only numbers larger than 1 can be certified"+    | n < 31    = case trialDivisionWith trivialPrimes n of+                    ((p,_):_) | p < n     -> Nothing+                              | otherwise -> Just (Trivial n)+                    _ -> error "Impossible"+    | n < billi = let r2 = integerSquareRoot n + 2 in+                  case trialDivisionTo r2 n of+                    ((p,_):_) | p < n       -> Nothing+                              | otherwise   -> Just (TrialDivision n r2)+                    _ -> error "Impossible"+    | otherwise = case smallFactors (fromInteger (abs n)) of+                    ([], Just _) | not (isStrongFermatPP n 2) -> Nothing+                                 | not (lucasTest n) -> Nothing+                                 | otherwise -> Just (certifyBPSW n)       -- if it isn't we error and ask for a report.+                    ((toInteger -> p,_):_, _)+                      | p == n -> Just (TrialDivision n (min 100000 n))+                      | otherwise -> Nothing+                    _ -> error ("***Error factorising " ++ show n ++ "! Please report this to maintainer of arithmoi.")+      where+        billi = 1000000000000++-- | Certify a number known to be not too small, having no small prime divisors and having+--   passed the Baillie PSW test. So we assume it's prime, erroring if not.+--   Since it's presumably a large number, we don't bother with trial division and+--   construct a Pocklington certificate.+certifyBPSW :: Integer -> PrimalityProof+certifyBPSW n = Pocklington n a b kfcts+  where+    nm1 = n-1+    h = nm1 `quot` 2+    m3 = fromInteger n .&. (3 :: Int) == 3+    (a,pp,b) = findDecomposition nm1+    kfcts0 = map check pp+    kfcts = foldl' force [] kfcts0+    force xs t@(_,_,_,prf) = prf `seq` (t:xs)+    check (p,e,byTD) = go 2+      where+        go bs+            | bs > h    = error (bpswMessage n)+            | x == 1    = if m3 && (p == 2) then (p,e,n-bs,Trivial 2) else go (bs+1)+            | g /= 1    = error (bpswMessage n ++ found g)+            | y /= 1    = error (bpswMessage n ++ fermat bs)+            | byTD      = (p,e,bs, smallCert p)+            | otherwise = case certify p of+                            Nothing -> error ("***Error in factorisation code: " ++ show p+                                                        ++ " was supposed to be prime but isn't.\n"+                                                        ++ "Please report this to the maintainer.\n\n")+                            Just ppr ->(p,e,bs,ppr)+              where+                q = nm1 `quot` p+                (# x | #) = integerPowMod# bs q (fromInteger n)+                (# y | #) = integerPowMod# (toInteger x) p (fromInteger n)+                g = gcd n (toInteger x-1)++-- | Find a decomposition of p-1 for the pocklington certificate.+--   Usually bloody slow if p-1 has two (or more) /large/ prime divisors.+findDecomposition :: Integer -> (Integer, [(Integer, Word, Bool)], Integer)+findDecomposition n = go 1 n [] prms+  where+    sr = integerSquareRoot n+    pbd = min 1000000 (sr+20)+    prms = map unPrime $ primeList (primeSieve pbd)+    go a b afs (p:ps)+        | a > b     = (a,afs,b)+        | otherwise = case splitOff p b of+                        (0,_) -> go a b afs ps+                        (e,q) -> go (a*p^e) q ((p,e,True):afs) ps+    go a b afs []+        | a > b     = (a,afs,b)+        | bailliePSW b  = (b,[(b,1,False)],a)   -- Until a Baillie PSW pseudoprime is found, I'm going with this+        | e == 0    = error ("Error in factorisation, " ++ show p ++ " was found as a factor of " ++ show b ++ " but isn't.")+        | otherwise = go (a*p^e) q ((p,e,False):afs) []+          where+            p = findFactor b 8 6+            (e,q) = splitOff p b++-- | Find a factor of a known composite with approximately digits digits,+--   starting with curve s. Actually, this may loop infinitely, but the+--   loop should not be entered before the heat death of the universe.+findFactor :: Integer -> Int -> Integer -> Integer+findFactor n digits s = case findLoop n lo hi count s of+                          Left t  -> findFactor n (digits+5) t+                          Right f -> f+  where+    (lo,hi,count) = findParms digits++-- | Find a factor or say with which curve to continue.+findLoop :: Integer -> Word -> Word -> Word -> Integer -> Either Integer Integer+findLoop _ _  _  0  s = Left s+findLoop n lo hi ct s+    | n <= s+2  = Left 6+    | otherwise = case someNatVal (fromInteger n) of+                    SomeNat (_ :: Proxy t) -> case montgomeryFactorisation lo hi (fromInteger s :: Mod t) of+                      Nothing -> findLoop n lo hi (ct-1) (s+1)+                      Just fct+                        | bailliePSW fct -> Right fct+                        | otherwise -> Right (findFactor fct 8 (s+1))++-- | Message in the unlikely case a Baillie PSW pseudoprime is found.+bpswMessage :: Integer -> String+bpswMessage n = unlines+                    [ "\n***Congratulations! You found a Baillie PSW pseudoprime!"+                    , "Please report this finding to the maintainers:"+                    , "<daniel.is.fischer@googlemail.com>,"+                    , "<andrew.lelechenko@gmail.com>"+                    , "The number in question is:\n"+                    , show n+                    , "\nOther parties like wikipedia might also be interested."+                    , "\nSorry for aborting your program, but this is a major discovery."+                    ]++-- | Found a factor+found :: Integer -> String+found g = "\nA nontrivial divisor is:\n" ++ show g++-- | Fermat failure+fermat :: Integer -> String+fermat b = "\nThe Fermat test fails for base\n" ++ show b
Math/NumberTheory/Primes/Testing/Probabilistic.hs view
@@ -3,12 +3,13 @@ -- Copyright:   (c) 2011 Daniel Fischer, 2017 Andrew Lelechenko -- Licence:     MIT -- Maintainer:  Daniel Fischer <daniel.is.fischer@googlemail.com>--- Stability:   Provisional--- Portability: Non-portable (GHC extensions) -- -- Probabilistic primality tests, Miller-Rabin and Baillie-PSW.-{-# LANGUAGE CPP, MagicHash, BangPatterns #-}-{-# OPTIONS_HADDOCK hide #-}++{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE MagicHash           #-}+{-# LANGUAGE ScopedTypeVariables #-}+ module Math.NumberTheory.Primes.Testing.Probabilistic   ( isPrime   , millerRabinV@@ -18,17 +19,18 @@   , lucasTest   ) where -#include "MachDeps.h"- import Data.Bits-import GHC.Base-import GHC.Integer.GMP.Internals-import GHC.TypeNats.Compat+import Data.Mod+import Data.Proxy+import GHC.Num.BigNat+import GHC.Num.Integer+import GHC.Exts (Word(..), Int(..), (-#), (<#), isTrue#)+import GHC.TypeNats (KnownNat, SomeNat(..), someNatVal) -import Math.NumberTheory.Moduli.Class-import Math.NumberTheory.Moduli.Jacobi+import Math.NumberTheory.Moduli.JacobiSymbol+import Math.NumberTheory.Primes.Small+import Math.NumberTheory.Roots import Math.NumberTheory.Utils-import Math.NumberTheory.Powers.Squares  -- | @isPrime n@ tests whether @n@ is a prime (negative or positive). --   It is a combination of trial division and Baillie-PSW test.@@ -57,9 +59,17 @@ -- If @millerRabinV k n@ returns @False@ then @n@ is definitely composite. -- Otherwise @n@ may appear composite with probability @1/4^k@. millerRabinV :: Int -> Integer -> Bool-millerRabinV (I# k) n = case testPrimeInteger n k of-  0# -> False-  _  -> True+millerRabinV k n+  | n < 0       = millerRabinV k (-n)+  | n < 2       = False+  | n < 4       = True+  | otherwise   = go smallPrimes+    where+      go (p:ps)+        | p*p > n   = True+        | otherwise = (n `rem` p /= 0) && go ps+      go [] = all (isStrongFermatPP n) (take k smallPrimes)+      smallPrimes = map toInteger $ smallPrimesFromTo minBound maxBound  -- | @'isStrongFermatPP' n b@ tests whether non-negative @n@ is --   a strong Fermat probable prime for base @b@.@@ -85,15 +95,14 @@   | n < 0          = error "isStrongFermatPP: negative argument"   | n <= 1         = False   | n == 2         = True-  | otherwise      = case b `modulo` fromInteger n of-                       SomeMod b' -> isStrongFermatPPMod b'-                       InfMod{}   -> True+  | otherwise      = case someNatVal (fromInteger n) of+                     SomeNat (_ :: Proxy t) -> isStrongFermatPPMod (fromInteger b :: Mod t)  isStrongFermatPPMod :: KnownNat n => Mod n -> Bool isStrongFermatPPMod b = b == 0 || a == 1 || go t a   where     m = -1-    (t, u) = shiftToOddCount $ getVal m+    (t, u) = shiftToOddCount $ unMod m     a = b ^% u      go 0 _ = False@@ -116,9 +125,8 @@ --   of prime bases is reasonable to find out whether it's worth the --   effort to undertake the prime factorisation). isFermatPP :: Integer -> Integer -> Bool-isFermatPP n b = case b `modulo` fromInteger n of-  SomeMod b' -> b' ^% (n-1) == 1-  InfMod{}   -> True+isFermatPP n b = case someNatVal (fromInteger n) of+  SomeNat (_ :: Proxy t) -> (fromInteger b :: Mod t) ^% (n-1) == 1  -- | Primality test after Baillie, Pomerance, Selfridge and Wagstaff. --   The Baillie-PSW test consists of a strong Fermat probable primality@@ -149,14 +157,12 @@ --   the Fermat test. For package-internal use only. lucasTest :: Integer -> Bool lucasTest n-  | square || d == 0    = False-  | d == 1              = True-  | otherwise           = uo == 0 || go t vo qo+  | isSquare n || d == 0 = False+  | d == 1               = True+  | otherwise            = uo == 0 || go t vo qo     where-      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)@@ -169,7 +175,7 @@  -- n odd positive, n > abs q, index odd testLucas :: Integer -> Integer -> Integer -> (Integer, Integer, Integer)-testLucas n q (S# i#) = look (WORD_SIZE_IN_BITS - 2)+testLucas n q (IS i#) = look (finiteBitSize (0 :: Word) - 2)   where     j = I# i#     look k@@ -187,29 +193,19 @@           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#)+testLucas n q (IP bn#) = test (s# -# 1#)   where-    s# = sizeofBigNat# bn#-    test j# = case indexBigNat# bn# j# of-#endif+    s# = bigNatSize# bn#+    test j# = case bigNatIndex# bn# j# of                 0## -> test (j# -# 1#)-                w# -> look (j# -# 1#) (W# w#) (WORD_SIZE_IN_BITS - 1)+                w# -> look (j# -# 1#) (W# w#) (finiteBitSize (0 :: Word) - 1)     look j# w i       | testBit w i = go j# w (i - 1) 1 1 1 q       | otherwise   = look j# w (i-1)     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+                         else go (k# -# 1#) (W# (bigNatIndex# bn# k#)) (finiteBitSize (0 :: Word) - 1) un un1 vn qn       | 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 +216,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
+ Math/NumberTheory/Primes/Types.hs view
@@ -0,0 +1,169 @@+-- |+-- Module:      Math.NumberTheory.Primes.Types+-- Copyright:   (c) 2017 Andrew Lelechenko+-- Licence:     MIT+-- Maintainer:  Andrew Lelechenko <andrew.lelechenko@gmail.com>+--+-- This is an internal module, defining types for primes.+-- Should not be exposed to users.+--++{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE DeriveGeneric         #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module Math.NumberTheory.Primes.Types+  ( Prime(..)+  , toPrimeIntegral+  ) where++import Data.Bits+import GHC.Generics+import Control.DeepSeq+import qualified Data.Vector.Generic as G+import qualified Data.Vector.Generic.Mutable as M+import qualified Data.Vector.Unboxed as U++import Math.NumberTheory.Utils.FromIntegral++-- $setup+-- >>> import Math.NumberTheory.Primes (nextPrime, precPrime)++-- | Wrapper for prime elements of @a@. It is supposed to be constructed+-- by 'Math.NumberTheory.Primes.nextPrime' / 'Math.NumberTheory.Primes.precPrime'.+-- and eliminated by 'unPrime'.+--+-- One can leverage 'Enum' instance to generate lists of primes.+-- Here are some examples.+--+-- *  Generate primes from the given interval:+--+--    >>> :set -XFlexibleContexts+--    >>> [nextPrime 101 .. precPrime 130]+--    [Prime 101,Prime 103,Prime 107,Prime 109,Prime 113,Prime 127]+--+-- *  Generate an infinite list of primes:+--+--    > [nextPrime 101 ..]+--    > [Prime 101,Prime 103,Prime 107,Prime 109,Prime 113,Prime 127...+--+-- *  Generate primes from the given interval of form p = 6k+5:+--+--    >>> [nextPrime 101, nextPrime 107 .. precPrime 150]+--    [Prime 101,Prime 107,Prime 113,Prime 131,Prime 137,Prime 149]+--+-- *  Get next prime:+--+--    >>> succ (nextPrime 101)+--    Prime 103+--+-- *  Get previous prime:+--+--    >>> pred (nextPrime 101)+--    Prime 97+--+-- *  Count primes less than a given number (cf. 'Math.NumberTheory.Primes.Counting.approxPrimeCount'):+--+--    >>> fromEnum (precPrime 100)+--    25+--+-- *  Get 25-th prime number (cf. 'Math.NumberTheory.Primes.Counting.nthPrimeApprox'):+--+--    >>> toEnum 25 :: Prime Int+--    Prime 97+--+newtype Prime a = Prime+  { unPrime :: a -- ^ Unwrap prime element.+  }+  deriving (Eq, Ord, Generic)++instance NFData a => NFData (Prime a)++instance Show a => Show (Prime a) where+  showsPrec d (Prime p) r = (if d > 10 then "(" ++ s ++ ")" else s) ++ r+    where+      s = "Prime " ++ show p++newtype instance U.MVector s (Prime a) = MV_Prime (U.MVector s a)+newtype instance U.Vector    (Prime a) = V_Prime  (U.Vector    a)++instance U.Unbox a => U.Unbox (Prime a)++instance M.MVector U.MVector a => M.MVector U.MVector (Prime a) where+  {-# INLINE basicLength #-}+  {-# INLINE basicUnsafeSlice #-}+  {-# INLINE basicOverlaps #-}+  {-# INLINE basicUnsafeNew #-}+  {-# INLINE basicInitialize #-}+  {-# INLINE basicUnsafeReplicate #-}+  {-# INLINE basicUnsafeRead #-}+  {-# INLINE basicUnsafeWrite #-}+  {-# INLINE basicClear #-}+  {-# INLINE basicSet #-}+  {-# INLINE basicUnsafeCopy #-}+  {-# INLINE basicUnsafeGrow #-}+  basicLength (MV_Prime v) = M.basicLength v+  basicUnsafeSlice i n (MV_Prime v) = MV_Prime $ M.basicUnsafeSlice i n v+  basicOverlaps (MV_Prime v1) (MV_Prime v2) = M.basicOverlaps v1 v2+  basicUnsafeNew n = MV_Prime <$> M.basicUnsafeNew n+  basicInitialize (MV_Prime v) = M.basicInitialize v+  basicUnsafeReplicate n x = MV_Prime <$> M.basicUnsafeReplicate n (unPrime x)+  basicUnsafeRead (MV_Prime v) i = Prime <$> M.basicUnsafeRead v i+  basicUnsafeWrite (MV_Prime v) i x = M.basicUnsafeWrite v i (unPrime x)+  basicClear (MV_Prime v) = M.basicClear v+  basicSet (MV_Prime v) x = M.basicSet v (unPrime x)+  basicUnsafeCopy (MV_Prime v1) (MV_Prime v2) = M.basicUnsafeCopy v1 v2+  basicUnsafeMove (MV_Prime v1) (MV_Prime v2) = M.basicUnsafeMove v1 v2+  basicUnsafeGrow (MV_Prime v) n = MV_Prime <$> M.basicUnsafeGrow v n++instance G.Vector U.Vector a => G.Vector U.Vector (Prime a) where+  {-# INLINE basicUnsafeFreeze #-}+  {-# INLINE basicUnsafeThaw #-}+  {-# INLINE basicLength #-}+  {-# INLINE basicUnsafeSlice #-}+  {-# INLINE basicUnsafeIndexM #-}+  {-# INLINE elemseq #-}+  basicUnsafeFreeze (MV_Prime v) = V_Prime <$> G.basicUnsafeFreeze v+  basicUnsafeThaw (V_Prime v) = MV_Prime <$> G.basicUnsafeThaw v+  basicLength (V_Prime v) = G.basicLength v+  basicUnsafeSlice i n (V_Prime v) = V_Prime $ G.basicUnsafeSlice i n v+  basicUnsafeIndexM (V_Prime v) i = Prime <$> G.basicUnsafeIndexM v i+  basicUnsafeCopy (MV_Prime mv) (V_Prime v) = G.basicUnsafeCopy mv v+  elemseq _ = seq++-- | Convert between primes of different types, similar in spirit to 'toIntegralSized'.+--+-- A simpler version of this function is:+--+-- > toPrimeIntegral :: (Integral a, Integral b) => a -> Maybe b+-- > toPrimeIntegral (Prime a)+-- >   | toInteger a == b = Just (Prime (fromInteger b))+-- >   | otherwise        = Nothing+-- >   where+-- >     b = toInteger a+--+-- The point of 'toPrimeIntegral' is to avoid redundant conversions and conditions,+-- when it is safe to do so, determining type sizes statically with 'bitSizeMaybe'.+-- For example, 'toPrimeIntegral' from 'Prime' 'Int' to 'Prime' 'Word' boils down to+-- 'Just' . 'fromIntegral'.+--+toPrimeIntegral :: (Integral a, Integral b, Bits a, Bits b) => Prime a -> Maybe (Prime b)+toPrimeIntegral (Prime a) = case unsignedWidth b of+  Nothing -> res+  Just bW -> case unsignedWidth a of+    Just aW+      | aW <= bW -> res+    _+      | a <= bit bW - 1 -> res+      | otherwise       -> Nothing+  where+    b = fromIntegral' a+    res = Just (Prime b)+{-# INLINE toPrimeIntegral #-}++unsignedWidth :: Bits a => a -> Maybe Int+unsignedWidth t+  | isSigned t = subtract 1 <$> bitSizeMaybe t+  | otherwise  =                bitSizeMaybe t+{-# INLINE unsignedWidth #-}
+ Math/NumberTheory/Quadratic/EisensteinIntegers.hs view
@@ -0,0 +1,338 @@+-- |+-- Module:      Math.NumberTheory.EisensteinIntegers+-- Copyright:   (c) 2018 Alexandre Rodrigues Baldé+-- Licence:     MIT+-- Maintainer:  Alexandre Rodrigues Baldé <alexandrer_b@outlook.com>+--+-- This module exports functions for manipulating Eisenstein integers, including+-- computing their prime factorisations.+--++{-# LANGUAGE BangPatterns   #-}+{-# LANGUAGE DeriveGeneric  #-}+{-# LANGUAGE PostfixOperators #-}+{-# LANGUAGE RankNTypes     #-}+{-# LANGUAGE TypeFamilies   #-}++module Math.NumberTheory.Quadratic.EisensteinIntegers+  ( EisensteinInteger(..)+  , ω+  , conjugate+  , norm+  , associates+  , ids++  -- * Primality functions+  , findPrime+  , primes+  ) where++import Prelude hiding (quot, quotRem, gcd)+import Control.DeepSeq+import Data.Coerce+import Data.Euclidean+import Data.List                                       (mapAccumL)+import Data.List.Infinite (Infinite(..), (...))+import qualified Data.List.Infinite as Inf+import Data.List.NonEmpty (NonEmpty(..))+import Data.Maybe+import Data.Ord                                        (comparing)+import qualified Data.Semiring as S+import GHC.Generics                                    (Generic)++import Math.NumberTheory.Moduli.Sqrt+import Math.NumberTheory.Primes.Types+import qualified Math.NumberTheory.Primes as U+import Math.NumberTheory.Utils                          (mergeBy)+import Math.NumberTheory.Utils.FromIntegral++infix 6 :+++-- | An Eisenstein integer is @a + bω@, where @a@ and @b@ are both integers.+data EisensteinInteger = !Integer :+ !Integer+    deriving (Eq, Ord, Generic)++instance NFData EisensteinInteger++-- | 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++instance S.Semiring EisensteinInteger where+    plus          = (+)+    times         = (*)+    zero          = 0 :+ 0+    one           = 1 :+ 0+    fromNatural n = naturalToInteger n :+ 0++instance S.Ring EisensteinInteger where+    negate = negate++-- | Returns an @EisensteinInteger@'s sign, and its associate in the first+-- sextant.+absSignum :: EisensteinInteger -> (EisensteinInteger, EisensteinInteger)+absSignum 0 = (0, 0)+absSignum z@(a :+ b)+  -- first sextant: 0 ≤ Arg(z) < π/3+  | a > b && b >= 0 = (z, 1)+  -- second sextant: π/3 ≤ Arg(z) < 2π/3+  | b >= a && a > 0 = (b :+ (b - a), 1 :+ 1)+  -- third sextant: 2π/3 ≤ Arg(z) < π+  | b > 0 && 0 >= a = ((b - a) :+ (-a), 0 :+ 1)+  -- fourth sextant: -π ≤ Arg(z) < -2π/3+  | a < b && b <= 0 = (-z, -1)+  -- fifth sextant: -2π/3 ≤ Arg(η) < -π/3+  | b <= a && a < 0 = ((-b) :+ (a - b), (-1) :+ (-1))+  -- sixth sextant: -π/3 ≤ Arg(η) < 0+  | otherwise       = ((a - b) :+ a, 0 :+ (-1))++-- | 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++instance GcdDomain EisensteinInteger++instance Euclidean EisensteinInteger where+  degree = fromInteger . norm+  quotRem x (d :+ 0) = quotRemInt x d+  quotRem x y = (q, x - q * y)+    where+      (q, _) = quotRemInt (x * conjugate y) (norm y)++quotRemInt :: EisensteinInteger -> Integer -> (EisensteinInteger, EisensteinInteger)+quotRemInt z   1  = ( z, 0)+quotRemInt z (-1) = (-z, 0)+quotRemInt (a :+ b) c = (qa :+ qb, (ra - bumpA) :+ (rb - bumpB))+  where+    halfC    = abs c `quot` 2+    bumpA    = signum a * halfC+    bumpB    = signum b * halfC+    (qa, ra) = (a + bumpA) `quotRem` c+    (qb, rb) = (b + bumpB) `quotRem` c++-- | 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 <http://thekeep.eiu.edu/theses/2467 Bandara, Sarada, "An Exposition of the Eisenstein Integers" (2016)>,+-- 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 = isJust $ U.isPrime a'+          | nE `mod` 3 == 1            = isJust $ U.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 -> (Word, EisensteinInteger)+divideByThree = go 0+  where+    go :: Word -> EisensteinInteger -> (Word, 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@.+--+-- >>> import Math.NumberTheory.Primes (nextPrime)+-- >>> findPrime (nextPrime 7)+-- Prime 3+2*ω+findPrime :: Prime Integer -> U.Prime EisensteinInteger+findPrime p = case (r, sqrtsModPrime (9 * q * q - 1) p) of+  (1, z : _) -> Prime $ abs $ gcd (unPrime p :+ 0) ((z - 3 * q) :+ 1)+  _ -> error "findPrime: argument must be prime p = 6k + 1"+  where+    (q, r) = unPrime p `quotRem` 6++-- | An infinite list of Eisenstein primes. Uses primes in @Z@ to exhaustively+-- generate all Eisenstein primes in order of ascending norm.+--+-- * 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.+--+-- >>> take 10 primes+-- [Prime 2+ω,Prime 2,Prime 3+2*ω,Prime 3+ω,Prime 4+3*ω,Prime 4+ω,Prime 5+3*ω,Prime 5+2*ω,Prime 5,Prime 6+5*ω]+primes :: Infinite (Prime EisensteinInteger)+primes = coerce $ (2 :+ 1) :< mergeBy (comparing norm) l r+  where+    leftPrimes, rightPrimes :: Infinite (Prime Integer)+    (leftPrimes, rightPrimes) = Inf.partition (\p -> unPrime p `mod` 3 == 2) (U.nextPrime 2...)++    rightPrimes' :: Infinite (Prime Integer)+    rightPrimes' = Inf.filter (\prime -> unPrime prime `mod` 3 == 1) $ Inf.tail rightPrimes++    l :: Infinite EisensteinInteger+    l = fmap (\p -> unPrime p :+ 0) leftPrimes++    r :: Infinite EisensteinInteger+    r = Inf.concatMap+        (\p -> let x :+ y = unPrime (findPrime p) in (x :+ y) :| [x :+ (x - y)])+        rightPrimes'++-- | [Implementation notes for factorise function]+--+-- Compute the prime factorisation of a Eisenstein integer.+--+--     1. 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@.+--     2. 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@.+--     3. In the previously mentioned work <http://thekeep.eiu.edu/theses/2467 Bandara, Sarada, "An Exposition of the Eisenstein Integers" (2016)>,+--        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 Eisenstein primes.+--+-- Applying @norm@ to both sides of the equation from Theorem 8.4:+--+-- 1. @norm μ = norm ( (-1)^a * ω^b * (1 - ω)^c * product [ π_i^a_i | i <- [1..N]] ) ==@+-- 2. @norm μ = norm ((-1)^a) * norm (ω^b) * norm ((1 - ω)^c) * norm (product [ π_i^a_i | i <- [1..N]]) ==@+-- 3. @norm μ = (norm (-1))^a * (norm ω)^b * (norm (1 - ω))^c * product [ norm (π_i^a_i) | i <- [1..N]] ==@+-- 4. @norm μ = (norm (-1))^a * (norm ω)^b * (norm (1 - ω))^c * product [ (norm π_i)^a_i) | i <- [1..N]] ==@+-- 5. @norm μ = 1^a * 1^b * 3^c * product [ (norm π_i)^a_i) | i <- [1..N]] ==@+-- 6. @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 Eisenstein primes @[e_i | i <- [1..M]]@ such that+-- @map norm [e_i | i <- [1..M]] == map norm [π_i | i <- [1..N]]@+-- where @ 1 < N <= M@ are integers and @==@ is equality on sets+-- (i.e.duplicates do not matter).+--+-- NB: The reason @M >= N@ is because the prime factors of an Eisenstein integer+-- may include a prime factor and its conjugate (both have the same norm),+-- meaning the number may have more Eisenstein prime factors than its norm has+-- integer prime factors.+factorise :: EisensteinInteger -> [(Prime EisensteinInteger, Word)]+factorise g = concat $+              snd $+              mapAccumL go (abs g) (U.factorise $ norm g)+  where+    go :: EisensteinInteger -> (Prime Integer, Word) -> (EisensteinInteger, [(Prime EisensteinInteger, Word)])+    go z (Prime 3, e)+      | e == n    = (q, [(Prime (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)+      | unPrime p `mod` 3 == 2+      = let e' = e `quot` 2 in (z `quotI` (unPrime p ^ e'), [(Prime (unPrime p :+ 0), e')])++      -- The @`rem` 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 = findPrime p+        x :+ y = unPrime gp+        -- @gp'@ is @gp@'s conjugate.+        gp' = Prime (x :+ (x - y))+        (k, k', z') = divideByPrime gp gp' (unPrime 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+    :: Prime EisensteinInteger -- ^ Eisenstein prime @p@+    -> Prime EisensteinInteger -- ^ Conjugate of @p@+    -> Integer                 -- ^ Precomputed norm of @p@, of form @4k + 1@+    -> Word                    -- ^ Expected number of factors (either @p@ or @conjugate p@)+                               --   in Eisenstein integer @z@+    -> EisensteinInteger       -- ^ Eisenstein integer @z@+    -> ( Word                  -- Multiplicity of factor @p@ in @z@+       , Word                  -- Multiplicity of factor @conjigate p@ in @z@+       , EisensteinInteger     -- Remaining Eisenstein integer+       )+divideByPrime p p' np k = go k 0+    where+        go :: Word -> Word -> EisensteinInteger -> (Word, Word, 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'' = iterate (\g -> fromMaybe err $ (g * unPrime p) `quotEvenI` np) z' !! max 0 (wordToInt d2)++        go1 :: Word -> Word -> EisensteinInteger -> (Word, EisensteinInteger)+        go1 0 d z = (d, z)+        go1 c d z+            | Just z' <- (z * unPrime 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++-------------------------------------------------------------------------------++-- | See the source code and Haddock comments for the @factorise@ and @isPrime@+-- functions in this module (they are not exported) for implementation+-- details.+instance U.UniqueFactorisation EisensteinInteger where+  factorise 0 = []+  factorise e = coerce $ factorise e++  isPrime e = if isPrime e then Just (Prime e) else Nothing
+ Math/NumberTheory/Quadratic/GaussianIntegers.hs view
@@ -0,0 +1,271 @@+-- |+-- Module:      Math.NumberTheory.GaussianIntegers+-- Copyright:   (c) 2016 Chris Fredrickson, Google Inc.+-- Licence:     MIT+-- Maintainer:  Chris Fredrickson <chris.p.fredrickson@gmail.com>+--+-- This module exports functions for manipulating Gaussian integers, including+-- computing their prime factorisations.+--++{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE PostfixOperators #-}+{-# LANGUAGE TypeFamilies  #-}++module Math.NumberTheory.Quadratic.GaussianIntegers (+    GaussianInteger(..),+    ι,+    conjugate,+    norm,+    ids,+    associates,+    primes,+    findPrime,+) where++import Prelude hiding (quot, quotRem)+import Control.DeepSeq (NFData)+import Data.Coerce+import Data.Euclidean+import Data.List (mapAccumL)+import Data.List.Infinite (Infinite(..), (...))+import qualified Data.List.Infinite as Inf+import Data.List.NonEmpty (NonEmpty(..))+import Data.Maybe+import Data.Ord (comparing)+import qualified Data.Semiring as S+import GHC.Generics++import Math.NumberTheory.Moduli.Sqrt+import Math.NumberTheory.Roots (integerSquareRoot)+import Math.NumberTheory.Primes.Types+import qualified Math.NumberTheory.Primes as U+import Math.NumberTheory.Utils              (mergeBy)+import Math.NumberTheory.Utils.FromIntegral++infix 6 :++-- |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++instance S.Semiring GaussianInteger where+    plus          = (+)+    times         = (*)+    zero          = 0 :+ 0+    one           = 1 :+ 0+    fromNatural n = naturalToInteger n :+ 0++instance S.Ring GaussianInteger where+    negate = negate++absSignum :: GaussianInteger -> (GaussianInteger, GaussianInteger)+absSignum 0 = (0, 0)+absSignum z@(a :+ b)+  -- first quadrant: (0, inf) x [0, inf)i+  | a >  0 && b >= 0 = (z, 1)+  -- second quadrant: (-inf, 0] x (0, inf)i+  | a <= 0 && b >  0 = (b :+ (-a), ι)+  -- third quadrant: (-inf, 0) x (-inf, 0]i+  | a <  0 && b <= 0 = (-z, -1)+  -- fourth quadrant: [0, inf) x (-inf, 0)i+  | otherwise        = ((-b) :+ a, -ι)++-- | List of all Gaussian units, counterclockwise across all quadrants,+-- starting with @1@.+--+-- @since 0.13.4.0+ids :: [GaussianInteger]+ids = [1, ι, -1, -ι]++-- | Produce a list of a @GaussianInteger@'s associates.+--+-- @since 0.13.4.0+associates :: GaussianInteger -> [GaussianInteger]+associates (a :+ b) = [a :+ b, (-b) :+ a, (-a) :+ (-b), b :+ (-a)]++instance GcdDomain GaussianInteger++instance Euclidean GaussianInteger where+  degree = fromInteger . norm+  quotRem x (d :+ 0) = quotRemInt x d+  quotRem x y = (q, x - q * y)+    where+      (q, _) = quotRemInt (x * conjugate y) (norm y)++quotRemInt :: GaussianInteger -> Integer -> (GaussianInteger, GaussianInteger)+quotRemInt z   1  = ( z, 0)+quotRemInt z (-1) = (-z, 0)+quotRemInt (a :+ b) c = (qa :+ qb, (ra - bumpA) :+ (rb - bumpB))+  where+    halfC    = abs c `quot` 2+    bumpA    = signum a * halfC+    bumpB    = signum b * halfC+    (qa, ra) = (a + bumpA) `quotRem` c+    (qb, rb) = (b + bumpB) `quotRem` c++-- |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 && isJust (U.isPrime y)+    | y == 0 && x /= 0 = abs x `mod` 4 == 3 && isJust (U.isPrime x)+    | otherwise        = isJust $ U.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.+--+-- >>> take 10 primes+-- [Prime 1+ι,Prime 2+ι,Prime 1+2*ι,Prime 3,Prime 3+2*ι,Prime 2+3*ι,Prime 4+ι,Prime 1+4*ι,Prime 5+2*ι,Prime 2+5*ι]+primes :: Infinite (U.Prime GaussianInteger)+primes = coerce $ (1 :+ 1) :< mergeBy (comparing norm) l r+  where+    leftPrimes, rightPrimes :: Infinite (Prime Integer)+    (leftPrimes, rightPrimes) = Inf.partition (\p -> unPrime p `mod` 4 == 3) (U.nextPrime 3 ...)++    l :: Infinite (GaussianInteger)+    l = fmap (\p -> unPrime p :+ 0) leftPrimes++    r :: Infinite (GaussianInteger)+    r = Inf.concatMap+        (\p -> let x :+ y = unPrime (findPrime p) in (x :+ y) :| [y :+ x])+        rightPrimes++-- |Find a Gaussian integer whose norm is the given prime number+-- of form 4k + 1 using+-- <http://www.ams.org/journals/mcom/1972-26-120/S0025-5718-1972-0314745-6/S0025-5718-1972-0314745-6.pdf Hermite-Serret algorithm>.+--+-- >>> import Math.NumberTheory.Primes (nextPrime)+-- >>> findPrime (nextPrime 5)+-- Prime 2+ι+findPrime :: Prime Integer -> U.Prime GaussianInteger+findPrime p = case sqrtsModPrime (-1) p of+    []    -> error "findPrime: an argument must be prime p = 4k + 1"+    z : _ -> Prime $ go (unPrime p) z -- Effectively we calculate gcdG' (p :+ 0) (z :+ 1)+    where+        sqrtp :: Integer+        sqrtp = integerSquareRoot (unPrime p)++        go :: Integer -> Integer -> GaussianInteger+        go g h+            | g <= sqrtp = g :+ h+            | otherwise  = go h (g `mod` h)++-- | 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 -> [(Prime GaussianInteger, Word)]+factorise g = concat $ snd $ mapAccumL go g (U.factorise $ norm g)+    where+        go :: GaussianInteger -> (Prime Integer, Word) -> (GaussianInteger, [(Prime GaussianInteger, Word)])+        go z (Prime 2, e) = (divideByTwo z, [(Prime (1 :+ 1), e)])+        go z (p, e)+            | unPrime p `mod` 4 == 3+            = let e' = e `quot` 2 in (z `quotI` (unPrime p ^ e'), [(Prime (unPrime p :+ 0), e')])+            | otherwise+            = (z', filter ((> 0) . snd) [(gp, k), (gp', k')])+                where+                    gp = findPrime p+                    (k, k', z') = divideByPrime gp (unPrime p) e z+                    gp' = Prime (abs (conjugate (unPrime 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+    :: Prime GaussianInteger -- ^ Gaussian prime p+    -> Integer               -- ^ Precomputed norm of p, of form 4k + 1+    -> Word                  -- ^ Expected number of factors (either p or conj p)+                             --   in Gaussian integer z+    -> GaussianInteger       -- ^ Gaussian integer z+    -> ( Word                -- Multiplicity of factor p in z+       , Word                -- Multiplicity of factor conj p in z+       , GaussianInteger     -- Remaining Gaussian integer+       )+divideByPrime p np k = go k 0+    where+        go :: Word -> Word -> GaussianInteger -> (Word, Word, 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'' = iterate (\g -> fromMaybe err $ (g * unPrime p) `quotEvenI` np) z' !! wordToInt d2++        go1 :: Word -> Word -> GaussianInteger -> (Word, GaussianInteger)+        go1 0 d z = (d, z)+        go1 c d z+            | Just z' <- (z * conjugate (unPrime 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++-------------------------------------------------------------------------------++instance U.UniqueFactorisation GaussianInteger where+  factorise 0 = []+  factorise g = coerce $ factorise g++  isPrime g = if isPrime g then Just (Prime g) else Nothing
+ Math/NumberTheory/Recurrences.hs view
@@ -0,0 +1,16 @@+-- |+-- Module:      Math.NumberTheory.Recurrences+-- Copyright:   (c) 2018 Alexandre Rodrigues Baldé+-- Licence:     MIT+-- Maintainer:  Alexandre Rodrigues Baldé <alexandrer_b@outlook.com>+--++module Math.NumberTheory.Recurrences+    ( module Math.NumberTheory.Recurrences.Linear+    , module Math.NumberTheory.Recurrences.Bilinear+    , module Math.NumberTheory.Recurrences.Pentagonal+    ) where++import Math.NumberTheory.Recurrences.Bilinear+import Math.NumberTheory.Recurrences.Linear+import Math.NumberTheory.Recurrences.Pentagonal (partition)
+ Math/NumberTheory/Recurrences/Bilinear.hs view
@@ -0,0 +1,346 @@+-- |+-- Module:      Math.NumberTheory.Recurrences.Bilinear+-- Copyright:   (c) 2016 Andrew Lelechenko+-- Licence:     MIT+-- Maintainer:  Andrew Lelechenko <andrew.lelechenko@gmail.com>+--+-- Bilinear recurrent sequences and Bernoulli numbers,+-- roughly covering Ch. 5-6 of /Concrete Mathematics/+-- by R. L. Graham, D. E. Knuth and O. Patashnik.+--+-- #memory# __Note on memory leaks and memoization.__+-- 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+--+-- >>> binomial !! 1000 !! 1000 :: Integer -- (0.01 secs, 1,385,512 bytes)+-- 1+-- >>> binomial !! 1000 !! 1000 :: Integer -- (0.01 secs, 1,381,616 bytes)+-- 1+--+-- against+--+-- >>> let binomial' = binomial :: [[Integer]]+-- >>> binomial' !! 1000 !! 1000 :: Integer -- (0.01 secs, 1,381,696 bytes)+-- 1+-- >>> binomial' !! 1000 !! 1000 :: Integer -- (0.01 secs, 391,152 bytes)+-- 1++{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE PostfixOperators    #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Math.NumberTheory.Recurrences.Bilinear+  ( -- * Pascal triangle+    binomial+  , binomialRotated+  , binomialLine+  , binomialDiagonal+  , binomialFactors+    -- * Other recurrences+  , stirling1+  , stirling2+  , lah+  , eulerian1+  , eulerian2+  , bernoulli+  , euler+  , eulerPolyAt1+  , faulhaberPoly+  ) where++import Data.Euclidean (GcdDomain(..))+import Data.List (scanl', zipWith4)+import Data.List.Infinite (Infinite(..), (...))+import qualified Data.List.Infinite as Inf+import Data.List.NonEmpty (NonEmpty(..))+import Data.Maybe+import Data.Ratio+import Data.Semiring (Semiring(..))+import Numeric.Natural++import Math.NumberTheory.Recurrences.Linear (factorial)+import Math.NumberTheory.Primes++-- | Infinite zero-based table of binomial coefficients (also known as Pascal triangle).+--+-- > binomial !! n !! k == n! / k! / (n - k)!+--+-- Note that 'binomial' !! n !! k is asymptotically slower+-- than 'binomialLine' n !! k,+-- but imposes only 'Semiring' constraint.+--+-- >>> take 6 binomial :: [[Int]]+-- [[1],[1,1],[1,2,1],[1,3,3,1],[1,4,6,4,1],[1,5,10,10,5,1]]+binomial :: Semiring a => Infinite [a]+binomial = Inf.iterate (\l -> zipWith plus (l ++ [zero]) (zero : l)) [one]+{-# SPECIALIZE binomial :: Infinite [Int]     #-}+{-# SPECIALIZE binomial :: Infinite [Word]    #-}+{-# SPECIALIZE binomial :: Infinite [Integer] #-}+{-# SPECIALIZE binomial :: Infinite [Natural] #-}++-- | Pascal triangle, rotated by 45 degrees.+--+-- > binomialRotated !! n !! k == (n + k)! / n! / k! == binomial !! (n + k) !! k+--+-- Note that 'binomialRotated' !! n !! k is asymptotically slower+-- than 'binomialDiagonal' n !! k,+-- but imposes only 'Semiring' constraint.+--+-- >>> take 6 (map (take 6) binomialRotated) :: [[Int]]+-- [[1,1,1,1,1,1],[1,2,3,4,5,6],[1,3,6,10,15,21],[1,4,10,20,35,56],[1,5,15,35,70,126],[1,6,21,56,126,252]]+binomialRotated :: Semiring a => Infinite (Infinite a)+binomialRotated = Inf.iterate (Inf.tail . Inf.scanl' plus zero) (Inf.repeat one)+{-# SPECIALIZE binomialRotated :: Infinite (Infinite Int)     #-}+{-# SPECIALIZE binomialRotated :: Infinite (Infinite Word)    #-}+{-# SPECIALIZE binomialRotated :: Infinite (Infinite Integer) #-}+{-# SPECIALIZE binomialRotated :: Infinite (Infinite Natural) #-}++-- | The n-th (zero-based) line of 'binomial'+-- (and the n-th diagonal of 'binomialRotated').+--+-- >>> binomialLine 5+-- [1,5,10,10,5,1]+binomialLine :: (Enum a, GcdDomain a) => a -> [a]+binomialLine n = scanl'+  (\x (k, nk1) -> fromJust $ (x `times` nk1) `divide` k)+  one+  (zip [one..n] [n, pred n..one])+{-# SPECIALIZE binomialLine :: Int     -> [Int]     #-}+{-# SPECIALIZE binomialLine :: Word    -> [Word]    #-}+{-# SPECIALIZE binomialLine :: Integer -> [Integer] #-}+{-# SPECIALIZE binomialLine :: Natural -> [Natural] #-}++-- | The n-th (zero-based) diagonal of 'binomial'+-- (and the n-th line of 'binomialRotated').+--+-- >>> take 6 (binomialDiagonal 5)+-- [1,6,21,56,126,252]+binomialDiagonal :: (Enum a, GcdDomain a) => a -> Infinite a+binomialDiagonal n = Inf.scanl'+  (\x k -> fromJust (x `times` (n `plus` k) `divide` k))+  one+  (one...)+{-# SPECIALIZE binomialDiagonal :: Int     -> Infinite Int     #-}+{-# SPECIALIZE binomialDiagonal :: Word    -> Infinite Word    #-}+{-# SPECIALIZE binomialDiagonal :: Integer -> Infinite Integer #-}+{-# SPECIALIZE binomialDiagonal :: Natural -> Infinite Natural #-}++-- | Prime factors of a binomial coefficient.+--+-- > binomialFactors n k == factorise (binomial !! n !! k)+--+-- >>> binomialFactors 10 4+-- [(Prime 2,1),(Prime 3,1),(Prime 5,1),(Prime 7,1)]+binomialFactors :: Word -> Word -> [(Prime Word, Word)]+binomialFactors n k+  | n < 2+  = []+  | otherwise+  = filter ((/= 0) . snd)+  $ map (\p -> (p, mult (unPrime p) n - mult (unPrime p) (n - k) - mult (unPrime p) k))+    [minBound .. precPrime n]+  where+    mult :: Word -> Word -> Word+    mult p m = go mp mp+      where+        mp = m `quot` p+        go !acc !x+          | x >= p = let xp = x `quot` p in go (acc + xp) xp+          | otherwise = acc++-- | Infinite zero-based table of <https://en.wikipedia.org/wiki/Stirling_numbers_of_the_first_kind Stirling numbers of the first kind>.+--+-- >>> 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@.+--+-- One could also consider 'Math.Combinat.Numbers.unsignedStirling1st' from <http://hackage.haskell.org/package/combinat combinat> package to compute stand-alone values.+stirling1 :: (Num a, Enum a) => Infinite [a]+stirling1 = Inf.scanl f [1] (0...)+  where+    f xs n = 0 : zipIndexedListWithTail (\_ x y -> x + n * y) 1 xs 0+{-# SPECIALIZE stirling1 :: Infinite [Int]     #-}+{-# SPECIALIZE stirling1 :: Infinite [Word]    #-}+{-# SPECIALIZE stirling1 :: Infinite [Integer] #-}+{-# SPECIALIZE stirling1 :: Infinite [Natural] #-}++-- | Infinite zero-based table of <https://en.wikipedia.org/wiki/Stirling_numbers_of_the_second_kind Stirling numbers of the second kind>.+--+-- >>> 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@.+--+-- One could also consider 'Math.Combinat.Numbers.stirling2nd' from <http://hackage.haskell.org/package/combinat combinat> package to compute stand-alone values.+stirling2 :: (Num a, Enum a) => Infinite [a]+stirling2 = Inf.iterate f [1]+  where+    f xs = 0 : zipIndexedListWithTail (\k x y -> x + k * y) 1 xs 0+{-# SPECIALIZE stirling2 :: Infinite [Int]     #-}+{-# SPECIALIZE stirling2 :: Infinite [Word]    #-}+{-# SPECIALIZE stirling2 :: Infinite [Integer] #-}+{-# SPECIALIZE stirling2 :: Infinite [Natural] #-}++-- | Infinite one-based table of <https://en.wikipedia.org/wiki/Lah_number Lah numbers>.+-- @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]]+--+-- 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@.+lah :: Integral a => Infinite [a]+-- Implementation was derived from code by https://github.com/grandpascorpion+lah = Inf.zipWith f (Inf.tail factorial) (1...)+  where+    f nf n = scanl (\x k -> x * (n - k) `div` (k * (k + 1))) nf [1..n-1]+{-# SPECIALIZE lah :: Infinite [Int]     #-}+{-# SPECIALIZE lah :: Infinite [Word]    #-}+{-# SPECIALIZE lah :: Infinite [Integer] #-}+{-# SPECIALIZE lah :: Infinite [Natural] #-}++-- | Infinite zero-based table of <https://en.wikipedia.org/wiki/Eulerian_number Eulerian numbers of the first kind>.+--+-- >>> 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@.+--+eulerian1 :: (Num a, Enum a) => Infinite [a]+eulerian1 = Inf.scanl f [] (1...)+  where+    f xs n = 1 : zipIndexedListWithTail (\k x y -> (n - k) * x + (k + 1) * y) 1 xs 0+{-# SPECIALIZE eulerian1 :: Infinite [Int]     #-}+{-# SPECIALIZE eulerian1 :: Infinite [Word]    #-}+{-# SPECIALIZE eulerian1 :: Infinite [Integer] #-}+{-# SPECIALIZE eulerian1 :: Infinite [Natural] #-}++-- | Infinite zero-based table of <https://en.wikipedia.org/wiki/Eulerian_number#Eulerian_numbers_of_the_second_kind Eulerian numbers of the second kind>.+--+-- >>> 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@.+--+eulerian2 :: (Num a, Enum a) => Infinite [a]+eulerian2 = Inf.scanl f [] (1...)+  where+    f xs n = 1 : zipIndexedListWithTail (\k x y -> (2 * n - k - 1) * x + (k + 1) * y) 1 xs 0+{-# SPECIALIZE eulerian2 :: Infinite [Int]     #-}+{-# SPECIALIZE eulerian2 :: Infinite [Word]    #-}+{-# SPECIALIZE eulerian2 :: Infinite [Integer] #-}+{-# SPECIALIZE eulerian2 :: Infinite [Natural] #-}++-- | Infinite zero-based sequence of <https://en.wikipedia.org/wiki/Bernoulli_number Bernoulli numbers>,+-- computed via <https://en.wikipedia.org/wiki/Bernoulli_number#Connection_with_Stirling_numbers_of_the_second_kind connection>+-- with 'stirling2'.+--+-- >>> 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' from <http://hackage.haskell.org/package/combinat combinat> package to compute stand-alone values.+bernoulli :: Integral a => Infinite (Ratio a)+bernoulli = helperForBEEP id (Inf.map recip (1...))+{-# SPECIALIZE bernoulli :: Infinite (Ratio Int) #-}+{-# SPECIALIZE bernoulli :: Infinite (Rational) #-}++-- | <https://en.wikipedia.org/wiki/Faulhaber%27s_formula Faulhaber's formula>.+--+-- >>> sum (map (^ 10) [0..100])+-- 959924142434241924250+-- >>> sum $ zipWith (*) (faulhaberPoly 10) (iterate (* 100) 1)+-- 959924142434241924250 % 1+faulhaberPoly :: (GcdDomain a, Integral a) => Int -> [Ratio a]+-- Implementation by https://github.com/CarlEdman+faulhaberPoly p+  = zipWith (*) ((0:)+  $ reverse+  $ Inf.take (p + 1) bernoulli)+  $ map (% (fromIntegral p+1))+  $ zipWith (*) (iterate negate (if odd p then 1 else -1))+  $ binomial Inf.!! (fromIntegral (p+1))++-- | Infinite zero-based list of <https://en.wikipedia.org/wiki/Euler_number Euler numbers>.+-- The algorithm used was derived from <http://www.emis.ams.org/journals/JIS/VOL4/CHEN/AlgBE2.pdf Algorithms for Bernoulli numbers and Euler numbers>+-- by Kwang-Wu Chen, second formula of the Corollary in page 7.+-- Sequence <https://oeis.org/A122045 A122045> 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 => Infinite (Ratio a)+euler' = Inf.tail $ helperForBEEP (drop 1) as+  where+    as :: Infinite (Ratio a)+    as = Inf.zipWith3+        (\sgn frac ones -> (sgn * ones) % frac)+        (Inf.cycle (1 :| [1, 1, 1, -1, -1, -1, -1]))+        (dups (Inf.iterate (2 *) 1))+        (Inf.cycle (1 :| [1, 1, 0]))++    dups :: forall x . Infinite x -> Infinite x+    dups = Inf.foldr (\n list -> n :< n :< list)+{-# SPECIALIZE euler' :: Infinite (Ratio Int)     #-}+{-# SPECIALIZE euler' :: Infinite (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 => Infinite a+euler = Inf.map numerator euler'++-- | Infinite zero-based list of the @n@-th order Euler polynomials evaluated at @1@.+-- The algorithm used was derived from <http://www.emis.ams.org/journals/JIS/VOL4/CHEN/AlgBE2.pdf Algorithms for Bernoulli numbers and Euler numbers>+-- by Kwang-Wu Chen, third formula of the Corollary in page 7.+-- Element-by-element division of sequences <https://oeis.org/A198631 A1986631>+-- and <https://oeis.org/A006519 A006519> 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 => Infinite (Ratio a)+eulerPolyAt1 = Inf.tail $ helperForBEEP (drop 1) (Inf.map recip (Inf.iterate (2 *) 1))+{-# SPECIALIZE eulerPolyAt1 :: Infinite (Ratio Int)     #-}+{-# SPECIALIZE eulerPolyAt1 :: Infinite (Rational)      #-}++-------------------------------------------------------------------------------+-- Utils++-- zipIndexedListWithTail f n as a == zipWith3 f [n..] as (tail as ++ [a])+-- but inlines much better and avoids checks for distinct sizes of lists.+zipIndexedListWithTail :: Enum b => (b -> a -> a -> b) -> b -> [a] -> a -> [b]+zipIndexedListWithTail f n as a = case as of+  []       -> []+  (x : xs) -> go n x xs+  where+    go m y ys = case ys of+      []       -> 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+-- @helperForBEEP@ 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.+helperForBEEP :: Integral a => (forall b. [b] -> [b]) -> Infinite (Ratio a) -> Infinite (Ratio a)+helperForBEEP g xs = Inf.map (f . g) stirling2+  where+    f = sum . zipWith4 (\sgn fact x stir -> sgn * fact * x * stir) (cycle [1, -1]) (Inf.toList factorial) (Inf.toList xs)+{-# INLINABLE helperForBEEP #-}
+ Math/NumberTheory/Recurrences/Linear.hs view
@@ -0,0 +1,161 @@+-- |+-- Module:      Math.NumberTheory.Recurrences.Linear+-- Copyright:   (c) 2011 Daniel Fischer+-- Licence:     MIT+-- Maintainer:  Daniel Fischer <daniel.is.fischer@googlemail.com>+--+-- Efficient calculation of linear recurrent sequences, including Fibonacci and Lucas sequences.++{-# LANGUAGE BangPatterns     #-}+{-# LANGUAGE PostfixOperators #-}++module Math.NumberTheory.Recurrences.Linear+  ( factorial+  , factorialFactors+  , fibonacci+  , fibonacciPair+  , lucas+  , lucasPair+  , generalLucas+  ) where++import Data.Bits+import Data.List.Infinite (Infinite(..), (...))+import qualified Data.List.Infinite as Inf+import Numeric.Natural+import Math.NumberTheory.Primes++-- | Infinite zero-based table of factorials.+--+-- >>> take 5 factorial+-- [1,1,2,6,24]+--+-- The time-and-space behaviour of 'factorial' is similar to described in+-- "Math.NumberTheory.Recurrences.Bilinear#memory".+factorial :: (Num a, Enum a) => Infinite a+factorial = Inf.scanl (*) 1 (1...)+{-# SPECIALIZE factorial :: Infinite Int     #-}+{-# SPECIALIZE factorial :: Infinite Word    #-}+{-# SPECIALIZE factorial :: Infinite Integer #-}+{-# SPECIALIZE factorial :: Infinite Natural #-}++-- | Prime factors of a factorial.+--+-- > factorialFactors n == factorise (factorial !! n)+--+-- >>> factorialFactors 10+-- [(Prime 2,8),(Prime 3,4),(Prime 5,2),(Prime 7,1)]+factorialFactors :: Word -> [(Prime Word, Word)]+factorialFactors n+  | n < 2+  = []+  | otherwise+  = map (\p -> (p, mult (unPrime p))) [minBound .. precPrime n]+  where+    mult :: Word -> Word+    mult p = go np np+      where+        np = n `quot` p+        go !acc !x+          | x >= p = let xp = x `quot` p in go (acc + xp) xp+          | otherwise = acc++-- | @'fibonacci' k@ calculates the @k@-th Fibonacci number in+--   /O/(@log (abs k)@) steps. The index may be negative. This+--   is efficient for calculating single Fibonacci numbers (with+--   large index), but for computing many Fibonacci numbers in+--   close proximity, it is better to use the simple addition+--   formula starting from an appropriate pair of successive+--   Fibonacci numbers.+fibonacci :: Num a => Int -> a+fibonacci = fst . fibonacciPair+{-# SPECIALIZE fibonacci :: Int -> Int     #-}+{-# SPECIALIZE fibonacci :: Int -> Word    #-}+{-# SPECIALIZE fibonacci :: Int -> Integer #-}+{-# SPECIALIZE fibonacci :: Int -> Natural #-}++-- | @'fibonacciPair' k@ returns the pair @(F(k), F(k+1))@ of the @k@-th+--   Fibonacci number and its successor, thus it can be used to calculate+--   the Fibonacci numbers from some index on without needing to compute+--   the previous. The pair is efficiently calculated+--   in /O/(@log (abs k)@) steps. The index may be negative.+fibonacciPair :: Num a => Int -> (a, a)+fibonacciPair n+  | n < 0     = let (f,g) = fibonacciPair (-(n+1)) in if testBit n 0 then (g, -f) else (-g, f)+  | n == 0    = (0, 1)+  | otherwise = look (finiteBitSize (0 :: Word) - 2)+    where+      look k+        | testBit n k = go (k-1) 0 1+        | otherwise   = look (k-1)+      go k g f+        | k < 0       = (f, f+g)+        | testBit n k = go (k-1) (f*(f+shiftL1 g)) ((f+g)*shiftL1 f + g*g)+        | otherwise   = go (k-1) (f*f+g*g) (f*(f+shiftL1 g))+{-# SPECIALIZE fibonacciPair :: Int -> (Int, Int)         #-}+{-# SPECIALIZE fibonacciPair :: Int -> (Word, Word)       #-}+{-# SPECIALIZE fibonacciPair :: Int -> (Integer, Integer) #-}+{-# SPECIALIZE fibonacciPair :: Int -> (Natural, Natural) #-}++-- | @'lucas' k@ computes the @k@-th Lucas number. Very similar+--   to @'fibonacci'@.+lucas :: Num a => Int -> a+lucas = fst . lucasPair+{-# SPECIALIZE lucas :: Int -> Int     #-}+{-# SPECIALIZE lucas :: Int -> Word    #-}+{-# SPECIALIZE lucas :: Int -> Integer #-}+{-# SPECIALIZE lucas :: Int -> Natural #-}++-- | @'lucasPair' k@ computes the pair @(L(k), L(k+1))@ of the @k@-th+--   Lucas number and its successor. Very similar to @'fibonacciPair'@.+lucasPair :: Num a => Int -> (a, a)+lucasPair n+  | n < 0     = let (f,g) = lucasPair (-(n+1)) in if testBit n 0 then (-g, f) else (g, -f)+  | n == 0    = (2, 1)+  | otherwise = look (finiteBitSize (0 :: Word) - 2)+    where+      look k+        | testBit n k = go (k-1) 0 1+        | otherwise   = look (k-1)+      go k g f+        | k < 0       = (shiftL1 g + f,g+3*f)+        | otherwise   = go (k-1) g' f'+          where+            (f',g')+              | testBit n k = (shiftL1 (f*(f+g)) + g*g,f*(shiftL1 g + f))+              | otherwise   = (f*(shiftL1 g + f),f*f+g*g)+{-# SPECIALIZE lucasPair :: Int -> (Int, Int)         #-}+{-# SPECIALIZE lucasPair :: Int -> (Word, Word)       #-}+{-# SPECIALIZE lucasPair :: Int -> (Integer, Integer) #-}+{-# SPECIALIZE lucasPair :: Int -> (Natural, Natural) #-}++-- | @'generalLucas' p q k@ calculates the quadruple @(U(k), U(k+1), V(k), V(k+1))@+--   where @U(i)@ is the Lucas sequence of the first kind and @V(i)@ the Lucas+--   sequence of the second kind for the parameters @p@ and @q@, where @p^2-4q /= 0@.+--   Both sequences satisfy the recurrence relation @A(j+2) = p*A(j+1) - q*A(j)@,+--   the starting values are @U(0) = 0, U(1) = 1@ and @V(0) = 2, V(1) = p@.+--   The Fibonacci numbers form the Lucas sequence of the first kind for the+--   parameters @p = 1, q = -1@ and the Lucas numbers form the Lucas sequence of+--   the second kind for these parameters.+--   Here, the index must be non-negative, since the terms of the sequence for+--   negative indices are in general not integers.+generalLucas :: Num a => a -> a -> Int -> (a, a, a, a)+generalLucas p q k+  | k < 0       = error "generalLucas: negative index"+  | k == 0      = (0,1,2,p)+  | otherwise   = look (finiteBitSize (0 :: Word) - 2)+    where+      look i+        | testBit k i   = go (i-1) 1 p p q+        | otherwise     = look (i-1)+      go i un un1 vn qn+        | i < 0         = (un, un1, vn, p*un1 - shiftL1 (q*un))+        | testBit k i   = go (i-1) (un1*vn-qn) ((p*un1-q*un)*vn - p*qn) ((p*un1 - (2*q)*un)*vn - p*qn) (qn*qn*q)+        | otherwise     = go (i-1) (un*vn) (un1*vn-qn) (vn*vn - 2*qn) (qn*qn)+{-# SPECIALIZE generalLucas :: Int     -> Int     -> Int -> (Int, Int, Int, Int)                 #-}+{-# SPECIALIZE generalLucas :: Word    -> Word    -> Int -> (Word, Word, Word, Word)             #-}+{-# SPECIALIZE generalLucas :: Integer -> Integer -> Int -> (Integer, Integer, Integer, Integer) #-}+{-# SPECIALIZE generalLucas :: Natural -> Natural -> Int -> (Natural, Natural, Natural, Natural) #-}++shiftL1 :: Num a => a -> a+shiftL1 n = n + n
+ Math/NumberTheory/Recurrences/Pentagonal.hs view
@@ -0,0 +1,61 @@+-- |+-- Module:      Math.NumberTheory.Recurrences.Pentagonal+-- Copyright:   (c) 2018 Alexandre Rodrigues Baldé+-- Licence:     MIT+-- Maintainer:  Alexandre Rodrigues Baldé <alexandrer_b@outlook.com>+--+-- Values of <https://en.wikipedia.org/wiki/Partition_(number_theory)#Partition_function partition function>.+--++{-# LANGUAGE PostfixOperators #-}+{-# LANGUAGE TypeApplications #-}++module Math.NumberTheory.Recurrences.Pentagonal+  ( partition+  ) where++import qualified Data.Chimera as Ch+import Data.List.Infinite (Infinite(..), (...))+import qualified Data.List.Infinite as Inf+import Data.Vector (Vector)+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) => Infinite a+pents = Inf.interleave+  (Inf.scanl (\acc n -> acc + 3 * n - 1) 0 (1...))+  (Inf.scanl (\acc n -> acc + 3 * n - 2) 1 (2...))++-- | @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 @Chimera@ from the+-- @chimera@ package to memoize previous results.+partitionF :: Num a => (Word -> a) -> Word -> a+partitionF _ 0 = 1+partitionF f n+  = sum+  $ zipWith (*) (cycle [1, 1, -1, -1])+  $ map (f . (n -))+  $ Inf.takeWhile (<= n)+  $ Inf.tail pents++-- | Infinite zero-based table of <https://oeis.org/A000041 partition numbers>.+--+-- >>> take 10 partition+-- [1,1,2,3,5,7,11,15,22,30]+--+-- >>> :set -XDataKinds+-- >>> import Data.Mod+-- >>> partition !! 1000 :: Mod 1000+-- (991 `modulo` 1000)+partition :: Num a => Infinite a+partition = Inf.tabulate (Ch.index ch)+  where+    ch = Ch.tabulateFix @Vector partitionF+{-# SPECIALIZE partition :: Infinite Int     #-}+{-# SPECIALIZE partition :: Infinite Word    #-}+{-# SPECIALIZE partition :: Infinite Integer #-}+{-# SPECIALIZE partition :: Infinite Natural #-}
− Math/NumberTheory/Recurrencies/Bilinear.hs 
@@ -1,197 +0,0 @@--- |--- Module:      Math.NumberTheory.Recurrencies.Bilinear--- Copyright:   (c) 2016 Andrew Lelechenko--- Licence:     MIT--- Maintainer:  Andrew Lelechenko <andrew.lelechenko@gmail.com>--- Stability:   Provisional--- Portability: Non-portable (GHC extensions)------ Bilinear recurrent sequences and Bernoulli numbers,--- roughly covering Ch. 5-6 of /Concrete Mathematics/--- by R. L. Graham, D. E. Knuth and O. Patashnik.------ #memory# __Note on memory leaks and memoization.__--- 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)------ 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)--{-# LANGUAGE CPP #-}--module Math.NumberTheory.Recurrencies.Bilinear-  ( binomial-  , stirling1-  , stirling2-  , lah-  , eulerian1-  , eulerian2-  , bernoulli-  ) 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]]------ 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@.--- Use the symmetry of Pascal triangle @binomial !! n !! k == binomial !! n !! (n - k)@ to speed up computations.------ One could also consider 'Math.Combinat.Numbers.binomial' to compute stand-alone values.-binomial :: Integral a => [[a]]-binomial = map f [0..]-  where-    f n = scanl (\x k -> x * (n - k + 1) `div` k) 1 [1..n]-{-# SPECIALIZE binomial :: [[Int]]     #-}-{-# SPECIALIZE binomial :: [[Word]]    #-}-{-# SPECIALIZE binomial :: [[Integer]] #-}-{-# SPECIALIZE binomial :: [[Natural]] #-}---- | Infinite zero-based table of <https://en.wikipedia.org/wiki/Stirling_numbers_of_the_first_kind Stirling numbers of the first kind>.------ > > 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@.------ One could also consider 'Math.Combinat.Numbers.unsignedStirling1st' to compute stand-alone values.-stirling1 :: (Num a, Enum a) => [[a]]-stirling1 = scanl f [1] [0..]-  where-    f xs n = 0 : zipIndexedListWithTail (\_ x y -> x + n * y) 1 xs 0-{-# SPECIALIZE stirling1 :: [[Int]]     #-}-{-# SPECIALIZE stirling1 :: [[Word]]    #-}-{-# SPECIALIZE stirling1 :: [[Integer]] #-}-{-# SPECIALIZE stirling1 :: [[Natural]] #-}---- | Infinite zero-based table of <https://en.wikipedia.org/wiki/Stirling_numbers_of_the_second_kind Stirling numbers of the second kind>.------ > > 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@.------ One could also consider 'Math.Combinat.Numbers.stirling2nd' to compute stand-alone values.-stirling2 :: (Num a, Enum a) => [[a]]-stirling2 = iterate f [1]-  where-    f xs = 0 : zipIndexedListWithTail (\k x y -> x + k * y) 1 xs 0-{-# SPECIALIZE stirling2 :: [[Int]]     #-}-{-# SPECIALIZE stirling2 :: [[Word]]    #-}-{-# SPECIALIZE stirling2 :: [[Integer]] #-}-{-# SPECIALIZE stirling2 :: [[Natural]] #-}---- | Infinite one-based table of <https://en.wikipedia.org/wiki/Lah_number Lah numbers>.--- @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]]------ 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@.-lah :: Integral a => [[a]]--- Implementation was derived from code by https://github.com/grandpascorpion-lah = zipWith f (tail factorial) [1..]-  where-    f nf n = scanl (\x k -> x * (n - k) `div` (k * (k + 1))) nf [1..n-1]-{-# SPECIALIZE lah :: [[Int]]     #-}-{-# SPECIALIZE lah :: [[Word]]    #-}-{-# SPECIALIZE lah :: [[Integer]] #-}-{-# SPECIALIZE lah :: [[Natural]] #-}---- | Infinite zero-based table of <https://en.wikipedia.org/wiki/Eulerian_number Eulerian numbers of the first kind>.------ > > 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@.----eulerian1 :: (Num a, Enum a) => [[a]]-eulerian1 = scanl f [] [1..]-  where-    f xs n = 1 : zipIndexedListWithTail (\k x y -> (n - k) * x + (k + 1) * y) 1 xs 0-{-# SPECIALIZE eulerian1 :: [[Int]]     #-}-{-# SPECIALIZE eulerian1 :: [[Word]]    #-}-{-# SPECIALIZE eulerian1 :: [[Integer]] #-}-{-# SPECIALIZE eulerian1 :: [[Natural]] #-}---- | Infinite zero-based table of <https://en.wikipedia.org/wiki/Eulerian_number#Eulerian_numbers_of_the_second_kind Eulerian numbers of the second kind>.------ > > 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@.----eulerian2 :: (Num a, Enum a) => [[a]]-eulerian2 = scanl f [] [1..]-  where-    f xs n = 1 : zipIndexedListWithTail (\k x y -> (2 * n - k - 1) * x + (k + 1) * y) 1 xs 0-{-# SPECIALIZE eulerian2 :: [[Int]]     #-}-{-# SPECIALIZE eulerian2 :: [[Word]]    #-}-{-# SPECIALIZE eulerian2 :: [[Integer]] #-}-{-# SPECIALIZE eulerian2 :: [[Natural]] #-}---- | Infinite zero-based sequence of <https://en.wikipedia.org/wiki/Bernoulli_number Bernoulli numbers>,--- computed via <https://en.wikipedia.org/wiki/Bernoulli_number#Connection_with_Stirling_numbers_of_the_second_kind connection>--- with 'stirling2'.------ > > 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-{-# SPECIALIZE bernoulli :: [Ratio Int] #-}-{-# SPECIALIZE bernoulli :: [Rational] #-}------------------------------------------------------------------------------------ Utils---- zipIndexedListWithTail f n as a == zipWith3 f [n..] as (tail as ++ [a])--- but inlines much better and avoids checks for distinct sizes of lists.-zipIndexedListWithTail :: Enum b => (b -> a -> a -> b) -> b -> [a] -> a -> [b]-zipIndexedListWithTail f n as a = case as of-  []       -> []-  (x : xs) -> go n x xs-  where-    go m y ys = case ys of-      []       -> 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 #-}
− Math/NumberTheory/Recurrencies/Linear.hs 
@@ -1,143 +0,0 @@--- |--- Module:      Math.NumberTheory.Recurrencies.Linear--- Copyright:   (c) 2011 Daniel Fischer--- Licence:     MIT--- Maintainer:  Daniel Fischer <daniel.is.fischer@googlemail.com>--- Stability:   Provisional--- Portability: Non-portable (GHC extensions)------ Efficient calculation of linear recurrent sequences, including Fibonacci and Lucas sequences.--{-# LANGUAGE CPP #-}-module Math.NumberTheory.Recurrencies.Linear-  ( factorial-  , fibonacci-  , fibonacciPair-  , lucas-  , lucasPair-  , generalLucas-  ) where--#include "MachDeps.h"--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]------ The time-and-space behaviour of 'factorial' is similar to described in--- "Math.NumberTheory.Recurrencies.Bilinear#memory".-factorial :: (Num a, Enum a) => [a]-factorial = scanl (*) 1 [1..]-{-# SPECIALIZE factorial :: [Int]     #-}-{-# SPECIALIZE factorial :: [Word]    #-}-{-# SPECIALIZE factorial :: [Integer] #-}-{-# SPECIALIZE factorial :: [Natural] #-}---- | @'fibonacci' k@ calculates the @k@-th Fibonacci number in---   /O/(@log (abs k)@) steps. The index may be negative. This---   is efficient for calculating single Fibonacci numbers (with---   large index), but for computing many Fibonacci numbers in---   close proximity, it is better to use the simple addition---   formula starting from an appropriate pair of successive---   Fibonacci numbers.-fibonacci :: Num a => Int -> a-fibonacci = fst . fibonacciPair-{-# SPECIALIZE fibonacci :: Int -> Int     #-}-{-# SPECIALIZE fibonacci :: Int -> Word    #-}-{-# SPECIALIZE fibonacci :: Int -> Integer #-}-{-# SPECIALIZE fibonacci :: Int -> Natural #-}---- | @'fibonacciPair' k@ returns the pair @(F(k), F(k+1))@ of the @k@-th---   Fibonacci number and its successor, thus it can be used to calculate---   the Fibonacci numbers from some index on without needing to compute---   the previous. The pair is efficiently calculated---   in /O/(@log (abs k)@) steps. The index may be negative.-fibonacciPair :: Num a => Int -> (a, a)-fibonacciPair n-  | n < 0     = let (f,g) = fibonacciPair (-(n+1)) in if testBit n 0 then (g, -f) else (-g, f)-  | n == 0    = (0, 1)-  | otherwise = look (WORD_SIZE_IN_BITS - 2)-    where-      look k-        | testBit n k = go (k-1) 0 1-        | otherwise   = look (k-1)-      go k g f-        | k < 0       = (f, f+g)-        | testBit n k = go (k-1) (f*(f+shiftL1 g)) ((f+g)*shiftL1 f + g*g)-        | otherwise   = go (k-1) (f*f+g*g) (f*(f+shiftL1 g))-{-# SPECIALIZE fibonacciPair :: Int -> (Int, Int)         #-}-{-# SPECIALIZE fibonacciPair :: Int -> (Word, Word)       #-}-{-# SPECIALIZE fibonacciPair :: Int -> (Integer, Integer) #-}-{-# SPECIALIZE fibonacciPair :: Int -> (Natural, Natural) #-}---- | @'lucas' k@ computes the @k@-th Lucas number. Very similar---   to @'fibonacci'@.-lucas :: Num a => Int -> a-lucas = fst . lucasPair-{-# SPECIALIZE lucas :: Int -> Int     #-}-{-# SPECIALIZE lucas :: Int -> Word    #-}-{-# SPECIALIZE lucas :: Int -> Integer #-}-{-# SPECIALIZE lucas :: Int -> Natural #-}---- | @'lucasPair' k@ computes the pair @(L(k), L(k+1))@ of the @k@-th---   Lucas number and its successor. Very similar to @'fibonacciPair'@.-lucasPair :: Num a => Int -> (a, a)-lucasPair n-  | n < 0     = let (f,g) = lucasPair (-(n+1)) in if testBit n 0 then (-g, f) else (g, -f)-  | n == 0    = (2, 1)-  | otherwise = look (WORD_SIZE_IN_BITS - 2)-    where-      look k-        | testBit n k = go (k-1) 0 1-        | otherwise   = look (k-1)-      go k g f-        | k < 0       = (shiftL1 g + f,g+3*f)-        | otherwise   = go (k-1) g' f'-          where-            (f',g')-              | testBit n k = (shiftL1 (f*(f+g)) + g*g,f*(shiftL1 g + f))-              | otherwise   = (f*(shiftL1 g + f),f*f+g*g)-{-# SPECIALIZE lucasPair :: Int -> (Int, Int)         #-}-{-# SPECIALIZE lucasPair :: Int -> (Word, Word)       #-}-{-# SPECIALIZE lucasPair :: Int -> (Integer, Integer) #-}-{-# SPECIALIZE lucasPair :: Int -> (Natural, Natural) #-}---- | @'generalLucas' p q k@ calculates the quadruple @(U(k), U(k+1), V(k), V(k+1))@---   where @U(i)@ is the Lucas sequence of the first kind and @V(i)@ the Lucas---   sequence of the second kind for the parameters @p@ and @q@, where @p^2-4q /= 0@.---   Both sequences satisfy the recurrence relation @A(j+2) = p*A(j+1) - q*A(j)@,---   the starting values are @U(0) = 0, U(1) = 1@ and @V(0) = 2, V(1) = p@.---   The Fibonacci numbers form the Lucas sequence of the first kind for the---   parameters @p = 1, q = -1@ and the Lucas numbers form the Lucas sequence of---   the second kind for these parameters.---   Here, the index must be non-negative, since the terms of the sequence for---   negative indices are in general not integers.-generalLucas :: Num a => a -> a -> Int -> (a, a, a, a)-generalLucas p q k-  | k < 0       = error "generalLucas: negative index"-  | k == 0      = (0,1,2,p)-  | otherwise   = look (WORD_SIZE_IN_BITS - 2)-    where-      look i-        | testBit k i   = go (i-1) 1 p p q-        | otherwise     = look (i-1)-      go i un un1 vn qn-        | i < 0         = (un, un1, vn, p*un1 - shiftL1 (q*un))-        | testBit k i   = go (i-1) (un1*vn-qn) ((p*un1-q*un)*vn - p*qn) ((p*un1 - (2*q)*un)*vn - p*qn) (qn*qn*q)-        | otherwise     = go (i-1) (un*vn) (un1*vn-qn) (vn*vn - 2*qn) (qn*qn)-{-# SPECIALIZE generalLucas :: Int     -> Int     -> Int -> (Int, Int, Int, Int)                 #-}-{-# SPECIALIZE generalLucas :: Word    -> Word    -> Int -> (Word, Word, Word, Word)             #-}-{-# SPECIALIZE generalLucas :: Integer -> Integer -> Int -> (Integer, Integer, Integer, Integer) #-}-{-# SPECIALIZE generalLucas :: Natural -> Natural -> Int -> (Natural, Natural, Natural, Natural) #-}--shiftL1 :: Num a => a -> a-shiftL1 n = n + n
+ Math/NumberTheory/RootsOfUnity.hs view
@@ -0,0 +1,68 @@+-- |+-- Module:      Math.NumberTheory.RootsOfUnity+-- Copyright:   (c) 2018 Bhavik Mehta+-- Licence:     MIT+-- Maintainer:  Bhavik Mehta <bhavikmehta8@gmail.com>+--+-- Implementation of roots of unity+--+++module Math.NumberTheory.RootsOfUnity+(  +-- * Roots of unity+   RootOfUnity (..)+-- ** Conversions+   , toRootOfUnity+   , toComplex )++where++import Data.Complex                                        (Complex(..), cis)+import Data.Semigroup                                      (Semigroup(..))+import Data.Ratio                                          ((%), numerator, denominator)++-- | A representation of <https://en.wikipedia.org/wiki/Root_of_unity roots of unity>: complex+-- numbers \(z\) for which there is \(n\) such that \(z^n=1\).+newtype RootOfUnity =+  RootOfUnity { -- | Every root of unity can be expressed as \(e^{2 \pi i q}\) for some+                -- rational \(q\) satisfying \(0 \leq q < 1\), this function extracts it.+                fromRootOfUnity :: Rational }+  deriving (Eq)++instance Show RootOfUnity where+  show (RootOfUnity q)+    | n == 0    = "1"+    | d == 1    = "-1"+    | n == 1    = "e^(πi/" ++ show d ++ ")"+    | otherwise = "e^(" ++ show n ++ "πi/" ++ show d ++ ")"+    where n = numerator (2*q)+          d = denominator (2*q)++-- | Given a rational \(q\), produce the root of unity \(e^{2 \pi i q}\).+toRootOfUnity :: Rational -> RootOfUnity+toRootOfUnity q = RootOfUnity ((n `rem` d) % d)+  where n = numerator q+        d = denominator q+        -- effectively q `mod` 1+  -- This smart constructor ensures that the rational is always in the range 0 <= q < 1.++-- | This Semigroup is in fact a group, so @'stimes'@ can be called with a negative first argument.+instance Semigroup RootOfUnity where+  RootOfUnity q1 <> RootOfUnity q2 = toRootOfUnity (q1 + q2)+  stimes k (RootOfUnity q) = toRootOfUnity (q * (toInteger k % 1))++instance Monoid RootOfUnity where+  mempty = RootOfUnity 0++-- | Convert a root of unity into an inexact complex number. Due to floating point inaccuracies,+-- it is recommended to avoid use of this until the end of a calculation. Alternatively, with+-- the [cyclotomic](http://hackage.haskell.org/package/cyclotomic-0.5.1) package, one can use+-- @[polarRat](https://hackage.haskell.org/package/cyclotomic-0.5.1/docs/Data-Complex-Cyclotomic.html#v:polarRat)+-- 1 . @'fromRootOfUnity' to convert to a cyclotomic number.+toComplex :: Floating a => RootOfUnity -> Complex a+toComplex (RootOfUnity t)+  | t == 1/2 = (-1) :+ 0+  | t == 1/4 = 0 :+ 1+  | t == 3/4 = 0 :+ (-1)+  | otherwise = cis . (2*pi*) . fromRational $ t
+ Math/NumberTheory/SmoothNumbers.hs view
@@ -0,0 +1,110 @@+-- |+-- Module:      Math.NumberTheory.SmoothNumbers+-- Copyright:   (c) 2018 Frederick Schneider, 2018-2019 Andrew Lelechenko+-- Licence:     MIT+-- Maintainer:  Frederick Schneider <frederick.schneider2011@gmail.com>+--+-- A <https://en.wikipedia.org/wiki/Smooth_number smooth number>+-- is an number, which can be represented as a product of powers of elements+-- from a given set (smooth basis). E. g., 48 = 3 * 4 * 4 is smooth+-- over a set {3, 4}, and 24 is not.+--++{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Math.NumberTheory.SmoothNumbers+  ( SmoothBasis+  , unSmoothBasis+  , fromList+  , isSmooth+  , smoothOver+  , smoothOver'+  ) where++import Prelude hiding (div, mod, gcd, (+))+import Data.Euclidean+import Data.List (nub)+import Data.Maybe+import Data.Semiring++-- | An abstract representation of a smooth basis.+newtype SmoothBasis a = SmoothBasis+  { unSmoothBasis :: [a]+  -- ^ Unwrap elements of a smooth basis.+  }+  deriving (Show)++-- | Build a 'SmoothBasis' from a list of numbers,+-- sanitizing it from duplicates, zeros and units.+--+-- >>> fromList [2, 3]+-- SmoothBasis {unSmoothBasis = [2,3]}+-- >>> fromList [2, 2]+-- SmoothBasis {unSmoothBasis = [2]}+-- >>> fromList [1, 3]+-- SmoothBasis {unSmoothBasis = [3]}+fromList :: (Eq a, GcdDomain a) => [a] -> SmoothBasis a+fromList+  = SmoothBasis+  . filter (\x -> not (isZero x) && isNothing (one `divide` x))+  . nub++-- | A generalization of 'smoothOver',+-- suitable for non-'Integral' domains.+-- The first argument must be an appropriate+-- <https://en.wikipedia.org/wiki/Ideal_norm Ideal norm> function,+-- like 'Math.NumberTheory.Quadratic.GaussianIntegers.norm'+-- or 'Math.NumberTheory.Quadratic.EisensteinIntegers.norm'.+--+-- This routine is more efficient than filtering with 'isSmooth'.+--+-- >>> import Math.NumberTheory.Quadratic.GaussianIntegers+-- >>> take 10 (smoothOver' norm (fromList [1+ι,3]))+-- [1,1+ι,2,2+2*ι,3,4,3+3*ι,4+4*ι,6,8]+smoothOver'+  :: (Eq a, Num a, Ord b)+  => (a -> b) -- ^ <https://en.wikipedia.org/wiki/Ideal_norm Ideal norm>+  -> SmoothBasis a+  -> [a]+smoothOver' norm (SmoothBasis pl) =+  foldr+  (\p l -> foldr skipHead [] $ iterate (map (abs . (Prelude.* p))) l)+  [1]+  pl+  where+    skipHead []      b = b+    skipHead (h : t) b = h : merge t b++    merge a [] = a+    merge [] b = b+    merge a@(ah : at) b@(bh : bt)+      | norm bh < norm ah = bh : merge a bt+      | ah == bh          = ah : merge at bt+      | otherwise         = ah : merge at b++-- | Generate an infinite ascending list of+-- <https://en.wikipedia.org/wiki/Smooth_number smooth numbers>+-- over a given smooth basis.+--+-- This routine is more efficient than filtering with 'isSmooth'.+--+-- >>> take 10 (smoothOver (fromList [2, 5]))+-- [1,2,4,5,8,10,16,20,25,32]+smoothOver :: Integral a => SmoothBasis a -> [a]+smoothOver = smoothOver' abs++-- | Check that a given number is smooth under a given 'SmoothBasis'.+--+-- >>> isSmooth (fromList [2,3]) 12+-- True+-- >>> isSmooth (fromList [2,3]) 15+-- False+isSmooth :: (Eq a, GcdDomain a) => SmoothBasis a -> a -> Bool+isSmooth prs x = not (isZero x) && go (unSmoothBasis prs) x+  where+    go :: (Eq a, GcdDomain a) => [a] -> a -> Bool+    go [] n = isJust (one `divide` n)+    go pps@(p:ps) n = case n `divide` p of+      Nothing -> go ps n+      Just q  -> go pps q || go ps n
− Math/NumberTheory/UniqueFactorisation.hs 
@@ -1,123 +0,0 @@--- |--- Module:      Math.NumberTheory.UniqueFactorisation--- Copyright:   (c) 2016 Andrew Lelechenko--- Licence:     MIT--- Maintainer:  Andrew Lelechenko <andrew.lelechenko@gmail.com>--- Stability:   Provisional--- Portability: Non-portable (GHC extensions)------ An abstract type class for unique factorisation domains.-----{-# LANGUAGE CPP          #-}-{-# LANGUAGE TypeFamilies #-}--module Math.NumberTheory.UniqueFactorisation-  ( Prime-  , UniqueFactorisation(..)-  ) where--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 Math.NumberTheory.GaussianIntegers as G--import Numeric.Natural--newtype SmallPrime = SmallPrime { _unSmallPrime :: Word }-  deriving (Eq, Ord, Show)--newtype BigPrime = BigPrime { _unBigPrime :: Natural }-  deriving (Eq, Ord, Show)---- | Type of primes of a given unique factorisation domain.--- When the domain has exactly one unit, @Prime t = t@,--- but when units are multiple more restricted types--- (or at least newtypes) should be specified.------ @abs (unPrime n) == unPrime n@ must hold for all @n@ of type @Prime t@-type family Prime (f :: *) :: *--type instance Prime Int     = SmallPrime-type instance Prime Word    = SmallPrime-type instance Prime Integer = BigPrime-type instance Prime Natural = BigPrime--type instance Prime G.GaussianInteger = GaussianPrime---- | The following invariant must hold for @n /= 0@:------ > abs n == abs (product (map (\(p, k) -> unPrime p ^ k) (factorise n)))------ The result of 'factorise' should not contain zero powers and should not change after multiplication of the argument by domain's unit.-class UniqueFactorisation a where-  unPrime   :: Prime a -> a-  factorise :: a -> [(Prime a, Word)]--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'--instance UniqueFactorisation Word where-  unPrime     = coerce-  factorise m = if m <= 1-                  then []-                  else map (coerce integerToWord *** intToWord) . F.factorise' . wordToInteger $ m---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'--instance UniqueFactorisation Natural where-  unPrime   = coerce-  factorise m = if m <= 1-                  then []-                  else map (coerce integerToNatural *** intToWord) . F.factorise' . naturalToInteger $ m--newtype GaussianPrime = GaussianPrime { _unGaussianPrime :: G.GaussianInteger }-  deriving (Eq, Show)--instance UniqueFactorisation G.GaussianInteger where-  unPrime = coerce--  factorise 0 = []-  factorise g = map (coerce *** intToWord) $ filter (\(h, _) -> abs h /= 1) $ G.factorise g---------------- Utils--wordToInt :: Word -> Int-wordToInt = fromIntegral--wordToInteger :: Word -> Integer-wordToInteger = fromIntegral--intToWord :: Int -> Word-intToWord = fromIntegral--intToInteger :: Int -> Integer-intToInteger = fromIntegral--naturalToInteger :: Natural -> Integer-naturalToInteger = fromIntegral--integerToNatural :: Integer -> Natural-integerToNatural = fromIntegral--integerToWord :: Integer -> Word-integerToWord = fromIntegral
− Math/NumberTheory/Unsafe.hs 
@@ -1,70 +0,0 @@--- |--- Module:      Math.NumberTheory.Unsafe--- Copyright:   (c) 2016 Andrew Lelechenko--- Licence:     MIT--- Maintainer:  Andrew Lelechenko <andrew.lelechenko@gmail.com>--- Stability:   Provisional------ Layer to switch between safe and unsafe arrays.-----{-# LANGUAGE CPP #-}--module Math.NumberTheory.Unsafe-  ( UArray-  , bounds-  , castSTUArray-  , unsafeAt-  , unsafeFreeze-  , unsafeNewArray_-  , unsafeRead-  , unsafeThaw-  , unsafeWrite-  ) where--#ifdef CheckBounds--import Data.Array.Base-  ( UArray-  , castSTUArray-  )-import Data.Array.IArray-  ( IArray-  , bounds-  , (!)-  )-import Data.Array.MArray--unsafeAt :: (IArray a e, Ix i) => a i e -> i -> e-unsafeAt = (!)--unsafeFreeze :: (Ix i, MArray a e m, IArray b e) => a i e -> m (b i e)-unsafeFreeze = freeze--unsafeNewArray_ :: (Ix i, MArray a e m) => (i, i) -> m (a i e)-unsafeNewArray_ = newArray_--unsafeRead :: (MArray a e m, Ix i) => a i e -> i -> m e-unsafeRead = readArray--unsafeThaw :: (Ix i, IArray a e, MArray b e m) => a i e -> m (b i e)-unsafeThaw = thaw--unsafeWrite :: (MArray a e m, Ix i) => a i e -> i -> e -> m ()-unsafeWrite = writeArray--#else--import Data.Array.Base-  ( UArray-  , bounds-  , castSTUArray-  , unsafeAt-  , unsafeFreeze-  , unsafeNewArray_-  , unsafeRead-  , unsafeThaw-  , unsafeWrite-  )--#endif
Math/NumberTheory/Utils.hs view
@@ -3,50 +3,53 @@ -- Copyright:   (c) 2011 Daniel Fischer -- Licence:     MIT -- Maintainer:  Daniel Fischer <daniel.is.fischer@googlemail.com>--- 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 #-}++{-# LANGUAGE BangPatterns   #-}+{-# LANGUAGE MagicHash      #-}+{-# LANGUAGE UnboxedTuples  #-}+{-# LANGUAGE RankNTypes     #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE DataKinds      #-}+{-# LANGUAGE GADTs          #-}+ module Math.NumberTheory.Utils-    ( shiftToOddCount+    ( SomeKnown(..)+    , shiftToOddCount     , shiftToOdd     , shiftToOdd#     , shiftToOddCount#-    , bitCountWord-    , bitCountInt-    , bitCountWord#-    , uncheckedShiftR+    , shiftToOddCountBigNat     , splitOff-    ) where--#include "MachDeps.h"+    , splitOff# -import GHC.Base+    , mergeBy -import GHC.Integer-import GHC.Integer.GMP.Internals+    , recipMod -import Data.Bits+    , toWheel30+    , fromWheel30+    , withSomeKnown+    , intVal+    ) where -#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+import Prelude hiding (mod, quotRem)+import qualified Prelude as P -uncheckedShiftR :: Word -> Int -> Word-uncheckedShiftR (W# w#) (I# i#) = W# (uncheckedShiftRL# w# i#)+import Data.Bits+import Data.Euclidean+import Data.List.Infinite (Infinite(..))+import Data.Semiring (Semiring(..), isZero)+import GHC.Base+import GHC.Num.BigNat+import GHC.Num.Integer+import GHC.Num.Natural+import qualified Math.NumberTheory.Utils.FromIntegral as UT+import GHC.Natural+import GHC.TypeNats+import Math.NumberTheory.Utils.FromIntegral (intToWord)  -- | Remove factors of @2@ and count them. If --   @n = 2^k*m@ with @m@ odd, the result is @(k, m)@.@@ -55,61 +58,65 @@ "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)-shiftToOddCount n = case shiftOCInteger (fromIntegral n) of+shiftToOddCount :: Integral a => a -> (Word, a)+shiftToOddCount n = case shiftOCInteger (toInteger n) of                       (z, o) -> (z, fromInteger o)  -- | Specialised version for @'Word'@. --   Precondition: argument strictly positive (not checked).-shiftOCWord :: Word -> (Int, Word)+shiftOCWord :: Word -> (Word, Word) shiftOCWord (W# w#) = case shiftToOddCount# w# of-                        (# z# , u# #) -> (I# z#, W# u#)+                        (# z# , u# #) -> (W# z#, W# u#)  -- | Specialised version for @'Int'@. --   Precondition: argument nonzero (not checked).-shiftOCInt :: Int -> (Int, Int)+shiftOCInt :: Int -> (Word, Int) shiftOCInt (I# i#) = case shiftToOddCount# (int2Word# i#) of-                        (# z#, u# #) -> (I# z#, I# (word2Int# u#))+                        (# z#, u# #) -> (W# z#, I# (word2Int# u#))  -- | Specialised version for @'Integer'@. --   Precondition: argument nonzero (not checked).-shiftOCInteger :: Integer -> (Int, Integer)-shiftOCInteger n@(S# i#) =+shiftOCInteger :: Integer -> (Word, Integer)+shiftOCInteger n@(IS i#) =     case shiftToOddCount# (int2Word# i#) of-      (# 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+      (# 0##, _ #) -> (0, n)+      (# z#, w# #) -> (W# z#, integerFromWord# w#)+shiftOCInteger n@(IP bn#) = case bigNatZeroCount bn# of+                                 0## -> (0, n)+                                 z#  -> (W# z#, integerFromBigNat# (bn# `bigNatShiftR#` z#))+shiftOCInteger n@(IN bn#) = case bigNatZeroCount bn# of+                                 0## -> (0, n)+                                 z#  -> (W# z#, integerFromBigNatNeg# (bn# `bigNatShiftR#` z#)) -#if __GLASGOW_HASKELL__ >= 709+-- | Specialised version for @'Natural'@.+--   Precondition: argument nonzero (not checked).+shiftOCNatural :: Natural -> (Word, Natural)+shiftOCNatural n@(NatS# i#) =+    case shiftToOddCount# i# of+      (# 0##, _ #) -> (0, n)+      (# z#, w# #) -> (W# z#, NatS# w#)+shiftOCNatural n@(NatJ# (BN# bn#)) = case bigNatZeroCount bn# of+                                 0## -> (0, n)+                                 z#  -> (W# z#, naturalFromBigNat# (bn# `bigNatShiftR#` z#))++shiftToOddCountBigNat :: BigNat# -> (# Word, BigNat# #)+shiftToOddCountBigNat bn# = case bigNatZeroCount bn# of+  0## -> (# 0, bn# #)+  z#  -> (# W# z#, bn# `bigNatShiftR#` z# #)+ -- | Count trailing zeros in a @'BigNat'@. --   Precondition: argument nonzero (not checked, Integer invariant).-bigNatZeroCount :: BigNat -> Int#-bigNatZeroCount bn# = count 0# 0#+bigNatZeroCount :: BigNat# -> Word#+bigNatZeroCount bn# = count 0## 0#   where+    !(W# bitSize#) = intToWord (finiteBitSize (0 :: Word))     count a# i# =-          case indexBigNat# bn# i# of-            0## -> count (a# +# WORD_SIZE_IN_BITS#) (i# +# 1#)-            w#  -> a# +# trailZeros# w#-#endif+          case bigNatIndex# bn# i# of+            0## -> count (a# `plusWord#` bitSize#) (i# +# 1#)+            w#  -> a# `plusWord#` ctz# w#  -- | Remove factors of @2@. If @n = 2^k*m@ with @m@ odd, the result is @m@. --   Precondition: argument not @0@ (not checked).@@ -120,7 +127,7 @@   #-} {-# INLINE [1] shiftToOdd #-} shiftToOdd :: Integral a => a -> a-shiftToOdd n = fromInteger (shiftOInteger (fromIntegral n))+shiftToOdd n = fromInteger (shiftOInteger (toInteger n))  -- | Specialised version for @'Int'@. --   Precondition: argument nonzero (not checked).@@ -135,70 +142,82 @@ -- | Specialised version for @'Int'@. --   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+shiftOInteger (IS i#) = integerFromWord# (shiftToOdd# (int2Word# i#))+shiftOInteger n@(IP bn#) = case bigNatZeroCount bn# of+                                 0## -> n+                                 z#  -> integerFromBigNat# (bn# `bigNatShiftR#` z#)+shiftOInteger n@(IN bn#) = case bigNatZeroCount bn# of+                                 0## -> n+                                 z#  -> integerFromBigNatNeg# (bn# `bigNatShiftR#` z#)  -- | 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-                        k# -> (# k#, uncheckedShiftRL# w# k# #)+shiftToOddCount# :: Word# -> (# Word#, Word# #)+shiftToOddCount# w# = case ctz# w# of+                        k# -> (# k#, uncheckedShiftRL# w# (word2Int# k#) #) --- | Number of 1-bits in a @'Word#'@.-bitCountWord# :: Word# -> Int#-bitCountWord# w# = case bitCountWord (W# w#) of-                     I# i# -> i#+splitOff :: (Eq a, GcdDomain a) => a -> a -> (Word, a)+splitOff p n+  | isZero n  = (0, zero) -- prevent infinite loop+  | otherwise = go 0 n+  where+    go !k m = case m `divide` p of+      Just q -> go (k + 1) q+      _      -> (k, m)+{-# INLINABLE splitOff #-} --- | Number of 1-bits in a @'Word'@.-bitCountWord :: Word -> Int-bitCountWord = popCount+-- | It is difficult to convince GHC to unbox output of 'splitOff' and 'splitOff.go',+-- so we fallback to a specialized unboxed version to minimize allocations.+splitOff# :: Word# -> Word# -> (# Word#, Word# #)+splitOff# _ 0## = (# 0##, 0## #)+splitOff# p n = go 0## n+  where+    go k m = case m `quotRemWord#` p of+      (# q, 0## #) -> go (k `plusWord#` 1##) q+      _            -> (# k, m #)+{-# INLINABLE splitOff# #-} --- | Number of 1-bits in an @'Int'@.-bitCountInt :: Int -> Int-bitCountInt = popCount+-- | Merges two ordered lists into an ordered list. Checks for neither its+-- precondition or postcondition.+mergeBy :: (a -> a -> Ordering) -> Infinite a -> Infinite a -> Infinite a+mergeBy cmp = loop+  where+    loop ( x:< xs) (y :< ys)+      = case cmp x y of+         GT -> y :< loop (x :< xs) ys+         _  -> x :< loop xs (y :< ys) --- | 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#)+-- | Work around https://ghc.haskell.org/trac/ghc/ticket/14085+recipMod :: Integer -> Integer -> Maybe Integer+recipMod x m = case integerRecipMod# (x `P.mod` m) (fromInteger m) of+  (# | _ #) -> Nothing+  (# y | #) -> Just (toInteger y) --- {-# SPECIALISE splitOff :: Integer -> Integer -> (Int, Integer),---                            Int -> Int -> (Int, Int),---                            Word -> Word -> (Int, Word)---   #-}-{-# INLINABLE splitOff #-}-splitOff :: Integral a => a -> a -> (Int, a)-splitOff p n = go 0 n+-------------------------------------------------------------------------------+-- Helpers for mapping to rough numbers and back.+-- Copypasted from Data.BitStream.WheelMapping++toWheel30 :: (Integral a, Bits a) => a -> a+toWheel30 i = q `shiftL` 3 + (r + r `shiftR` 4) `shiftR` 2   where-    go !k m = case m `quotRem` p of-                (q,r) | r == 0 -> go (k+1) q-                      | otherwise -> (k,m)+    (q, r) = i `P.quotRem` 30++fromWheel30 :: (Num a, Bits a) => a -> a+fromWheel30 i = ((i `shiftL` 2 - i `shiftR` 2) .|. 1)+              + ((i `shiftL` 1 - i `shiftR` 1) .&. 2)++-------------------------------------------------------------------------------+-- Helpers for dealing with data types parametrised by natural numbers.++data SomeKnown (f :: Nat -> Type) where+  SomeKnown :: KnownNat k => f k -> SomeKnown f++withSomeKnown :: (forall k. KnownNat k => f k -> a) -> SomeKnown f -> a+withSomeKnown f (SomeKnown x) = f x++intVal :: KnownNat k => a k -> Int+intVal = UT.naturalToInt . natVal
+ Math/NumberTheory/Utils/DirichletSeries.hs view
@@ -0,0 +1,93 @@+-- |+-- Module:      Math.NumberTheory.Utils.DirichletSeries+-- Copyright:   (c) 2018 Andrew Lelechenko+-- Licence:     MIT+-- Maintainer:  Andrew Lelechenko <andrew.lelechenko@gmail.com>+--+-- An abstract representation of a Dirichlet series over a semiring.+--++{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeApplications      #-}++module Math.NumberTheory.Utils.DirichletSeries+  ( DirichletSeries+  , fromDistinctAscList+  , lookup+  , filter+  , partition+  , unions+  , union+  , size+  , timesAndCrop+  ) where++import Prelude (Integer, Num, (*))+import Data.Bool (Bool)+import Data.Coerce (coerce)+import Data.Euclidean (Euclidean, quot, divide)+import Data.Function (($), (.))+import Data.Int (Int)+import Data.List (takeWhile)+import Data.Map (Map)+import qualified Data.Map.Strict as M+import Data.Maybe (isJust)+import Data.Ord (Ord, (<=))+import Data.Semiring (Semiring(..))+import Data.Tuple (fst)+import Data.Word (Word)+import Numeric.Natural (Natural)+import Text.Show (Show)++-- Sparse Dirichlet series are represented by an ascending list of pairs.+-- For instance, [(a, b), (c, d)] stands for 1 + b/a^s + d/c^s.+-- Note that the representation still may include a term (1, b), so+-- [(1, b), (c, d)] means (1 + b) + d/c^s.+newtype DirichletSeries a b = DirichletSeries { _unDirichletSeries :: Map a b }+  deriving (Show)++fromDistinctAscList :: forall a b. [(a, b)] -> DirichletSeries a b+fromDistinctAscList = coerce (M.fromDistinctAscList @a @b)++lookup :: (Ord a, Num a, Semiring b) => a -> DirichletSeries a b -> b+lookup 1 (DirichletSeries m) = M.findWithDefault zero 1 m `plus` one+lookup a (DirichletSeries m) = M.findWithDefault zero a m++filter :: forall a b. (a -> Bool) -> DirichletSeries a b -> DirichletSeries a b+filter predicate = coerce (M.filterWithKey @a @b (\k _ -> predicate k))++partition :: forall a b. (a -> Bool) -> DirichletSeries a b -> (DirichletSeries a b, DirichletSeries a b)+partition predicate = coerce (M.partitionWithKey @a @b (\k _ -> predicate k))++unions :: forall a b. (Ord a, Semiring b) => [DirichletSeries a b] -> DirichletSeries a b+unions = coerce (M.unionsWith plus :: [Map a b] -> Map a b)++union :: forall a b. (Ord a, Semiring b) => DirichletSeries a b -> DirichletSeries a b -> DirichletSeries a b+union = coerce (M.unionWith @a @b plus)++size :: forall a b. DirichletSeries a b -> Int+size = coerce (M.size @a @b)++-- | Let as = sum_i k_i/a_i^s and bs = sum_i l_i/b_i^s be Dirichlet series,+-- and all a_i and b_i are divisors of n. Return Dirichlet series cs,+-- which contains all terms as * bs = sum_i m_i/c_i^s such that c_i divides n.+timesAndCrop+  :: (Num a, Euclidean a, Ord a, Semiring b)+  => a+  -> DirichletSeries a b+  -> DirichletSeries a b+  -> DirichletSeries a b+timesAndCrop n (DirichletSeries as) (DirichletSeries bs)+  = DirichletSeries+  $ M.unionWith plus (M.unionWith plus as bs)+  $ M.fromListWith plus+  [ (a * b, fa `times` fb)+  | (b, fb) <- M.assocs bs+  , let nb = n `quot` b+  , (a, fa) <- takeWhile ((<= nb) . fst) (M.assocs as)+  , isJust (nb `divide` a)+  ]+{-# SPECIALISE timesAndCrop :: Semiring b => Int -> DirichletSeries Int b -> DirichletSeries Int b -> DirichletSeries Int b #-}+{-# SPECIALISE timesAndCrop :: Semiring b => Word -> DirichletSeries Word b -> DirichletSeries Word b -> DirichletSeries Word b #-}+{-# SPECIALISE timesAndCrop :: Semiring b => Integer -> DirichletSeries Integer b -> DirichletSeries Integer b -> DirichletSeries Integer b #-}+{-# SPECIALISE timesAndCrop :: Semiring b => Natural -> DirichletSeries Natural b -> DirichletSeries Natural b -> DirichletSeries Natural b #-}
+ Math/NumberTheory/Utils/FromIntegral.hs view
@@ -0,0 +1,152 @@+-- |+-- Module:      Math.NumberTheory.Utils.FromIntegral+-- Copyright:   (c) 2017 Andrew Lelechenko+-- Licence:     MIT+-- Maintainer:  Andrew Lelechenko <andrew.lelechenko@gmail.com>+--+-- Monomorphic `fromIntegral`.+--++{-# LANGUAGE CPP #-}++module Math.NumberTheory.Utils.FromIntegral+  ( wordToInt+  , wordToInteger+  , intToWord+  , intToInt8+  , intToInt64+  , int8ToInt64+  , intToWord8+  , intToWord64+  , int8ToInt+  , int64ToInt+  , word8ToInt+  , word64ToInt+  , intToInteger+  , int16ToInteger+  , int64ToInteger+  , word64ToInteger+  , naturalToInteger+  , integerToNatural+  , integerToWord+  , integerToWord64+  , integerToInt+  , integerToInt64+  , intToNatural+  , naturalToInt+  , intToDouble+  , fromIntegral'+  ) where++import Data.Int+import Data.Word+import Numeric.Natural++wordToInt :: Word -> Int+wordToInt = fromIntegral+{-# INLINE wordToInt #-}++wordToInteger :: Word -> Integer+wordToInteger = fromIntegral+{-# INLINE wordToInteger #-}++intToWord :: Int -> Word+intToWord = fromIntegral+{-# INLINE intToWord #-}++intToInt8 :: Int -> Int8+intToInt8 = fromIntegral+{-# INLINE intToInt8 #-}++intToInt64 :: Int -> Int64+intToInt64 = fromIntegral+{-# INLINE intToInt64 #-}++int8ToInt64 :: Int8 -> Int64+int8ToInt64 = fromIntegral+{-# INLINE int8ToInt64 #-}++intToWord8 :: Int -> Word8+intToWord8 = fromIntegral+{-# INLINE intToWord8 #-}++intToWord64 :: Int -> Word64+intToWord64 = fromIntegral+{-# INLINE intToWord64 #-}++int8ToInt :: Int8 -> Int+int8ToInt = fromIntegral+{-# INLINE int8ToInt #-}++int64ToInt :: Int64 -> Int+int64ToInt = fromIntegral+{-# INLINE int64ToInt #-}++word8ToInt :: Word8 -> Int+word8ToInt = fromIntegral+{-# INLINE word8ToInt #-}++word64ToInt :: Word64 -> Int+word64ToInt = fromIntegral+{-# INLINE word64ToInt #-}++intToInteger :: Int -> Integer+intToInteger = fromIntegral+{-# INLINE intToInteger #-}++int16ToInteger :: Int16 -> Integer+int16ToInteger = fromIntegral+{-# INLINE int16ToInteger #-}++int64ToInteger :: Int64 -> Integer+int64ToInteger = fromIntegral+{-# INLINE int64ToInteger #-}++word64ToInteger :: Word64 -> Integer+word64ToInteger = fromIntegral+{-# INLINE word64ToInteger #-}++naturalToInteger :: Natural -> Integer+naturalToInteger = fromIntegral+{-# INLINE naturalToInteger #-}++integerToNatural :: Integer -> Natural+integerToNatural = fromIntegral'+{-# INLINE integerToNatural #-}++integerToWord :: Integer -> Word+integerToWord = fromIntegral+{-# INLINE integerToWord #-}++integerToWord64 :: Integer -> Word64+integerToWord64 = fromIntegral+{-# INLINE integerToWord64 #-}++integerToInt :: Integer -> Int+integerToInt = fromIntegral+{-# INLINE integerToInt #-}++integerToInt64 :: Integer -> Int64+integerToInt64 = fromIntegral+{-# INLINE integerToInt64 #-}++intToNatural :: Int -> Natural+intToNatural = fromIntegral+{-# INLINE intToNatural #-}++naturalToInt :: Natural -> Int+naturalToInt = fromIntegral+{-# INLINE naturalToInt #-}++intToDouble :: Int -> Double+intToDouble = fromIntegral+{-# INLINE intToDouble #-}++fromIntegral' :: (Integral a, Num b) => a -> b+#if __GLASGOW_HASKELL__ == 900 && __GLASGOW_HASKELL_PATCHLEVEL1__ == 1+-- Cannot use fromIntegral because of https://gitlab.haskell.org/ghc/ghc/-/issues/19411+fromIntegral' = fromInteger . toInteger+#else+fromIntegral' = fromIntegral+#endif+{-# INLINE fromIntegral' #-}
+ Math/NumberTheory/Utils/Hyperbola.hs view
@@ -0,0 +1,83 @@+-- |+-- Module:      Math.NumberTheory.Utils.Hyperbola+-- Copyright:   (c) 2018 Andrew Lelechenko+-- Licence:     MIT+-- Maintainer:  Andrew Lelechenko <andrew.lelechenko@gmail.com>+--+-- Highest points under hyperbola.+--++module Math.NumberTheory.Utils.Hyperbola+  ( pointsUnderHyperbola+  ) where++import Data.Bits++import Math.NumberTheory.Roots++-- | Straightforward computation of+-- [ n `quot` x | x <- [hi, hi - 1 .. lo] ].+-- Unfortunately, such list generator performs poor,+-- so we fall back to manual recursion.+pointsUnderHyperbola0 :: Int -> Int -> Int -> [Int]+pointsUnderHyperbola0 n lo hi+  | n < 0     = error "pointsUnderHyperbola0: first argument must be non-negative"+  | lo <= 0   = error "pointsUnderHyperbola0: second argument must be positive"+  | otherwise = go hi+    where+      go x+        | x < lo    = []+        | otherwise = n `quot` x : go (x - 1)++data Bresenham = Bresenham+  {  bresX       :: !Int+  ,  bresBeta    :: !Int+  , _bresGamma   :: !Int+  , _bresDelta1  :: !Int+  , _bresEpsilon :: !Int+  }++initBresenham :: Int -> Int -> Bresenham+initBresenham n x = Bresenham x beta gamma delta1 epsilon+  where+    beta    = n `quot` x+    epsilon = n `rem` x+    delta1  = n `quot` (x - 1) - beta+    gamma   = beta - (x - 1) * delta1++-- | bresenham(x+1) -> bresenham(x) for x >= (2n)^1/3+stepBack :: Bresenham -> Bresenham+stepBack (Bresenham x' beta' gamma' delta1' epsilon')+  | eps >= x `shiftL` 1 {- delta2 = 2 -}+  = let delta1 = delta1' + 2 in Bresenham x (beta' + delta1) (gamma' + delta1 `shiftL` 1 - x `shiftL` 1) delta1 (eps - x `shiftL` 1)+  | eps >= x {- delta1 = 1 -}+  = let delta1 = delta1' + 1 in Bresenham x (beta' + delta1) (gamma' + delta1 `shiftL` 1 - x) delta1 (eps - x)+  | eps >= 0 {- delta2 =  0 -}+  = Bresenham x (beta' + delta1') (gamma' + delta1' `shiftL` 1) delta1' eps+  | otherwise {- delta2 = -1 -}+  = let delta1 = delta1' - 1 in Bresenham x (beta' + delta1) (gamma' + delta1 `shiftL` 1 + x) delta1 (eps + x)+  where+    x       = x' - 1+    eps     = epsilon' + gamma'+{-# INLINE stepBack #-}++-- | Division-free computation of+-- [ n `quot` x | x <- [hi, hi - 1 .. lo] ].+-- In other words, we compute y-coordinates of highest integral points+-- under hyperbola @x * y = n@ between @x = lo@ and @x = hi@ in reverse order.+--+-- The implementation follows section 5 of <https://arxiv.org/pdf/1206.3369.pdf A successive approximation algorithm for computing the divisor summatory function>+-- by R. Sladkey.+-- It is 2x faster than a trivial implementation for 'Int'.+pointsUnderHyperbola :: Int -> Int -> Int -> [Int]+pointsUnderHyperbola n lo hi+  | n < 0        = error "pointsUnderHyperbola: first argument must be non-negative"+  | lo <= 0      = error "pointsUnderHyperbola: second argument must be positive"+  | hi <  lo     = []+  | hi == lo     = [n `quot` lo]+  | otherwise    = go (initBresenham n hi)+  where+    mid = (integerCubeRoot (2 * n) + 1) `max` lo+    go h+      | bresX h < mid = pointsUnderHyperbola0 n lo ((mid - 1) `min` hi)+      | otherwise = bresBeta h : go (stepBack h)
Math/NumberTheory/Zeta.hs view
@@ -1,115 +1,24 @@ -- | -- Module:      Math.NumberTheory.Zeta--- Copyright:   (c) 2016 Andrew Lelechenko+-- Copyright:   (c) 2018 Alexandre Rodrigues Baldé, Andrew Lelechenko -- Licence:     MIT -- Maintainer:  Andrew Lelechenko <andrew.lelechenko@gmail.com>--- Stability:   Provisional--- Portability: Non-portable (GHC extensions) ----- Riemann zeta-function.+-- Numeric evaluation of various zeta-functions.  {-# LANGUAGE ScopedTypeVariables #-}  module Math.NumberTheory.Zeta-  ( zetas+  ( -- * Riemann zeta-function+    zetas   , zetasEven-  , approximateValue+    -- * Dirichlet beta-function+  , betas+  , betasOdd+    -- * Hurwitz zeta-functions+  , zetaHurwitz   ) 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--- <https://cr.yp.to/bib/2000/borwein.pdf Computational strategies for the Riemann zeta function>--- 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.Hurwitz+import Math.NumberTheory.Zeta.Riemann
+ Math/NumberTheory/Zeta/Dirichlet.hs view
@@ -0,0 +1,71 @@+-- |+-- Module:      Math.NumberTheory.Zeta.Dirichlet+-- Copyright:   (c) 2018 Alexandre Rodrigues Baldé+-- Licence:     MIT+-- Maintainer:  Alexandre Rodrigues Baldé <alexandrer_b@outlook.com>+--+-- Dirichlet beta-function.++{-# LANGUAGE PostfixOperators    #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Math.NumberTheory.Zeta.Dirichlet+  ( betas+  , betasEven+  , betasOdd+  ) where++import Data.ExactPi+import Data.List.Infinite (Infinite(..), (....))+import Data.List.NonEmpty (NonEmpty(..))+import qualified Data.List.Infinite as Inf+import Data.Ratio                     ((%))++import Math.NumberTheory.Recurrences  (euler, factorial)+import Math.NumberTheory.Zeta.Hurwitz (zetaHurwitz)+import Math.NumberTheory.Zeta.Utils   (skipOdds)++-- | Infinite sequence of exact values of Dirichlet beta-function at odd arguments, starting with @β(1)@.+--+-- >>> import Data.ExactPi+-- >>> approximateValue (betasOdd !! 25) :: Double+-- 0.9999999999999987+-- >>> import Data.Number.Fixed+-- >>> approximateValue (betasOdd !! 25) :: Fixed Prec50+-- 0.99999999999999999999999960726927497384196726751694+betasOdd :: Infinite ExactPi+betasOdd = Inf.zipWith Exact ((1, 3)....) $ Inf.zipWith4+                                     (\sgn denom eul twos -> sgn * (eul % (twos * denom)))+                                     (Inf.cycle (1 :| [-1]))+                                     (skipOdds factorial)+                                     (skipOdds euler)+                                     (Inf.iterate (4 *) 4)++-- | 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 -> Infinite a+betasEven eps = (1 / 2) :< hurwitz+  where+    hurwitz :: Infinite a+    hurwitz =+        Inf.zipWith3 (\quarter threeQuarters four ->+            (quarter - threeQuarters) / four)+        (Inf.tail . skipOdds $ zetaHurwitz eps 0.25)+        (Inf.tail . skipOdds $ zetaHurwitz eps 0.75)+        (Inf.iterate (16 *) 16)++-- | Infinite sequence of approximate (up to given precision)+-- values of Dirichlet beta-function at integer arguments, starting with @β(0)@.+--+-- >>> take 5 (betas 1e-14) :: [Double]+-- [0.5,0.7853981633974483,0.9159655941772189,0.9689461462593694,0.9889445517411051]+betas :: (Floating a, Ord a) => a -> Infinite a+betas eps = e :< o :< Inf.scanl1 f (Inf.interleave es os)+  where+    e :< es = betasEven eps+    o :< os = Inf.map (getRationalLimit (\a b -> abs (a - b) < eps) . rationalApproximations) 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))
+ Math/NumberTheory/Zeta/Hurwitz.hs view
@@ -0,0 +1,126 @@+-- |+-- Module:      Math.NumberTheory.Zeta.Hurwitz+-- Copyright:   (c) 2018 Alexandre Rodrigues Baldé+-- Licence:     MIT+-- Maintainer:  Alexandre Rodrigues Baldé <alexandrer_b@outlook.com>+--+-- Hurwitz zeta function.++{-# LANGUAGE PostfixOperators    #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Math.NumberTheory.Zeta.Hurwitz+  ( zetaHurwitz+  ) where++import Data.List.Infinite (Infinite(..), (....))+import qualified Data.List.Infinite as Inf++import Math.NumberTheory.Recurrences (bernoulli, factorial)+import Math.NumberTheory.Zeta.Utils  (skipEvens, skipOdds)++-- | Values of Hurwitz zeta function evaluated at @ζ(s, a)@ for @s ∈ [0, 1 ..]@.+--+-- The algorithm used was based on the Euler-Maclaurin formula and was derived+-- from <http://fredrikj.net/thesis/thesis.pdf Fast and Rigorous Computation of Special Functions to High Precision>+-- by F. Johansson, chapter 4.8, formula 4.8.5.+-- The error for each value in this recurrence is given in formula 4.8.9 as an+--  indefinite integral, and in formula 4.8.12 as a closed form formula.+--+-- It is the __user's responsibility__ to provide an appropriate precision for+-- the type chosen.+--+-- For instance, when using @Double@s, it does not make sense+-- to provide a number @ε < 1e-53@ as the desired precision. For @Float@s,+-- providing an @ε < 1e-24@ also does not make sense.+-- Example of how to call the function:+--+-- >>> zetaHurwitz 1e-15 0.25 !! 5+-- 1024.3489745265808+zetaHurwitz :: forall a . (Floating a, Ord a) => a -> a -> Infinite a+zetaHurwitz eps a = Inf.zipWith3 (\s i t -> s + i + t) ss is ts+  where+    -- When given @1e-14@ as the @eps@ argument, this'll be+    -- @div (33 * (length . takeWhile (>= 1) . iterate (/ 10) . recip) 1e-14) 10 == div (33 * 14) 10@+    -- @div (33 * 14) 10 == 46.+    -- meaning @N,M@ in formula 4.8.5 will be @46@.+    -- Multiplying by 33 and dividing by 10 is because asking for @14@ digits+    -- of decimal precision equals asking for @(log 10 / log 2) * 14 ~ 3.3 * 14 ~ 46@+    -- bits of precision.+    digitsOfPrecision :: Integer+    digitsOfPrecision =+       let magnitude = toInteger . length . takeWhile (>= 1) . iterate (/ 10) . recip $ eps+       in  div (magnitude * 33) 10++    -- @a + n@+    aPlusN :: a+    aPlusN = a + fromInteger digitsOfPrecision++    -- @[(a + n)^s | s <- [0, 1, 2 ..]]@+    powsOfAPlusN :: Infinite a+    powsOfAPlusN = Inf.iterate (aPlusN *) 1++    -- [                   [      1      ] |                   ]+    -- | \sum_{k=0}^\(n-1) | ----------- | | s <- [0, 1, 2 ..] |+    -- [                   [ (a + k) ^ s ] |                   ]+    -- @S@ value in 4.8.5 formula.+    ss :: Infinite a+    ss = let numbers = map ((a +) . fromInteger) [0..digitsOfPrecision-1]+             denoms  = replicate (fromInteger digitsOfPrecision) 1 :<+                       Inf.iterate (zipWith (*) numbers) numbers+         in Inf.map (sum . map recip) denoms++    -- [ (a + n) ^ (1 - s)            a + n         |                   ]+    -- | ----------------- = ---------------------- | s <- [0, 1, 2 ..] |+    -- [       s - 1          (a + n) ^ s * (s - 1) |                   ]+    -- @I@ value in 4.8.5 formula.+    is :: Infinite a+    is = let denoms = Inf.zipWith+                      (\powOfA int -> powOfA * fromInteger int)+                      powsOfAPlusN+                      ((-1, 0)....)+         in Inf.map (aPlusN /) denoms++    -- [      1      |             ]+    -- [ ----------- | s <- [0 ..] ]+    -- [ (a + n) ^ s |             ]+    constants2 :: Infinite a+    constants2 = Inf.map recip powsOfAPlusN++    -- [ [(s)_(2*k - 1) | k <- [1 ..]], s <- [0 ..]], i.e. odd indices of+    -- infinite rising factorial sequences, each sequence starting at a+    -- positive integer.+    pochhammers :: Infinite (Infinite Integer)+    pochhammers = let -- [ [(s)_k | k <- [1 ..]], s <- [1 ..]]+                      pochhs :: Infinite (Infinite Integer)+                      pochhs = Inf.iterate (\(x :< xs) -> Inf.map (`div` x) xs) (Inf.tail factorial)+                  in -- When @s@ is @0@, the infinite sequence of rising+                     -- factorials starting at @s@ is @[0,0,0,0..]@.+                     Inf.repeat 0 :< Inf.map skipOdds pochhs++    -- [            B_2k           |             ]+    -- | ------------------------- | k <- [1 ..] |+    -- [ (2k)! (a + n) ^ (2*k - 1) |             ]+    second :: [a]+    second =+        Inf.take (fromInteger digitsOfPrecision) $+        Inf.zipWith3+        (\bern evenFac denom -> fromRational bern / (denom * fromInteger evenFac))+        (Inf.tail $ skipOdds bernoulli)+        (Inf.tail $ skipOdds factorial)+        -- Recall that @powsOfAPlusN = [(a + n) ^ s | s <- [0 ..]]@, so this+        -- is @[(a + n) ^ (2 * s - 1) | s <- [1 ..]]@+        (skipEvens powsOfAPlusN)++    fracs :: Infinite a+    fracs = Inf.map+            (sum . zipWith (\s p -> s * fromInteger p) second . Inf.toList)+            pochhammers++    -- Infinite list of @T@ values in 4.8.5 formula, for every @s@ in+    -- @[0, 1, 2 ..]@.+    ts :: Infinite a+    ts = Inf.zipWith+         (\constant2 frac -> constant2 * (0.5 + frac))+         constants2+         fracs
+ Math/NumberTheory/Zeta/Riemann.hs view
@@ -0,0 +1,67 @@+-- |+-- Module:      Math.NumberTheory.Zeta.Riemann+-- Copyright:   (c) 2016 Andrew Lelechenko+-- Licence:     MIT+-- Maintainer:  Andrew Lelechenko <andrew.lelechenko@gmail.com>+--+-- Riemann zeta-function.++{-# LANGUAGE PostfixOperators    #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Math.NumberTheory.Zeta.Riemann+  ( zetas+  , zetasEven+  , zetasOdd+  ) where++import Data.ExactPi+import Data.List.Infinite (Infinite(..), (...), (....))+import qualified Data.List.Infinite as Inf+import Data.Ratio                     ((%))++import Math.NumberTheory.Recurrences  (bernoulli)+import Math.NumberTheory.Zeta.Hurwitz (zetaHurwitz)+import Math.NumberTheory.Zeta.Utils   (skipEvens, skipOdds)++-- | 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 :: Infinite ExactPi+zetasEven = Inf.zipWith Exact ((0, 2)....) $ Inf.zipWith (*) (skipOdds bernoulli) cs+  where+    cs :: Infinite Rational+    cs = (- 1 % 2) :< Inf.zipWith (\i f -> i * (-4) / fromInteger (2 * f * (2 * f - 1))) cs (1...)++-- | Infinite sequence of approximate values of Riemann zeta-function+-- at odd arguments, starting with @ζ(1)@.+zetasOdd :: forall a. (Floating a, Ord a) => a -> Infinite a+zetasOdd eps = (1 / 0) :< Inf.tail (skipEvens $ zetaHurwitz eps 1)++-- | Infinite sequence of approximate (up to given precision)+-- values of Riemann zeta-function at integer arguments, starting with @ζ(0)@.+--+-- >>> take 5 (zetas 1e-14) :: [Double]+-- [-0.5,Infinity,1.6449340668482264,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 -> Infinite a+zetas eps = e :< o :< Inf.scanl1 f (Inf.interleave es os)+  where+    e :< es = Inf.map (getRationalLimit (\a b -> abs (a - b) < eps) . rationalApproximations) 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))
+ Math/NumberTheory/Zeta/Utils.hs view
@@ -0,0 +1,31 @@+-- |+-- Module:      Math.NumberTheory.Zeta.Utils+-- Copyright:   (c) 2018 Alexandre Rodrigues Baldé+-- Licence:     MIT+-- Maintainer:  Alexandre Rodrigues Baldé <alexandrer_b@outlook.com>+--+-- Shared utilities used by functions from @Math.NumberTheory.Zeta@.++module Math.NumberTheory.Zeta.Utils+  ( skipEvens+  , skipOdds+  ) where++import Data.List.Infinite (Infinite(..))+import qualified Data.List.Infinite as Inf++-- | 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 :: Infinite a -> Infinite a+skipOdds (x :< _ :< xs) = x :< skipOdds 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 :: Infinite a -> Infinite a+skipEvens = skipOdds . Inf.tail
− Setup.hs 
@@ -1,5 +0,0 @@-module Main where--import Distribution.Simple--main = defaultMain
+ app/SequenceModel.hs view
@@ -0,0 +1,83 @@+-- Model fitting to derive coefficients in+-- Math.NumberTheory.Primes.Sequence.chooseAlgorithm++module Main where++import Numeric.GSL.Fitting++-- | Benchmarks Sequence/filterIsPrime+-- ([start, length], ([time in microseconds], weight))+filterIsPrimeBenchData :: [([Double], ([Double], Double))]+filterIsPrimeBenchData =+  [ ([100000, 1000], ([777], 0.1))+  , ([100000, 10000], ([8523], 0.1))+  , ([1000000, 1000], ([813], 0.1))+  , ([1000000, 10000], ([8247], 0.1))+  , ([1000000, 100000], ([78600], 0.1))+  , ([10000000, 1000], ([765], 0.1))+  , ([10000000, 10000], ([7685], 0.1))+  , ([10000000, 100000], ([78900], 0.1))+  , ([10000000, 1000000], ([785000], 0.1))+  , ([100000000, 1000], ([792], 0.1))+  , ([100000000, 10000], ([8094], 0.1))+  , ([100000000, 100000], ([79280], 0.1))+  , ([100000000, 1000000], ([771600], 0.1))+  , ([100000000, 10000000], ([7670000], 0.1))+  ]++filterIsPrimeBenchModel :: [(Double, Double)]+filterIsPrimeBenchModel = sol+  where+    model [d] [from, len] = [len * d]+    modelDer [d] [from, len] = [[len]]+    (sol, _) = fitModelScaled 1E-10 1E-10 20 (model, modelDer) filterIsPrimeBenchData [1]++filterIsPrimeBenchApprox :: ([Double], ([Double], Double)) -> [Double]+filterIsPrimeBenchApprox ([from, len], ([exact], _)) = [from, len, exact, fromInteger (floor (appr / exact * 1000)) / 1000]+  where+    [(d, _)] = filterIsPrimeBenchModel+    appr = len * d++-- | Benchmarks Sequence/eratosthenes+-- ([start, length], ([time in microseconds], weight))+eratosthenesData :: [([Double], ([Double], Double))]+eratosthenesData =+  [ ([10000000000,1000000], ([21490], 0.1))+  , ([10000000000,10000000], ([103200], 0.1))+  , ([10000000000,100000000], ([956800], 0.1))+  , ([10000000000,1000000000], ([9473000], 0.1))+  , ([100000000000,10000000], ([107000], 0.1))+  , ([1000000000000,10000000], ([129900], 0.1))+  , ([10000000000000,10000000], ([202900], 0.1))+  , ([100000000000000,10000000], ([420400], 0.1))+  , ([1000000000000000,10000000], ([1048000], 0.1))+  , ([10000000000000000,10000000], ([2940000], 0.1))+  , ([100000000000000000,10000000], ([8763000], 0.1))+  ]++eratosthenesModel :: [(Double, Double)]+eratosthenesModel = sol+  where+    model [a, b, c] [from, len] = [a * len + b * sqrt from + c]+    modelDer [a, b, c] [from, len] = [[len, sqrt from, 1]]+    (sol, _) = fitModelScaled 1E-10 1E-10 20 (model, modelDer) eratosthenesData [1,0,0]++eratosthenesApprox :: ([Double], ([Double], Double)) -> [Double]+eratosthenesApprox ([from, len], ([exact], _)) = [from, len, exact, fromInteger (floor (appr / exact * 1000)) / 1000]+  where+    [(a, _), (b, _), (c, _)] = eratosthenesModel+    appr = a * len + b * sqrt from + c++coeffs :: (Double, Double)+coeffs = (b / (d - a), c / (d - a))+  where+    [(a, _), (b, _), (c, _)] = eratosthenesModel+    [(d, _)] = filterIsPrimeBenchModel++main :: IO ()+main = do+  print filterIsPrimeBenchModel+  mapM_ (print . filterIsPrimeBenchApprox) filterIsPrimeBenchData+  print eratosthenesModel+  mapM_ (print . eratosthenesApprox) eratosthenesData+  print coeffs
arithmoi.cabal view
@@ -1,177 +1,220 @@-name                : arithmoi-version             : 0.6.0.1-cabal-version       : >= 1.10-author              : Daniel Fischer-copyright           : (c) 2011 Daniel Fischer, 2016-2017 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-    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.Standard-                          Math.NumberTheory.Curves.Montgomery-                          Math.NumberTheory.Moduli-                          Math.NumberTheory.Moduli.Chinese-                          Math.NumberTheory.Moduli.Class-                          Math.NumberTheory.Moduli.Jacobi-                          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.Integer-                          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-                          GHC.TypeNats.Compat-    other-modules       : Math.NumberTheory.Utils-                          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-    other-extensions          : BangPatterns--    ghc-options         : -O2 -Wall-    ghc-prof-options    : -O2 -auto-    if flag(check-bounds)-        cpp-options     : -DCheckBounds+name:          arithmoi+version:       0.13.4.0+cabal-version: 2.0+build-type:    Simple+license:       MIT+license-file:  LICENSE+copyright:     (c) 2016-2021 Andrew Lelechenko, 2016-2019 Carter Schonwald, 2011 Daniel Fischer+maintainer:    Andrew Lelechenko <andrew.lelechenko@gmail.com>+homepage:      https://github.com/Bodigrim/arithmoi+bug-reports:   https://github.com/Bodigrim/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:        Andrew Lelechenko, Daniel Fischer+tested-with:   GHC ==9.0.2 GHC ==9.2.8 GHC ==9.4.8 GHC ==9.6.7 GHC ==9.8.4 GHC ==9.10.2 GHC ==9.12.2 GHC ==9.14.1+extra-doc-files:+  changelog.md+  Math/NumberTheory/Primes/Counting/HowPrimeCountingWorks.md  source-repository head-  type:     git-  location: https://github.com/cartazio/arithmoi+  type: git+  location: https://github.com/Bodigrim/arithmoi +library+  build-depends:+    base >=4.15 && <5,+    array >=0.5.4.0 && <0.6,+    bitvec >=1.1 && <1.2,+    containers >=0.5.11 && <0.9,+    chimera >=0.3 && <0.5,+    constraints <0.15,+    deepseq <1.6,+    exact-pi >=0.5 && <0.6,+    ghc-bignum <1.5,+    infinite-list <0.2,+    integer-logarithms >=1.0 && <1.1,+    integer-roots >= 1.0.4.0 && <1.1,+    mod >=0.2.1 && <0.3,+    random >=1.0 && <1.4,+    transformers >=0.4 && <0.7,+    semirings >=0.5.2 && <0.8,+    vector >=0.12 && <0.14+  exposed-modules:+    Math.NumberTheory.ArithmeticFunctions+    Math.NumberTheory.ArithmeticFunctions.Inverse+    Math.NumberTheory.ArithmeticFunctions.Mertens+    Math.NumberTheory.ArithmeticFunctions.NFreedom+    Math.NumberTheory.ArithmeticFunctions.Moebius+    Math.NumberTheory.ArithmeticFunctions.SieveBlock+    Math.NumberTheory.Curves.Montgomery+    Math.NumberTheory.Diophantine+    Math.NumberTheory.DirichletCharacters+    Math.NumberTheory.Euclidean.Coprimes+    Math.NumberTheory.Moduli+    Math.NumberTheory.Moduli.Chinese+    Math.NumberTheory.Moduli.Class+    Math.NumberTheory.Moduli.Cbrt+    Math.NumberTheory.Moduli.Equations+    Math.NumberTheory.Moduli.Multiplicative+    Math.NumberTheory.Moduli.Singleton+    Math.NumberTheory.Moduli.Sqrt+    Math.NumberTheory.MoebiusInversion+    Math.NumberTheory.Prefactored+    Math.NumberTheory.Primes+    Math.NumberTheory.Primes.Counting+    Math.NumberTheory.Primes.IntSet+    Math.NumberTheory.Primes.Testing+    Math.NumberTheory.Quadratic.GaussianIntegers+    Math.NumberTheory.Quadratic.EisensteinIntegers+    Math.NumberTheory.Recurrences+    Math.NumberTheory.Recurrences.Bilinear+    Math.NumberTheory.Recurrences.Linear+    Math.NumberTheory.SmoothNumbers+    Math.NumberTheory.Zeta+  other-modules:+    Math.NumberTheory.ArithmeticFunctions.Class+    Math.NumberTheory.ArithmeticFunctions.Standard+    Math.NumberTheory.Moduli.Internal+    Math.NumberTheory.Moduli.JacobiSymbol+    Math.NumberTheory.Moduli.SomeMod+    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.Small+    Math.NumberTheory.Primes.Testing.Certified+    Math.NumberTheory.Primes.Testing.Probabilistic+    Math.NumberTheory.Primes.Types+    Math.NumberTheory.Recurrences.Pentagonal+    Math.NumberTheory.RootsOfUnity+    Math.NumberTheory.Utils+    Math.NumberTheory.Utils.DirichletSeries+    Math.NumberTheory.Utils.FromIntegral+    Math.NumberTheory.Utils.Hyperbola+    Math.NumberTheory.Zeta.Dirichlet+    Math.NumberTheory.Zeta.Hurwitz+    Math.NumberTheory.Zeta.Riemann+    Math.NumberTheory.Zeta.Utils+  default-language: Haskell2010+  ghc-options: -Wall -Widentities -Wcompat -Wno-deprecations -benchmark criterion-  build-depends:    base-                    , arithmoi-                    , criterion-                    , containers-                    , random-                    , integer-logarithms-  if impl(ghc < 7.10)-    build-depends     : nats >= 1 && <1.2-  other-modules:    Math.NumberTheory.ArithmeticFunctionsBench-                  , Math.NumberTheory.PowersBench-                  , Math.NumberTheory.PrimesBench-                  , Math.NumberTheory.RecurrenciesBench-  hs-source-dirs:   benchmark-  main-is:          Bench.hs-  type:             exitcode-stdio-1.0+test-suite arithmoi-tests+  build-depends:+    base >=4.10 && <5,+    arithmoi,+    containers,+    exact-pi >=0.4.1.1,+    infinite-list,+    integer-roots >=1.0,+    mod,+    QuickCheck >=2.10 && <2.19,+    quickcheck-classes >=0.6.3 && <0.7,+    semirings >=0.2,+    smallcheck >=1.2 && <1.3,+    tasty >=0.10 && <1.6,+    tasty-hunit >=0.9 && <0.11,+    tasty-quickcheck >=0.9 && <0.12,+    tasty-rerun >=1.1.17 && <1.2,+    tasty-smallcheck >=0.8 && <0.9,+    vector+  other-modules:+    Math.NumberTheory.ArithmeticFunctionsTests+    Math.NumberTheory.ArithmeticFunctions.InverseTests+    Math.NumberTheory.ArithmeticFunctions.MertensTests+    Math.NumberTheory.ArithmeticFunctions.SieveBlockTests+    Math.NumberTheory.CurvesTests+    Math.NumberTheory.DiophantineTests+    Math.NumberTheory.DirichletCharactersTests+    Math.NumberTheory.EisensteinIntegersTests+    Math.NumberTheory.GaussianIntegersTests+    Math.NumberTheory.EuclideanTests+    Math.NumberTheory.Moduli.ChineseTests+    Math.NumberTheory.Moduli.DiscreteLogarithmTests+    Math.NumberTheory.Moduli.ClassTests+    Math.NumberTheory.Moduli.CbrtTests+    Math.NumberTheory.Moduli.EquationsTests+    Math.NumberTheory.Moduli.JacobiTests+    Math.NumberTheory.Moduli.PrimitiveRootTests+    Math.NumberTheory.Moduli.SingletonTests+    Math.NumberTheory.Moduli.SqrtTests+    Math.NumberTheory.MoebiusInversionTests+    Math.NumberTheory.PrefactoredTests+    Math.NumberTheory.Primes.CountingTests+    Math.NumberTheory.Primes.FactorisationTests+    -- Math.NumberTheory.Primes.LinearAlgebraTests+    -- Math.NumberTheory.Primes.QuadraticSieveTests+    Math.NumberTheory.Primes.SequenceTests+    Math.NumberTheory.Primes.SieveTests+    Math.NumberTheory.Primes.TestingTests+    Math.NumberTheory.PrimesTests+    Math.NumberTheory.Recurrences.PentagonalTests+    Math.NumberTheory.Recurrences.BilinearTests+    Math.NumberTheory.Recurrences.LinearTests+    Math.NumberTheory.RootsOfUnityTests+    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+  hs-source-dirs: test-suite+  ghc-options: -Wall -Widentities -Wcompat -threaded -test-suite spec-  type:                 exitcode-stdio-1.0-  hs-source-dirs:       test-suite-  ghc-options:          -Wall-  main-is:              Test.hs+benchmark arithmoi-bench+  build-depends:+    base,+    arithmoi,+    constraints,+    containers,+    infinite-list,+    integer-logarithms,+    mod,+    random,+    semirings,+    tasty-bench >= 0.4 && < 0.6,+    vector+  other-modules:+    Math.NumberTheory.ArithmeticFunctionsBench+    Math.NumberTheory.DiscreteLogarithmBench+    Math.NumberTheory.EisensteinIntegersBench+    Math.NumberTheory.GaussianIntegersBench+    Math.NumberTheory.InverseBench+    Math.NumberTheory.JacobiBench+    Math.NumberTheory.MertensBench+    Math.NumberTheory.PrimesBench+    Math.NumberTheory.PrimitiveRootsBench+    Math.NumberTheory.RecurrencesBench+    Math.NumberTheory.SequenceBench+    Math.NumberTheory.SieveBlockBench+    Math.NumberTheory.SmoothNumbersBench+    Math.NumberTheory.ZetaBench+  type: exitcode-stdio-1.0+  main-is: Bench.hs   default-language: Haskell2010-  build-depends:        arithmoi-                      , base >= 4.6 && < 5-                      , containers >= 0.5 && < 0.6-                      , tasty >= 0.10 && < 0.12-                      , tasty-smallcheck >= 0.8 && < 0.9-                      , tasty-quickcheck >= 0.9 && < 0.10-                      , tasty-hunit >= 0.9 && < 0.10-                      , QuickCheck >= 2.10 && < 2.11-                      , transformers >= 0.5-                      , integer-gmp < 1.1-  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: benchmark+  ghc-options: -Wall -Widentities -Wcompat -  other-modules :   Math.NumberTheory.ArithmeticFunctionsTests-                  , 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.SqrtTests-                  , Math.NumberTheory.Powers.CubesTests-                  , Math.NumberTheory.MoebiusInversionTests-                  , Math.NumberTheory.MoebiusInversion.IntTests-                  , Math.NumberTheory.Powers.FourthTests-                  , Math.NumberTheory.Powers.GeneralTests-                  , Math.NumberTheory.Powers.SquaresTests-                  , Math.NumberTheory.PrimesTests-                  , Math.NumberTheory.Primes.CountingTests-                  , Math.NumberTheory.Primes.FactorisationTests-                  , Math.NumberTheory.Primes.HeapTests-                  , 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 arithmoi-sequence-model+  build-depends:+    base,+    arithmoi,+    containers,+    hmatrix-gsl+  buildable: False+  type: exitcode-stdio-1.0+  main-is: SequenceModel.hs+  default-language: Haskell2010+  hs-source-dirs: app+  ghc-options: -Wall -Widentities -Wcompat
benchmark/Bench.hs view
@@ -1,15 +1,36 @@ module Main where -import Criterion.Main+import Test.Tasty.Bench  import Math.NumberTheory.ArithmeticFunctionsBench as ArithmeticFunctions-import Math.NumberTheory.PowersBench as Powers+import Math.NumberTheory.DiscreteLogarithmBench as DiscreteLogarithm+import Math.NumberTheory.EisensteinIntegersBench as Eisenstein+import Math.NumberTheory.GaussianIntegersBench as Gaussian+import Math.NumberTheory.InverseBench as Inverse+import Math.NumberTheory.JacobiBench as Jacobi+import Math.NumberTheory.MertensBench as Mertens import Math.NumberTheory.PrimesBench as Primes-import Math.NumberTheory.RecurrenciesBench as Recurrencies+import Math.NumberTheory.PrimitiveRootsBench as PrimitiveRoots+import Math.NumberTheory.RecurrencesBench as Recurrences+import Math.NumberTheory.SequenceBench as Sequence+import Math.NumberTheory.SieveBlockBench as SieveBlock+import Math.NumberTheory.SmoothNumbersBench as SmoothNumbers+import Math.NumberTheory.ZetaBench as Zeta +main :: IO () main = defaultMain   [ ArithmeticFunctions.benchSuite-  , Powers.benchSuite+  , DiscreteLogarithm.benchSuite+  , Eisenstein.benchSuite+  , Gaussian.benchSuite+  , Inverse.benchSuite+  , Jacobi.benchSuite+  , Mertens.benchSuite   , Primes.benchSuite-  , Recurrencies.benchSuite+  , PrimitiveRoots.benchSuite+  , Recurrences.benchSuite+  , Sequence.benchSuite+  , SieveBlock.benchSuite+  , SmoothNumbers.benchSuite+  , Zeta.benchSuite   ]
benchmark/Math/NumberTheory/ArithmeticFunctionsBench.hs view
@@ -1,25 +1,31 @@+{-# OPTIONS_GHC -fno-warn-type-defaults #-}+ module Math.NumberTheory.ArithmeticFunctionsBench   ( benchSuite   ) where -import Criterion.Main+import Test.Tasty.Bench import Data.Set (Set)  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.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]   ]
+ benchmark/Math/NumberTheory/DiscreteLogarithmBench.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE RankNTypes                #-}+{-# LANGUAGE ScopedTypeVariables       #-}+{-# LANGUAGE TypeApplications          #-}++{-# OPTIONS_GHC -fno-warn-type-defaults #-}++module Math.NumberTheory.DiscreteLogarithmBench+  ( benchSuite+  , rangeCases+  , discreteLogarithm'+  ) where++import Test.Tasty.Bench+import Control.Monad+import Data.Maybe+import Data.Mod+import GHC.TypeNats (KnownNat, SomeNat(..), someNatVal)+import Data.Proxy+import Numeric.Natural++import Math.NumberTheory.Moduli.Multiplicative+import Math.NumberTheory.Moduli.Singleton++data Case = forall m. KnownNat m => Case (PrimitiveRoot m) (MultMod m) String++instance Show Case where+  show (Case a b s) = concat [show (unMod a'), "ⁿ == ", show b', " mod ", s]+    where a' = multElement $ unPrimitiveRoot a+          b' = unMod $ multElement b++makeCase :: (Integer, Integer, Natural, String) -> Maybe Case+makeCase (a,b,n,s) =+  case someNatVal n of+    SomeNat (_ :: Proxy m) ->+      Case <$> join (isPrimitiveRoot @Integer <$> cyclicGroup <*> pure 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..]+  case someNatVal n of+    SomeNat (_ :: Proxy m) -> case cyclicGroup :: Maybe (CyclicGroup Integer m) of+      Nothing -> []+      Just cg -> do+        a <- take 1 $ mapMaybe (isPrimitiveRoot cg) [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 (fromJust cyclicGroup) 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)]+          ]+  ]
+ benchmark/Math/NumberTheory/EisensteinIntegersBench.hs view
@@ -0,0 +1,25 @@+{-# OPTIONS_GHC -fno-warn-type-defaults #-}+{-# OPTIONS_GHC -fno-warn-orphans       #-}++module Math.NumberTheory.EisensteinIntegersBench+  ( benchSuite+  ) where++import Data.Maybe+import Test.Tasty.Bench++import Math.NumberTheory.ArithmeticFunctions (tau)+import Math.NumberTheory.Primes (isPrime)+import Math.NumberTheory.Quadratic.EisensteinIntegers++benchFindPrime :: Integer -> Benchmark+benchFindPrime n = bench (show n) $ nf findPrime (fromJust (isPrime 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]+  ]
+ benchmark/Math/NumberTheory/GaussianIntegersBench.hs view
@@ -0,0 +1,24 @@+{-# OPTIONS_GHC -fno-warn-type-defaults #-}++module Math.NumberTheory.GaussianIntegersBench+  ( benchSuite+  ) where++import Data.Maybe+import Test.Tasty.Bench++import Math.NumberTheory.ArithmeticFunctions (tau)+import Math.NumberTheory.Primes (isPrime)+import Math.NumberTheory.Quadratic.GaussianIntegers++benchFindPrime :: Integer -> Benchmark+benchFindPrime n = bench (show n) $ nf findPrime (fromJust (isPrime 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]+  ]
+ benchmark/Math/NumberTheory/InverseBench.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE TypeApplications      #-}++{-# OPTIONS_GHC -fno-warn-type-defaults #-}++module Math.NumberTheory.InverseBench+  ( benchSuite+  ) where++import Test.Tasty.Bench+import Data.Bits (Bits)+import Data.Euclidean+import Numeric.Natural++import Math.NumberTheory.ArithmeticFunctions.Inverse+import Math.NumberTheory.Primes++fact :: (Enum a, Num a) => a+fact = product [1..13]++tens :: Num a => a+tens = 10 ^ 18++countInverseTotient :: (Ord a, Integral a, Euclidean a, UniqueFactorisation a) => a -> Word+countInverseTotient = inverseTotient (const 1)++countInverseSigma :: (Integral a, Euclidean a, UniqueFactorisation a, Enum (Prime a), Bits a) => a -> Word+countInverseSigma = inverseSigma (const 1)++benchSuite :: Benchmark+benchSuite = bgroup "Inverse"+  [ bgroup "Totient"+    [ bgroup "factorial"+      [ bench "Int"     $ nf (countInverseTotient @Int)     fact+      , bench "Word"    $ nf (countInverseTotient @Word)    fact+      , bench "Integer" $ nf (countInverseTotient @Integer) fact+      , bench "Natural" $ nf (countInverseTotient @Natural) fact+      ]+    , bgroup "power of 10"+      [ bench "Int"     $ nf (countInverseTotient @Int)     tens+      , bench "Word"    $ nf (countInverseTotient @Word)    tens+      , bench "Integer" $ nf (countInverseTotient @Integer) tens+      , bench "Natural" $ nf (countInverseTotient @Natural) tens+      ]+    ]+  , bgroup "Sigma1"+    [ bgroup "factorial"+      [ bench "Int"     $ nf (countInverseSigma @Int)     fact+      , bench "Word"    $ nf (countInverseSigma @Word)    fact+      , bench "Integer" $ nf (countInverseSigma @Integer) fact+      , bench "Natural" $ nf (countInverseSigma @Natural) fact+      ]+    , bgroup "power of 10"+      [ bench "Int"     $ nf (countInverseSigma @Int)     tens+      , bench "Word"    $ nf (countInverseSigma @Word)    tens+      , bench "Integer" $ nf (countInverseSigma @Integer) tens+      , bench "Natural" $ nf (countInverseSigma @Natural) tens+      ]+    ]+  ]
+ benchmark/Math/NumberTheory/JacobiBench.hs view
@@ -0,0 +1,21 @@+{-# OPTIONS_GHC -fno-warn-type-defaults #-}++module Math.NumberTheory.JacobiBench+  ( benchSuite+  ) where++import Test.Tasty.Bench+import Numeric.Natural++import Math.NumberTheory.Moduli.Sqrt++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+  ]
+ benchmark/Math/NumberTheory/MertensBench.hs view
@@ -0,0 +1,15 @@+{-# OPTIONS_GHC -fno-warn-type-defaults #-}++module Math.NumberTheory.MertensBench+  ( benchSuite+  ) where++import Test.Tasty.Bench++import Math.NumberTheory.ArithmeticFunctions.Mertens++mertensBench :: Word -> Benchmark+mertensBench n = bench (show n) (nf mertens n)++benchSuite :: Benchmark+benchSuite = bgroup "Mertens" $ map mertensBench $ take 4 $ iterate (* 10) 10000000
− benchmark/Math/NumberTheory/PowersBench.hs 
@@ -1,28 +0,0 @@-module Math.NumberTheory.PowersBench-  ( benchSuite-  ) where--import Criterion.Main-import System.Random--import Math.NumberTheory.Logarithms (integerLog2)-import Math.NumberTheory.Powers.Squares.Internal--genInteger :: Int -> Int -> Integer-genInteger salt bits-    = head-    . dropWhile ((< bits) . integerLog2)-    . scanl (\a r -> a * 2^31 + abs r) 1-    . randoms-    . mkStdGen-    $ salt + bits--compareRoots :: Int -> Benchmark-compareRoots bits = bgroup ("sqrt" ++ show bits)-  [ bench "new" $ nf (fst . karatsubaSqrt) n-  , bench "old" $ nf isqrtA n-  ]-  where-    n = genInteger 0 bits--benchSuite = bgroup "Powers" $ map compareRoots [2300, 2400 .. 2600]
benchmark/Math/NumberTheory/PrimesBench.hs view
@@ -1,14 +1,17 @@-{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}+{-# OPTIONS_GHC -Wno-type-defaults #-}+{-# OPTIONS_GHC -Wno-x-partial #-}+{-# OPTIONS_GHC -Wno-unrecognised-warning-flags #-}  module Math.NumberTheory.PrimesBench   ( benchSuite   ) where -import Criterion.Main+import Test.Tasty.Bench import System.Random  import Math.NumberTheory.Logarithms (integerLog2)-import Math.NumberTheory.Primes+import Math.NumberTheory.Primes (factorise)+import Math.NumberTheory.Primes.Testing  genInteger :: Int -> Int -> Integer genInteger salt bits
+ benchmark/Math/NumberTheory/PrimitiveRootsBench.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE RankNTypes #-}++{-# OPTIONS_GHC -fno-warn-type-defaults #-}++module Math.NumberTheory.PrimitiveRootsBench+  ( benchSuite+  ) where++import Test.Tasty.Bench+import Data.Constraint+import Data.Maybe++import Math.NumberTheory.Moduli.Multiplicative+import Math.NumberTheory.Moduli.Singleton+import Math.NumberTheory.Primes++primRootWrap :: Integer -> Word -> Integer -> Bool+primRootWrap p k g = case fromJust $ cyclicGroupFromFactors [(p', k)] of+  Some cg -> case proofFromCyclicGroup cg of+    Sub Dict -> isJust $ isPrimitiveRoot cg (fromInteger g)+  where+    p' = fromJust $ isPrime p++primRootWrap2 :: Integer -> Word -> Integer -> Bool+primRootWrap2 p k g = case fromJust $ cyclicGroupFromFactors [(two, 1), (p', k)] of+  Some cg -> case proofFromCyclicGroup cg of+    Sub Dict -> isJust $ isPrimitiveRoot cg (fromInteger g)+  where+    two = fromJust $ isPrime 2+    p'  = fromJust $ isPrime p++cyclicWrap :: Integer -> Maybe (Some (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+    ]+  ]
+ benchmark/Math/NumberTheory/RecurrencesBench.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE RankNTypes #-}++module Math.NumberTheory.RecurrencesBench+  ( benchSuite+  ) where++import Test.Tasty.Bench++import Data.Euclidean (GcdDomain)+import Data.List.Infinite (Infinite(..))+import qualified Data.List.Infinite as Inf+import Math.NumberTheory.Recurrences++benchTriangle :: String -> (forall a. (GcdDomain a, Integral a) => Infinite [a]) -> Word -> Benchmark+benchTriangle name triangle n = bgroup name+  [ benchAt (10 * n)  (1 * fromIntegral n)+  , benchAt (10 * n)  (2 * fromIntegral n)+  , benchAt (10 * n)  (5 * fromIntegral n)+  , benchAt (10 * n)  (9 * fromIntegral n)+  ]+  where+    benchAt i j = bench ("!! " ++ show i ++ " !! " ++ show j)+                $ nf (\(x, y) -> triangle Inf.!! x !! y :: Integer) (i, j)++benchPartition :: Word -> Benchmark+benchPartition n = bgroup "partition"+  [ benchAt n+  , benchAt (n * 10)+  , benchAt (n * 100)+  ]+  where+    benchAt m = bench ("!!" ++ show m) $  nf (\k -> partition Inf.!! k :: Integer) m++benchSuite :: Benchmark+benchSuite = bgroup "Recurrences"+  [ bgroup "Bilinear"+    [ benchTriangle "binomial"  binomial  80+    , benchTriangle "stirling1" stirling1 75+    , benchTriangle "stirling2" stirling2 75+    , benchTriangle "eulerian1" eulerian1 50+    , benchTriangle "eulerian2" eulerian2 50+    ]+  , benchPartition 1000+  , bgroup "factorialFactors"+    [ bench "10000" $ nf factorialFactors 10000+    , bench "20000" $ nf factorialFactors 20000+    , bench "40000" $ nf factorialFactors 40000+    ]+  ]
− benchmark/Math/NumberTheory/RecurrenciesBench.hs 
@@ -1,30 +0,0 @@-{-# LANGUAGE RankNTypes #-}--module Math.NumberTheory.RecurrenciesBench-  ( benchSuite-  ) where--import Criterion.Main-import Numeric.Natural-import System.Random--import Math.NumberTheory.Recurrencies.Bilinear--benchTriangle :: String -> (forall a. (Integral a) => [[a]]) -> Int -> Benchmark-benchTriangle name triangle n = bgroup name-  [ benchAt (10 * n)  (1 * n)-  , benchAt (10 * n)  (2 * n)-  , benchAt (10 * n)  (5 * n)-  , benchAt (10 * n)  (9 * n)-  ]-  where-    benchAt i j = bench ("!! " ++ show i ++ " !! " ++ show j)-                $ nf (\(x, y) -> triangle !! x !! y :: Integer) (i, j)--benchSuite = bgroup "Bilinear"-  [ benchTriangle "binomial"  binomial 1000-  , benchTriangle "stirling1" stirling1 100-  , benchTriangle "stirling2" stirling2 100-  , benchTriangle "eulerian1" eulerian1 100-  , benchTriangle "eulerian2" eulerian2 100-  ]
+ benchmark/Math/NumberTheory/SequenceBench.hs view
@@ -0,0 +1,62 @@+{-# OPTIONS_GHC -fno-warn-type-defaults #-}++module Math.NumberTheory.SequenceBench+  ( benchSuite+  ) where++import Test.Tasty.Bench++import Data.Bits+import qualified Data.Vector.Unboxed as U++import Math.NumberTheory.Primes (Prime(..), nextPrime, precPrime)+import Math.NumberTheory.Primes.Testing++filterIsPrime :: (Integer, Integer) -> Integer+filterIsPrime (p, q) = sum $ takeWhile (<= q) $ dropWhile (< p) $ filter isPrime (map toPrim [toIdx p .. toIdx q])++eratosthenes :: (Integer, Integer) -> Integer+eratosthenes (p, q) = sum (map unPrime [nextPrime p .. precPrime q])++filterIsPrimeBench :: Benchmark+filterIsPrimeBench = bgroup "filterIsPrime" $+  [ bench (show (10^x, 10^y)) $ nf filterIsPrime (10^x, 10^x + 10^y)+  | x <- [5..8]+  , y <- [3..x-1]+  ]++eratosthenesBench :: Benchmark+eratosthenesBench = bgroup "eratosthenes" $+  [ bench (show (10^x, 10^y)) $ nf eratosthenes (10^x, 10^x + 10^y)+  | x <- [10..17]+  , y <- [6..x-1]+  , x == 10 || y == 7+  ]++benchSuite :: Benchmark+benchSuite = bgroup "Sequence"+    [ filterIsPrimeBench+    , eratosthenesBench+    ]++-------------------------------------------------------------------------------+-- Utils copypasted from internal modules++rho :: Int -> Int+rho i = residues U.! i++residues :: U.Vector Int+residues = U.fromList [7,11,13,17,19,23,29,31]++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)++toPrim :: Integral a => Int -> a+toPrim ix = 30*fromIntegral k + fromIntegral (rho i)+  where+    i = ix .&. 7+    k = ix `shiftR` 3
+ benchmark/Math/NumberTheory/SieveBlockBench.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE LambdaCase #-}++{-# OPTIONS_GHC -fno-warn-type-defaults #-}++module Math.NumberTheory.SieveBlockBench+  ( benchSuite+  ) where++import Test.Tasty.Bench+import qualified Data.Vector as V+import qualified Data.Vector.Unboxed as U++import Math.NumberTheory.ArithmeticFunctions.Moebius+import Math.NumberTheory.ArithmeticFunctions.SieveBlock+import Math.NumberTheory.Primes++blockLen :: Word+blockLen = 1000000++totientHelper :: Word -> Word -> Word+totientHelper p 1 = p - 1+totientHelper p 2 = (p - 1) * p+totientHelper p k = (p - 1) * p ^ (k - 1)++totientBlockConfig :: SieveBlockConfig Word+totientBlockConfig = SieveBlockConfig+  { sbcEmpty                = 1+  , sbcAppend               = (*)+  , sbcFunctionOnPrimePower = totientHelper . unPrime+  }++carmichaelHelper :: Word -> Word -> Word+carmichaelHelper 2 1 = 1+carmichaelHelper 2 2 = 2+carmichaelHelper 2 k = 2 ^ (k - 2)+carmichaelHelper p 1 = p - 1+carmichaelHelper p 2 = (p - 1) * p+carmichaelHelper p k = (p - 1) * p ^ (k - 1)++carmichaelBlockConfig :: SieveBlockConfig Word+carmichaelBlockConfig = SieveBlockConfig+  { sbcEmpty                = 1+  -- There is a specialized 'gcd' for Word, but not 'lcm'.+  , sbcAppend               = \x y -> (x `quot` gcd x y) * y+  , sbcFunctionOnPrimePower = carmichaelHelper . unPrime+  }++moebiusConfig :: SieveBlockConfig Moebius+moebiusConfig = SieveBlockConfig+  { sbcEmpty                = MoebiusP+  , sbcAppend               = (<>)+  , sbcFunctionOnPrimePower = const $ \case+      0 -> MoebiusP+      1 -> MoebiusN+      _ -> MoebiusZ+  }++benchSuite :: Benchmark+benchSuite = bgroup "SieveBlock"+  [ bgroup "totient"+    [ bench "boxed"   $ nf (V.sum . sieveBlock        totientBlockConfig 1) blockLen+    , bench "unboxed" $ nf (U.sum . sieveBlockUnboxed totientBlockConfig 1) blockLen+    ]+  , bgroup "carmichael"+    [ bench "boxed"   $ nf (V.sum . sieveBlock        carmichaelBlockConfig 1) blockLen+    , bench "unboxed" $ nf (U.sum . sieveBlockUnboxed carmichaelBlockConfig 1) blockLen+    ]+  , bgroup "moebius"+    [ bench "boxed"   $ nf (V.sum . V.map runMoebius . sieveBlock        moebiusConfig 1 :: Word -> Int) blockLen+    , bench "unboxed" $ nf (U.sum . U.map runMoebius . sieveBlockUnboxed moebiusConfig 1 :: Word -> Int) blockLen+    , bench "special" $ nf (U.sum . U.map runMoebius . sieveBlockMoebius 1 :: Word -> Int) blockLen+    ]+  ]
+ benchmark/Math/NumberTheory/SmoothNumbersBench.hs view
@@ -0,0 +1,20 @@+{-# OPTIONS_GHC -fno-warn-type-defaults #-}++module Math.NumberTheory.SmoothNumbersBench+  ( benchSuite+  ) where++import Test.Tasty.Bench++import Math.NumberTheory.Primes+import Math.NumberTheory.SmoothNumbers++doBench :: Int -> Int+doBench lim = sum $ take lim $ smoothOver $ fromList $ map unPrime [nextPrime 2 .. precPrime lim]++benchSuite :: Benchmark+benchSuite = bgroup "SmoothNumbers"+  [ bench "100"      $ nf doBench   100+  , bench "1000"     $ nf doBench  1000+  , bench "10000"    $ nf doBench 10000+  ]
+ benchmark/Math/NumberTheory/ZetaBench.hs view
@@ -0,0 +1,16 @@+{-# OPTIONS_GHC -fno-warn-type-defaults #-}++module Math.NumberTheory.ZetaBench+  ( benchSuite+  ) where++import Test.Tasty.Bench++import qualified Data.List.Infinite as Inf+import Math.NumberTheory.Zeta++benchSuite :: Benchmark+benchSuite = bgroup "Zeta"+  [ bench "riemann zeta"   $ nf (sum . Inf.take 20 . zetas) (1e-15 :: Double)+  , bench "dirichlet beta" $ nf (sum . Inf.take 20 . betas) (1e-15 :: Double)+  ]
+ changelog.md view
@@ -0,0 +1,635 @@+# Changelog++## 0.13.4.0++### Fixed++* Fix `sieveBlockUnboxed` segfaulting when a block starts from 0.+* Fix typos.++### Added++* Add `ids` and `associates` to `Math.NumberTheory.Quadratic.GaussianIntegers`.++### Changed++* Define `liftA2` for `ArithmeticFunction` explicitly.++## 0.13.3.0++### Changed++* Changed primeCount implementation to something a little faster and better documented.+* Added a documentation file: "HowPrimeCountingWorks.md".+* Tweaked some benchmark settings to make them complete faster.++## 0.13.2.0++### Changed++* Migrate implementation of prime sieves from `Array Bool` to `Vector Bit`.++## 0.13.1.0++### Fixed++* Fix a grave bug in prime counting, lurking since `arithmoi-0.11.0.0`.++## 0.13.0.1++### Fixed++* Compatibility patches for `containers-0.8`.++## 0.13.0.0++### Changed++* Migrate functions under `Math.NumberTheory.Recurrences` and `Math.NumberTheory.Zeta`, which operate on infinite lists, to use `Infinite` from `infinite-list` package.+* Migrate functions under `Math.NumberTheory.Quadratic` to return an `Infinite` list of quadratic primes.++### Removed++* Remove deprecated `Math.NumberTheory.Powers.Modular`.++## 0.12.1.0++### Fixed++* Fix a grave bug in prime factorisation, lurking since `arithmoi-0.7.0.0`.++## 0.12.0.2++### Fixed++* Compatibility patches for GHC 9.4.++## 0.12.0.1++### Fixed++* Compatibility patches for GHC 9.2.++## 0.12.0.0++### Added++* Define cubic symbol ([#194](https://github.com/Bodigrim/arithmoi/pull/194)).+* Add `instance Unbox (Prime a)` and `toPrimeIntegral` helper ([#201](https://github.com/Bodigrim/arithmoi/pull/201)).+* Implement Cornacchia's algorithm for Diophantine equations ([#195](https://github.com/Bodigrim/arithmoi/pull/195)).+* Define a wrapper `PrimeIntSet` for sets of primes ([#205](https://github.com/Bodigrim/arithmoi/pull/205)).++### Deprecated++* Deprecate `Math.NumberTheory.Powers.Modular`, use `Data.Mod` or `Data.Mod.Word` instead.++### Removed++* Remove modules and functions, deprecated in the previous release.++## 0.11.0.1++### Changed++* Switch to `smallcheck-1.2.0`.++## 0.11.0.0++### Added++* Brand new machinery to deal with Dirichlet characters ([#180](https://github.com/Bodigrim/arithmoi/pull/180)).++* Generate preimages of the Jordan and the sum-of-powers-of-divisors+  functions ([#148](https://github.com/Bodigrim/arithmoi/pull/148)).++* More flexible interface for Pascal triangle: in addition to `binomial`+  we now provide also `binomialRotated`, `binomialLine` and `binomialDiagonal`+  ([#151](https://github.com/Bodigrim/arithmoi/pull/151)). There are also `factoriseFactorial` and `factoriseBinomial` ([#152](https://github.com/Bodigrim/arithmoi/pull/152)).++* Add `Semiring` instance of `SomeMod` ([#174](https://github.com/Bodigrim/arithmoi/pull/174)).++* Generate divisors in range ([#183](https://github.com/Bodigrim/arithmoi/pull/183)).++### Changed++* Speed up `partition`, using better container for memoization ([#176](https://github.com/Bodigrim/arithmoi/pull/176)).++* Speed up `integerRoot`, using better starting approximation ([#177](https://github.com/Bodigrim/arithmoi/pull/177)).++### Deprecated++* Deprecate `Math.NumberTheory.Euclidean`, use `Data.Euclidean` instead.++* Deprecate `chineseRemainder`, `chineseRemainder2`, `chineseCoprime`,+  use `chinese` instead. Deprecate `chineseCoprimeSomeMod`, use `chineseSomeMod`.++* Deprecate `Math.NumberTheory.Powers` except `Math.NumberTheory.Powers.Modular`.+  Use `Math.NumberTheory.Roots` instead.++* Deprecate `Math.NumberTheory.Moduli.Jacobi`, use `Math.NumberTheory.Moduli.Sqrt`+  instead.++* Deprecate `Math.NumberTheory.Moduli.{DiscreteLogarithm,PrimitiveRoot}`,+  use `Math.NumberTheory.Moduli.Multiplicative` instead.++### Removed++* Remove modules and functions, deprecated in the previous release.++### Fixed++* Fix subtraction of `SomeMod` ([#174](https://github.com/Bodigrim/arithmoi/pull/174)).++## 0.10.0.0++### Added++* The machinery of cyclic groups, primitive roots and discrete logarithms+  has been completely overhauled and rewritten using singleton types ([#169](https://github.com/Bodigrim/arithmoi/pull/169)).++  There is also a new singleton type, linking a type-level modulo with+  a term-level factorisation. It allows both to have a nicely-typed API+  of `Mod m` and avoid repeating factorisations ([#169](https://github.com/Bodigrim/arithmoi/pull/169)).++  Refer to a brand new module `Math.NumberTheory.Moduli.Singleton` for details.++* Add a new function `factorBack`.++* Add `Ord SomeMod` instance ([#165](https://github.com/Bodigrim/arithmoi/pull/165)).++* Add `Semiring` and `Ring` instances for Eisenstein and Gaussian integers.++### Changed++* Embrace the new `Semiring -> GcdDomain -> Euclidean` hierarchy+  of classes, refining `Num` and `Integral` constraints.++* Reshuffle exports from `Math.NumberTheory.Zeta`, do not advertise+  its submodules as available to import.++* Add a proxy argument storing vector's flavor to+  `Math.NumberTheory.MoebiusInversion.{generalInversion,totientSum}`.++* `solveQuadratic` and `sqrtsMod` require an additional argument: a singleton+  linking a type-level modulo with a term-level factorisation ([#169](https://github.com/Bodigrim/arithmoi/pull/169)).++* Generalize `sieveBlock` to handle any flavor of `Vector` ([#164](https://github.com/Bodigrim/arithmoi/pull/164)).++### Deprecated++* Deprecate `Math.NumberTheory.Primes.Factorisation`, use+  `Math.NumberTheory.Primes.factorise` instead. Deprecate+  `Math.NumberTheory.Primes.Sieve`, use `Enum` instance instead.++* Deprecate `Math.NumberTheory.Primes.Factorisation.Certified` and+  `Math.NumberTheory.Primes.Testing.Certificates`.++* Deprecate `Math.NumberTheory.MoebiusInversion.Int`.++* Deprecate `Math.NumberTheory.SmoothNumbers.{fromSet,fromSmoothUpperBound}`.+  Use `Math.NumberTheory.SmoothNumbers.fromList` instead.++* Deprecate `Math.NumberTheory.SmoothNumbers.smoothOverInRange` in favor+  of `smoothOver` and `Math.NumberTheory.SmoothNumbers.smoothOverInRange`+  in favor of `isSmooth`.++### Removed++* Move `Euclidean` type class to `semirings` package ([#168](https://github.com/Bodigrim/arithmoi/pull/168)).++* Remove deprecated earlier `Math.NumberTheory.Recurrencies.*`+  and `Math.NumberTheory.UniqueFactorisation` modules.+  Use `Math.NumberTheory.Recurrences.*` and `Math.NumberTheory.Primes`+  instead.++* Remove deprecated earlier an old interface of `Math.NumberTheory.Moduli.Sqrt`.++## 0.9.0.0++### Added++* Introduce `Prime` newtype. This newtype+  is now used extensively in public API:++  ```haskell+  primes :: Integral a => [Prime a]+  primeList :: Integral a => PrimeSieve -> [Prime a]+  sieveFrom :: Integer -> [Prime Integer]+  nthPrime :: Integer -> Prime Integer+  ```++* New functions `nextPrime` and `precPrime`. Implement an instance of `Enum` for primes ([#153](https://github.com/Bodigrim/arithmoi/pull/153)):++  ```haskell+  > [nextPrime 101 .. precPrime 130]+  [Prime 101,Prime 103,Prime 107,Prime 109,Prime 113,Prime 127]+  ```+* Add the Hurwitz zeta function on non-negative integer arguments ([#126](https://github.com/Bodigrim/arithmoi/pull/126)).++* Implement efficient tests of n-freeness: pointwise and in interval. See `isNFree` and `nFreesBlock` ([#145](https://github.com/Bodigrim/arithmoi/pull/145)).++* Generate preimages of the totient and the sum-of-divisors functions ([#142](https://github.com/Bodigrim/arithmoi/pull/142)):++  ```haskell+  > inverseTotient 120 :: [Integer]+  [155,310,183,366,225,450,175,350,231,462,143,286,244,372,396,308,248]+  ```++* Generate coefficients of Faulhaber polynomials `faulhaberPoly` ([#70](https://github.com/Bodigrim/arithmoi/pull/70)).++### Changed++* Support Gaussian and Eisenstein integers in smooth numbers ([#138](https://github.com/Bodigrim/arithmoi/pull/138)).++* Change types of `primes`, `primeList`, `sieveFrom`, `nthPrime`, etc.,+  to use `Prime` newtype.++* `Math.NumberTheory.Primes.{Factorisation,Testing,Counting,Sieve}`+  are no longer re-exported from `Math.NumberTheory.Primes`.+  Merge `Math.NumberTheory.UniqueFactorisation` into+  `Math.NumberTheory.Primes` ([#135](https://github.com/Bodigrim/arithmoi/pull/135), [#153](https://github.com/Bodigrim/arithmoi/pull/153)).++* From now on `Math.NumberTheory.Primes.Factorisation.factorise`+  and similar functions return `[(Integer, Word)]` instead of `[(Integer, Int)]`.++* `sbcFunctionOnPrimePower` now accepts `Prime Word` instead of `Word`.++* Better precision for exact values of Riemann zeta and Dirichlet beta+  functions ([#123](https://github.com/Bodigrim/arithmoi/pull/123)).++* Speed up certain cases of modular multiplication ([#160](https://github.com/Bodigrim/arithmoi/pull/160)).++* Extend Chinese theorem to non-coprime moduli ([#71](https://github.com/Bodigrim/arithmoi/pull/71)).++### Deprecated++* Deprecate `Math.NumberTheory.Recurrencies.*`.+  Use `Math.NumberTheory.Recurrences.*` instead ([#146](https://github.com/Bodigrim/arithmoi/pull/146)).++### Removed++* Remove `Prime` type family.++* Remove deprecated `Math.NumberTheory.GCD` and `Math.NumberTheory.GCD.LowLevel`.++## 0.8.0.0++### Added++* A new interface for `Math.NumberTheory.Moduli.Sqrt`, more robust and type safe ([#87](https://github.com/Bodigrim/arithmoi/pull/87), [#108](https://github.com/Bodigrim/arithmoi/pull/108)).++* Implement Ramanujan tau function ([#112](https://github.com/Bodigrim/arithmoi/pull/112)):++  ```haskell+  > map ramanujan [1..10]+  [1,-24,252,-1472,4830,-6048,-16744,84480,-113643,-115920]+  ```++* Implement partition function ([#115](https://github.com/Bodigrim/arithmoi/pull/115)):++  ```haskell+  > take 10 partition+  [1,1,2,3,5,7,11,15,22,30]+  ```++* Add the Dirichlet beta function on non-negative integer arguments ([#120](https://github.com/Bodigrim/arithmoi/pull/120)).+  E. g.,++  ```haskell+  > 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](https://github.com/Bodigrim/arithmoi/pull/129)).++* Support Eisenstein integers ([#121](https://github.com/Bodigrim/arithmoi/pull/121)).++* Implement discrete logarithm ([#88](https://github.com/Bodigrim/arithmoi/pull/88)).++### Changed++* Stop reporting units (1, -1, i, -i) as a part of factorisation+  for integers and Gaussian integers ([#101](https://github.com/Bodigrim/arithmoi/pull/101)). Now `factorise (-2)`+  is `[(2, 1)]` and not `[(-1, 1), (2, 1)]`.++* Move `splitIntoCoprimes` to `Math.NumberTheory.Euclidean.Coprimes`.++* Change types of `splitIntoCoprimes`, `fromFactors` and `prefFactors`+  using newtype `Coprimes` ([#89](https://github.com/Bodigrim/arithmoi/pull/89)).++* Sort Gaussian primes by norm ([#124](https://github.com/Bodigrim/arithmoi/pull/124)).++* Make return type of `primes` and `primeList` polymorphic instead of+  being limited to `Integer` only ([#109](https://github.com/Bodigrim/arithmoi/pull/109)).++* Speed up factorisation of Gaussian integers ([#116](https://github.com/Bodigrim/arithmoi/pull/116)).++* Speed up computation of primitive roots for prime powers ([#127](https://github.com/Bodigrim/arithmoi/pull/127)).++### Deprecated++* Deprecate an old interface of `Math.NumberTheory.Moduli.Sqrt`.++* Deprecate `Math.NumberTheory.GCD` and `Math.NumberTheory.GCD.LowLevel` ([#80](https://github.com/Bodigrim/arithmoi/pull/80)).+  Use `Math.NumberTheory.Euclidean` instead ([#128](https://github.com/Bodigrim/arithmoi/pull/128)).++* Deprecate `jacobi'` ([#103](https://github.com/Bodigrim/arithmoi/pull/103)).+++* Deprecate `Math.NumberTheory.GaussianIntegers` in favor of+  `Math.NumberTheory.Quadratic.GaussianIntegers`.++## 0.7.0.0++### Added++* A general framework for bulk evaluation of arithmetic functions ([#77](https://github.com/Bodigrim/arithmoi/pull/77)):++  ```haskell+  > runFunctionOverBlock carmichaelA 1 10+  [1,1,2,2,4,2,6,2,6,4]+  ```++* Implement a sublinear algorithm for Mertens function ([#90](https://github.com/Bodigrim/arithmoi/pull/90)):++  ```haskell+  > map (mertens . (10 ^)) [0..9]+  [1,-1,1,2,-23,-48,212,1037,1928,-222]+  ```++* Add basic support for cyclic groups and primitive roots ([#86](https://github.com/Bodigrim/arithmoi/pull/86)).++* Implement an efficient modular exponentiation ([#86](https://github.com/Bodigrim/arithmoi/pull/86)).++* Write routines for lazy generation of smooth numbers ([#91](https://github.com/Bodigrim/arithmoi/pull/91)).++  ```haskell+  > smoothOverInRange (fromJust (fromList [3,5,7])) 1000 2000+  [1029,1125,1215,1225,1323,1575,1701,1715,1875]+  ```++### Changed++* Now `moebius` returns not a number, but a value of `Moebius` type ([#90](https://github.com/Bodigrim/arithmoi/pull/90)).++* Now factorisation of large integers and Gaussian integers produces+  factors as lazy as possible ([#72](https://github.com/Bodigrim/arithmoi/pull/72), [#76](https://github.com/Bodigrim/arithmoi/pull/76)).++### Deprecated++* Deprecate `Math.NumberTheory.Primes.Heap`.+  Use `Math.NumberTheory.Primes.Sieve` instead.++* Deprecate `FactorSieve`, `TotientSieve`, `CarmichaelSieve` and+  accompanying functions. Use new general approach for bulk evaluation+  of arithmetic functions instead ([#77](https://github.com/Bodigrim/arithmoi/pull/77)).++### Removed++* Remove `Math.NumberTheory.Powers.Integer`, deprecated in 0.5.0.0.++## 0.6.0.1++### Changed++* Switch to `smallcheck-1.1.3`.++## 0.6.0.0++### Added++* Brand new `Math.NumberTheory.Moduli.Class` ([#56](https://github.com/Bodigrim/arithmoi/pull/56)), providing+  flexible and type safe modular arithmetic. Due to use of GMP built-ins+  it is also significantly faster.++* New function `divisorsList`, which is lazier than `divisors` and+  does not require `Ord` constraint ([#64](https://github.com/Bodigrim/arithmoi/pull/64)). Thus, it can be used+  for `GaussianInteger`.++### Changed++* `Math.NumberTheory.Moduli` was split into+  `Math.NumberTheory.Moduli.{Chinese,Class,Jacobi,Sqrt}`.++* Functions `jacobi` and `jacobi'` return `JacobiSymbol`+  instead of `Int`.++* Speed up factorisation over elliptic curve up to 15x ([#65](https://github.com/Bodigrim/arithmoi/pull/65)).++* Polymorphic `fibonacci` and `lucas` functions, which previously+  were restricted to `Integer` only ([#63](https://github.com/Bodigrim/arithmoi/pull/63)). This is especially useful+  for modular computations, e. g., `map fibonacci [1..10] :: [Mod 7]`.++* Make `totientSum` more robust and idiomatic ([#58](https://github.com/Bodigrim/arithmoi/pull/58)).++### Removed++* Functions `invertMod`, `powerMod` and `powerModInteger` were removed,+  as well as their unchecked counterparts. Use new interface to+  modular computations, provided by `Math.NumberTheory.Moduli.Class`.++## 0.5.0.1++### Changed++  Switch to `QuickCheck-2.10`.++## 0.5.0.0++### Added++* Add basic combinatorial sequences: binomial coefficients, Stirling+  numbers of both kinds, Eulerian numbers of both kinds, Bernoulli+  numbers ([#39](https://github.com/Bodigrim/arithmoi/pull/39)). E. g.,++  ```haskell+  > take 10 $ Math.NumberTheory.Recurrencies.Bilinear.bernoulli+  [1 % 1,(-1) % 2,1 % 6,0 % 1,(-1) % 30,0 % 1,1 % 42,0 % 1,(-1) % 30,0 % 1]+  ```++* Add the Riemann zeta function on non-negative integer arguments ([#44](https://github.com/Bodigrim/arithmoi/pull/44)).+  E. g.,++  ```haskell+  > take 5 $ Math.NumberTheory.Zeta.zetas 1e-15+  [-0.5,Infinity,1.6449340668482262,1.2020569031595945,1.0823232337111381]+  ```++### Changed++* Rename `Math.NumberTheory.Lucas` to `Math.NumberTheory.Recurrencies.Linear`.++* Speed up `isPrime` twice; rework `millerRabinV` and `isStrongFermatPP` ([#22](https://github.com/Bodigrim/arithmoi/pull/22), [#25](https://github.com/Bodigrim/arithmoi/pull/25)).++### Deprecated++* Deprecate `integerPower` and `integerWordPower` from+  `Math.NumberTheory.Powers.Integer`. Use `(^)` instead ([#51](https://github.com/Bodigrim/arithmoi/pull/51)).++### Removed++* Remove deprecated interface to arithmetic functions (`divisors`, `tau`,+  `sigma`, `totient`, `jordan`, `moebius`, `liouville`, `smallOmega`, `bigOmega`,+  `carmichael`, `expMangoldt`). New interface is exposed via+  `Math.NumberTheory.ArithmeticFunctions` ([#30](https://github.com/Bodigrim/arithmoi/pull/30)).++* `Math.NumberTheory.Logarithms` has been moved to the separate package+  `integer-logarithms` ([#51](https://github.com/Bodigrim/arithmoi/pull/51)).++## 0.4.3.0++### Added++* Add `Math.NumberTheory.ArithmeticFunctions` with brand-new machinery+  for arithmetic functions: `divisors`, `tau`, `sigma`, `totient`, `jordan`,+  `moebius`, `liouville`, `smallOmega`, `bigOmega`, `carmichael`, `expMangoldt` ([#30](https://github.com/Bodigrim/arithmoi/pull/30)).+  Old implementations (exposed via `Math.NumberTheory.Primes.Factorisation`+  and `Math.NumberTheory.Powers.Integer`) are deprecated and will be removed+  in the next major release.++* Add Karatsuba sqrt algorithm, improving performance on large integers ([#6](https://github.com/Bodigrim/arithmoi/pull/6)).++### Fixed++* Fix incorrect indexing of `FactorSieve` ([#35](https://github.com/Bodigrim/arithmoi/pull/35)).++## 0.4.2.0++### Added++* Add new cabal flag `check-bounds`, which replaces all unsafe array functions with safe ones.++* Add basic functions on Gaussian integers.++* Add Möbius mu-function.++### Changed++* Forbid non-positive moduli in `Math.NumberTheory.Moduli`.++### Fixed++* Fix out-of-bounds errors in `Math.NumberTheory.Primes.Heap`, `Math.NumberTheory.Primes.Sieve` and `Math.NumberTheory.MoebiusInversion`.++* Fix 32-bit build.++* Fix `binaryGCD` on negative numbers.++* Fix `highestPower` (various issues).++## 0.4.1.0++### Added++* Add `integerLog10` variants at Bas van Dijk's request and expose+  `Math.NumberTheory.Powers.Integer`, with an added `integerWordPower`.++## 0.4.0.4++### Fixed++* Update for GHC 7.8, the type of some primops changed, they return `Int#` now+  instead of `Bool`.++* Fixed bugs in modular square roots and factorisation.++## 0.4.0.3++### Changed++* Relaxed dependencies on mtl and containers.++### Fixed++* Fixed warnings from GHC 7.5, `Word(..)` moved to `GHC.Types`.++* Removed `SPECIALISE` pragma from inline function (warning from GHC 7.5, probably+  pointless anyway).++## 0.4.0.2++### Changed++* Sped up factor sieves. They need more space now, but the speedup is worth it, IMO.++* Raised spec-constr limit in `MoebiusInversion.Int`.++## 0.4.0.1++### Fixed++* Fixed Haddock bug.++## 0.4.0.0++### Added++* Added generalised Möbius inversion, to be continued.++## 0.3.0.0++### Added++* Added modular square roots and Chinese remainder theorem.++## 0.2.0.6++### Changed++* Performance tweaks for `powerModInteger` (~10%) and `invertMod` (~25%).++## 0.2.0.5++### Fixed++* Fix bug in `psieveFrom`.++## 0.2.0.4++### Fixed++* Fix bug in `nthPrime`.++## 0.2.0.3++### Fixed++* Fix bug in `powerMod`.++## 0.2.0.2++### Changed++* Relax bounds on `array` dependency for GHC 7.4.++## 0.2.0.1++### Fixed++* Fix copy-pasto (only relevant for GHC 7.3).++* Fix imports for GHC 7.3.++## 0.2.0.0++### Added++* Added certificates and certified testing/factorisation++## 0.1.0.2++### Fixed++* Fixed doc bugs++## 0.1.0.1++### Changed++* Elaborate on overflow, work more on native `Ints` in Eratosthenes.++## 0.1.0.0++### Added++* First release.
+ test-suite/Math/NumberTheory/ArithmeticFunctions/InverseTests.hs view
@@ -0,0 +1,414 @@+-- |+-- Module:      Math.NumberTheory.ArithmeticFunctions.InverseTests+-- Copyright:   (c) 2018 Andrew Lelechenko+-- Licence:     MIT+-- Maintainer:  Andrew Lelechenko <andrew.lelechenko@gmail.com>+-- Stability:   Provisional+--+-- Tests for Math.NumberTheory.ArithmeticFunctions.Inverse+--++{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE RankNTypes            #-}+{-# LANGUAGE ScopedTypeVariables   #-}++{-# OPTIONS_GHC -fconstraint-solver-iterations=0 #-}++{-# OPTIONS_GHC -fno-warn-type-defaults #-}++module Math.NumberTheory.ArithmeticFunctions.InverseTests+  ( testSuite+  ) where++import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.SmallCheck as SC hiding (test)+import Test.Tasty.QuickCheck as QC hiding (Positive)++import Data.Bits (Bits)+import Data.Euclidean+import qualified Data.List.Infinite as Inf+import Data.Semiring (Semiring)+import qualified Data.Set as S+import Numeric.Natural (Natural)++import Math.NumberTheory.ArithmeticFunctions+import Math.NumberTheory.ArithmeticFunctions.Inverse+import Math.NumberTheory.Primes+import Math.NumberTheory.Recurrences+import Math.NumberTheory.TestUtils++-------------------------------------------------------------------------------+-- Totient++totientProperty1 :: forall a. (Euclidean a, Integral a, UniqueFactorisation a) => Positive a -> Bool+totientProperty1 (Positive x) = x `S.member` asSetOfPreimages inverseTotient (totient x)++jordanProperty1+  :: (Euclidean a, Integral a, UniqueFactorisation a)+  => Power Word+  -> Positive a+  -> Bool+jordanProperty1 (Power k') (Positive x) =+  -- 'k' shouldn't be large to avoid slow tests.+  let k = 2 + k' `Prelude.mod` 20+  in x `S.member` asSetOfPreimages (inverseJordan k) (jordan k x)++totientProperty2 :: (Euclidean a, Integral a, UniqueFactorisation a) => Positive a -> Bool+totientProperty2 (Positive x) = all (== x) (S.map totient (asSetOfPreimages inverseTotient x))++jordanProperty2+  :: (Euclidean a, Integral a, UniqueFactorisation a, Ord a)+  => Power Word+  -> Positive a+  -> Bool+jordanProperty2 (Power k') (Positive x) =+  let k = 2 + k' `Prelude.mod` 20+  in all (== x) (S.map (jordan k) (asSetOfPreimages (inverseJordan k) x))++-- | http://oeis.org/A055506+totientCountFactorial :: [Word]+totientCountFactorial =+  [ 2+  , 3+  , 4+  , 10+  , 17+  , 49+  , 93+  , 359+  , 1138+  , 3802+  , 12124+  , 52844+  , 182752+  , 696647+  , 2852886+  , 16423633+  , 75301815+  , 367900714+  ]++totientSpecialCases1 :: [Assertion]+totientSpecialCases1 = zipWith mkAssert (drop 1 (Inf.toList factorial)) totientCountFactorial+  where+    mkAssert n m = assertEqual "should be equal" m (totientCount n)++    totientCount :: Word -> Word+    totientCount = inverseTotient (const 1)++-- | http://oeis.org/A055487+totientMinFactorial :: [Word]+totientMinFactorial =+  [ 1+  , 3+  , 7+  , 35+  , 143+  , 779+  , 5183+  , 40723+  , 364087+  , 3632617+  , 39916801+  , 479045521+  , 6227180929+  , 87178882081+  , 1307676655073+  , 20922799053799+  , 355687465815361+  , 6402373865831809+  ]++totientSpecialCases2 :: [Assertion]+totientSpecialCases2 = zipWith mkAssert (drop 1 (Inf.toList factorial)) totientMinFactorial+  where+    mkAssert n m = assertEqual "should be equal" m (totientMin n)++    totientMin :: Word -> Word+    totientMin = unMinWord . inverseTotient MinWord++-- | http://oeis.org/A165774+totientMaxFactorial :: [Word]+totientMaxFactorial =+  [ 2+  , 6+  , 18+  , 90+  , 462+  , 3150+  , 22050+  , 210210+  , 1891890+  , 19969950+  , 219669450+  , 2847714870+  , 37020293310+  , 520843112790+  , 7959363061650+  , 135309172048050+  , 2300255924816850+  , 41996101027370490+  ]++totientSpecialCases3 :: [Assertion]+totientSpecialCases3 = zipWith mkAssert (drop 1 (Inf.toList factorial)) totientMaxFactorial+  where+    mkAssert n m = assertEqual "should be equal" m (totientMax n)++    totientMax :: Word -> Word+    totientMax = unMaxWord . inverseTotient MaxWord++jordans5 :: [Word]+jordans5 =+  [ 1+  , 31+  , 242+  , 992+  , 3124+  , 7502+  , 16806+  , 31744+  , 58806+  , 96844+  , 161050+  , 240064+  , 371292+  , 520986+  , 756008+  , 1015808+  , 1419856+  , 1822986+  , 2476098+  , 3099008+  , 4067052+  , 4992550+  , 6436342+  , 7682048+  , 9762500+  , 11510052+  , 14289858+  , 16671552+  , 20511148+  ]++jordanSpecialCase1 :: [Assertion]+jordanSpecialCase1 = zipWith mkAssert ixs jordans5+  where+    mkAssert a b = assertEqual "should be equal" (S.singleton a) (asSetOfPreimages (inverseJordan 5) b)+    ixs = [1 .. 29]++-------------------------------------------------------------------------------+-- Sigma++sigmaProperty1 :: forall a. (Euclidean a, UniqueFactorisation a, Integral a, Enum (Prime a), Bits a) => Positive a -> Bool+sigmaProperty1 (Positive x) = x `S.member` asSetOfPreimages inverseSigma (sigma 1 x)++sigmaKProperty1+  :: forall a+   . (Euclidean a, UniqueFactorisation a, Integral a, Enum (Prime a), Bits a)+  => Power Word+  -> Positive a+  -> Bool+sigmaKProperty1 (Power k') (Positive x) =+  -- 'k' shouldn't be large to avoid slow tests.+  let k = 2 + k' `Prelude.mod` 20+  in x `S.member` asSetOfPreimages (inverseSigmaK k) (sigma k x)++sigmaProperty2 :: (Euclidean a, UniqueFactorisation a, Integral a, Enum (Prime a), Bits a) => Positive a -> Bool+sigmaProperty2 (Positive x) = all (== x) (S.map (sigma 1) (asSetOfPreimages inverseSigma x))++sigmaKProperty2+  :: (Euclidean a, UniqueFactorisation a, Integral a, Enum (Prime a), Bits a)+  => Power Word+  -> Positive a+  -> Bool+sigmaKProperty2 (Power k') (Positive x) =+  let k = 2 + k' `Prelude.mod` 20+  in all (== x) (S.map (sigma k) (asSetOfPreimages (inverseSigmaK k) x))++-- | http://oeis.org/A055486+sigmaCountFactorial :: [Word]+sigmaCountFactorial =+  [ 1+  , 0+  , 1+  , 3+  , 4+  , 15+  , 33+  , 111+  , 382+  , 1195+  , 3366+  , 14077+  , 53265+  , 229603+  , 910254+  , 4524029+  , 18879944+  , 91336498+  ]++sigmaSpecialCases1 :: [Assertion]+sigmaSpecialCases1 = zipWith mkAssert (drop 1 (Inf.toList factorial)) sigmaCountFactorial+  where+    mkAssert n m = assertEqual "should be equal" m (sigmaCount n)++    sigmaCount :: Word -> Word+    sigmaCount = inverseSigma (const 1)++-- | http://oeis.org/A055488+sigmaMinFactorial :: [Word]+sigmaMinFactorial =+  [ 5+  , 14+  , 54+  , 264+  , 1560+  , 10920+  , 97440+  , 876960+  , 10263240+  , 112895640+  , 1348827480+  , 18029171160+  , 264370186080+  , 3806158356000+  , 62703141621120+  , 1128159304272000+  ]++sigmaSpecialCases2 :: [Assertion]+sigmaSpecialCases2 = zipWith mkAssert (drop 3 (Inf.toList factorial)) sigmaMinFactorial+  where+    mkAssert n m = assertEqual "should be equal" m (sigmaMin n)++    sigmaMin :: Word -> Word+    sigmaMin = unMinWord . inverseSigma MinWord++-- | http://oeis.org/A055489+sigmaMaxFactorial :: [Word]+sigmaMaxFactorial =+  [ 5+  , 23+  , 95+  , 719+  , 5039+  , 39917+  , 361657+  , 3624941+  , 39904153+  , 479001599+  , 6226862869+  , 87178291199+  , 1307672080867+  , 20922780738961+  , 355687390376431+  , 6402373545694717+  ]++sigmaSpecialCases3 :: [Assertion]+sigmaSpecialCases3 = zipWith mkAssert (drop 3 (Inf.toList factorial)) sigmaMaxFactorial+  where+    mkAssert n m = assertEqual "should be equal" m (sigmaMax n)++    sigmaMax :: Word -> Word+    sigmaMax = unMaxWord . inverseSigma MaxWord++sigmaSpecialCase4 :: Assertion+sigmaSpecialCase4 = assertBool "200 should be in inverseSigma(sigma(200))" $+  sigmaProperty1 $ Positive (200 :: Word)++sigmas5 :: [Word]+sigmas5 =+  [ 1+  , 33+  , 244+  , 1057+  , 3126+  , 8052+  , 16808+  , 33825+  , 59293+  , 103158+  , 161052+  , 257908+  , 371294+  , 554664+  , 762744+  , 1082401+  , 1419858+  , 1956669+  , 2476100+  , 3304182+  , 4101152+  , 5314716+  , 6436344+  , 8253300+  , 9768751+  , 12252702+  , 14408200+  , 17766056+  , 20511150+  ]++sigmaSpecialCase5 :: [Assertion]+sigmaSpecialCase5 = zipWith mkAssert ixs sigmas5+ where+  mkAssert a b = assertEqual "should be equal" (S.singleton a) (asSetOfPreimages (inverseSigmaK 5) b)+  ixs = [1 .. 29]++-------------------------------------------------------------------------------+-- TestTree++-- Tests for 'Int', 'Word' are omitted because 'inverseSigmaK/inverseJordan'+-- tests would quickly overflow in these types.+testIntegralPropertyNoLargeInverse+  :: forall bool. (SC.Testable IO bool, QC.Testable bool)+  => String -> (forall a. (Euclidean a, Semiring a, Integral a, Bits a, UniqueFactorisation a, Show a, Enum (Prime a)) => Power Word -> Positive a -> bool) -> TestTree+testIntegralPropertyNoLargeInverse name f = testGroup name+  [ SC.testProperty "smallcheck Integer" (f :: Power Word -> Positive Integer -> bool)+  , SC.testProperty "smallcheck Natural" (f :: Power Word -> Positive Natural -> bool)+  , QC.testProperty "quickcheck Integer" (f :: Power Word -> Positive Integer -> bool)+  , QC.testProperty "quickcheck Natural" (f :: Power Word -> Positive Natural -> bool)+  ]++testSuite :: TestTree+testSuite = testGroup "Inverse"+  [ testGroup "Totient"+    [ testIntegralPropertyNoLarge "forward"  totientProperty1+    , testIntegralPropertyNoLarge "backward" totientProperty2+    , testGroup "count"+      (zipWith (\i a -> testCase ("factorial " ++ show i) a) [1..] totientSpecialCases1)+    , testGroup "min"+      (zipWith (\i a -> testCase ("factorial " ++ show i) a) [1..] totientSpecialCases2)+    , testGroup "max"+      (zipWith (\i a -> testCase ("factorial " ++ show i) a) [1..] totientSpecialCases3)+    ]+  , testGroup "Sigma1"+    [ testIntegralPropertyNoLarge "forward"  sigmaProperty1+    , testIntegralPropertyNoLarge "backward" sigmaProperty2+    , testCase "200" sigmaSpecialCase4+    , testGroup "count"+      (zipWith (\i a -> testCase ("factorial " ++ show i) a) [1..] sigmaSpecialCases1)+    , testGroup "min"+      (zipWith (\i a -> testCase ("factorial " ++ show i) a) [1..] sigmaSpecialCases2)+    , testGroup "max"+      (zipWith (\i a -> testCase ("factorial " ++ show i) a) [1..] sigmaSpecialCases3)+    ]++  , testGroup "Jordan"+    [ testIntegralPropertyNoLargeInverse "forward"  jordanProperty1+    , testIntegralPropertyNoLargeInverse "backward" jordanProperty2+    , testGroup "inverseJordan"+      (zipWith (\i test -> testCase ("inverseJordan 5" ++ show i) test) jordans5 jordanSpecialCase1)+    ]++  , testGroup  "SigmaK"+    [ testIntegralPropertyNoLargeInverse "forward"  sigmaKProperty1+    , testIntegralPropertyNoLargeInverse "backward" sigmaKProperty2+    , testGroup "inverseSigma"+      (zipWith (\i test -> testCase ("inverseSigma 5" ++ show i) test) sigmas5 sigmaSpecialCase5)+    ]+  ]
+ test-suite/Math/NumberTheory/ArithmeticFunctions/MertensTests.hs view
@@ -0,0 +1,68 @@+-- |+-- Module:      Math.NumberTheory.ArithmeticFunctions.MertensTests+-- Copyright:   (c) 2018 Andrew Lelechenko+-- Licence:     MIT+-- Maintainer:  Andrew Lelechenko <andrew.lelechenko@gmail.com>+--+-- Tests for Math.NumberTheory.ArithmeticFunctions.Mertens+--++{-# LANGUAGE LambdaCase #-}++{-# OPTIONS_GHC -fno-warn-type-defaults #-}++module Math.NumberTheory.ArithmeticFunctions.MertensTests+  ( testSuite+  ) where++import Test.Tasty++import qualified Data.Vector as V+import qualified Data.Vector.Unboxed as U++import Math.NumberTheory.ArithmeticFunctions+import Math.NumberTheory.ArithmeticFunctions.Mertens+import Math.NumberTheory.ArithmeticFunctions.SieveBlock+import Math.NumberTheory.TestUtils++moebiusConfig :: SieveBlockConfig Moebius+moebiusConfig = SieveBlockConfig+  { sbcEmpty                = MoebiusP+  , sbcAppend               = (<>)+  , sbcFunctionOnPrimePower = const $ \case+      0 -> MoebiusP+      1 -> MoebiusN+      _ -> MoebiusZ+  }++mertensDiffPointwise :: Word -> Word -> Int+mertensDiffPointwise lo len = sum $ map (runMoebius . moebius) [lo + 1 .. lo + len]++mertensDiffBlockSpecial :: Word -> Word -> Int+mertensDiffBlockSpecial lo len = U.sum $ U.map runMoebius+  $ sieveBlockMoebius (lo + 1) len++mertensDiffBlockUnboxed :: Word -> Word -> Int+mertensDiffBlockUnboxed lo len = U.sum $ U.map runMoebius+  $ sieveBlockUnboxed moebiusConfig (lo + 1) len++mertensDiffBlockBoxed :: Word -> Word -> Int+mertensDiffBlockBoxed lo len = V.sum $ V.map runMoebius+  $ sieveBlock moebiusConfig (lo + 1) len++mertensDiff :: Word -> Word -> Int+mertensDiff lo len = mertens (lo + len) - mertens lo++propertyCompare :: (Word -> Word -> Int) -> Word -> Word -> Bool+propertyCompare func lo' len' = mertensDiff lo len == func lo len+  where+    lo  = lo'  `rem` 10000000+    len = len' `rem` 1000++testSuite :: TestTree+testSuite = testGroup "Mertens"+  [ testSmallAndQuick "pointwise"     $ propertyCompare mertensDiffPointwise+  , testSmallAndQuick "block special" $ propertyCompare mertensDiffBlockSpecial+  , testSmallAndQuick "block unboxed" $ propertyCompare mertensDiffBlockUnboxed+  , testSmallAndQuick "block boxed"   $ propertyCompare mertensDiffBlockBoxed+  ]
+ test-suite/Math/NumberTheory/ArithmeticFunctions/SieveBlockTests.hs view
@@ -0,0 +1,98 @@+-- |+-- Module:      Math.NumberTheory.ArithmeticFunctions.SieveBlockTests+-- Copyright:   (c) 2016 Andrew Lelechenko+-- Licence:     MIT+-- Maintainer:  Andrew Lelechenko <andrew.lelechenko@gmail.com>+--+-- Tests for Math.NumberTheory.ArithmeticFunctions.SieveBlock+--++{-# LANGUAGE LambdaCase #-}++{-# OPTIONS_GHC -fno-warn-type-defaults #-}++module Math.NumberTheory.ArithmeticFunctions.SieveBlockTests+  ( testSuite+  ) where++import Test.Tasty+import Test.Tasty.HUnit++import qualified Data.Vector as V+import qualified Data.Vector.Unboxed as U++import Math.NumberTheory.ArithmeticFunctions+import Math.NumberTheory.ArithmeticFunctions.SieveBlock+import Math.NumberTheory.Primes (Prime(..))++pointwiseTest :: (Eq a, Show a) => ArithmeticFunction Word a -> Word -> Word -> IO ()+pointwiseTest f lowIndex len = assertEqual "pointwise"+    (runFunctionOverBlock f lowIndex len)+    (V.generate (fromIntegral len) (runFunction f . (+ lowIndex) . fromIntegral))++moebiusTest :: Word -> Word -> Bool+moebiusTest m n+  = m == 0+  || sieveBlockUnboxed moebiusConfig m n+  == sieveBlockMoebius m n++moebiusSpecialCases :: [TestTree]+moebiusSpecialCases = map (uncurry pairToTest)+  [ (1, 1)+  , (1, 2)+  , (208, 298)+  , (1, 12835)+  , (10956, 4430)+  , (65, 16171)+  , (120906, 19456)+  , (33800000, 27002)+  , (17266222643, 5051)+  , (1000158, 48758)+  , (1307265, 3725)+  , (2600000, 14686)+  , (4516141422507 - 100000, 100001)+  , (1133551497049257 - 100000, 100001)+  -- too long for regular runs+  -- , (1157562178759482171 - 100000, 100001)+  ]+  where+    pairToTest :: Word -> Word -> TestTree+    pairToTest m n = testCase (show m ++ "," ++ show n) $ assertBool "should be equal" $ moebiusTest m n++moebiusConfig :: SieveBlockConfig Moebius+moebiusConfig = SieveBlockConfig+  { sbcEmpty = MoebiusP+  , sbcAppend = (<>)+  , sbcFunctionOnPrimePower = const $ \case+      0 -> MoebiusP+      1 -> MoebiusN+      _ -> MoebiusZ+  }++doesNotSegfaultOnZero :: IO ()+doesNotSegfaultOnZero = assertBool "should not segfault" $ xs == xs+  where+    xs = U.sum $ sieveBlockUnboxed sigmaConfig 0 5++sigmaConfig :: SieveBlockConfig Int+sigmaConfig = SieveBlockConfig+  { sbcEmpty = 1+  , sbcAppend = (*)+  , sbcFunctionOnPrimePower =+      \p n -> fromIntegral $ (unPrime p ^ (n+1) - 1) `quot` (unPrime p - 1)+  }++testSuite :: TestTree+testSuite = testGroup "SieveBlock"+  [ testGroup "pointwise"+    [ testCase "divisors"   $ pointwiseTest divisorsA   1 1000+    , testCase "tau"        $ pointwiseTest tauA        1 1000+    , testCase "totient"    $ pointwiseTest totientA    1 1000+    , testCase "moebius"    $ pointwiseTest moebiusA    1 1000+    , testCase "smallOmega" $ pointwiseTest smallOmegaA 1 1000+    , testCase "bigOmega"   $ pointwiseTest bigOmegaA   1 1000+    , testCase "carmichael" $ pointwiseTest carmichaelA 1 1000+    ]+  , testGroup "special moebius" moebiusSpecialCases+  , testCase "does not segfault at 0" doesNotSegfaultOnZero+  ]
test-suite/Math/NumberTheory/ArithmeticFunctionsTests.hs view
@@ -3,13 +3,10 @@ -- Copyright:   (c) 2016 Andrew Lelechenko -- Licence:     MIT -- Maintainer:  Andrew Lelechenko <andrew.lelechenko@gmail.com>--- Stability:   Provisional -- -- Tests for Math.NumberTheory.ArithmeticFunctions -- -{-# LANGUAGE CPP       #-}- {-# OPTIONS_GHC -fno-warn-type-defaults #-}  module Math.NumberTheory.ArithmeticFunctionsTests@@ -19,45 +16,51 @@ 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.List.Infinite as Inf import qualified Data.Set as S import qualified Data.IntSet as IS  import Math.NumberTheory.ArithmeticFunctions-import Math.NumberTheory.Primes.Factorisation+import Math.NumberTheory.Primes (UniqueFactorisation (factorise)) import Math.NumberTheory.TestUtils+import Math.NumberTheory.Zeta (zetas)  import Numeric.Natural  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 `rem` 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) +-- | 'divisorsTo' matches 'divisorsA' with a filter+divisorsProperty6 :: Positive Int -> NonNegative Int -> Bool+divisorsProperty6 (Positive a) (NonNegative b) = runFunction (divisorsToA to) n == expected+  where to = a+        n = to + b+        expected = S.filter (<=to) (runFunction divisorsA n)+ -- | tau matches baseline from OEIS. tauOeis :: Assertion tauOeis = oeisAssertion "A000005" tauA@@ -69,12 +72,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 :: Natural)  -- | 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@@ -82,7 +85,7 @@   [ 1, 3, 4, 7, 6, 12, 8, 15, 13, 18, 12, 28, 14, 24, 24, 31, 18, 39, 20   , 42, 32, 36, 24, 60, 31, 42, 40, 56, 30, 72, 32, 63, 48, 54, 48, 91, 38   , 60, 56, 90, 42, 96, 44, 84, 78, 72, 48, 124, 57, 93, 72, 98, 54, 120-  , 72, 120, 80, 90, 60, 168, 62, 96, 104, 127, 84, 144, 68, 126, 96, 144+  , 72, 120, 80, 90, 60, 168, 62, 96, 104, 127, 84, 144, 68, 126, 96, 144 :: Natural   ]  -- | sigma_2 matches baseline from OEIS.@@ -91,25 +94,16 @@   [ 1, 5, 10, 21, 26, 50, 50, 85, 91, 130, 122, 210, 170, 250, 260, 341, 290   , 455, 362, 546, 500, 610, 530, 850, 651, 850, 820, 1050, 842, 1300, 962   , 1365, 1220, 1450, 1300, 1911, 1370, 1810, 1700, 2210, 1682, 2500, 1850-  , 2562, 2366, 2650, 2210, 3410, 2451, 3255+  , 2562, 2366, 2650, 2210, 3410, 2451, 3255 :: Natural   ]  -- | 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@@ -121,12 +115,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@@ -137,30 +131,92 @@   , 1728, 1584, 2208, 1536   ] --- | moebius values are [-1, 0, 1]-moebiusProperty1 :: Natural -> Bool-moebiusProperty1 n = runFunction moebiusA n `elem` [-1, 0, 1]+-- | 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') `rem` (2^11) == 0+  | k == 3 = (ramanujan n' - 1217 * sigma 11 n') `rem` (2^13) == 0+  | k == 5 = (ramanujan n' - 1537 * sigma 11 n') `rem` (2^12) == 0+  | k == 7 = (ramanujan n' - 705 * sigma 11 n') `rem` (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 `rem` 7 == 0+  | otherwise                    = m `rem` 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" 0 (runFunction moebiusA (2^2 * (2^100000-1) :: Natural))+moebiusLazy = assertEqual "moebius" MoebiusZ (runFunction moebiusA (2^2 * (2^100000-1) :: Natural))  -- | moebius matches baseline from OEIS. moebiusOeis :: Assertion moebiusOeis = oeisAssertion "A008683" moebiusA-  [ 1, -1, -1, 0, -1, 1, -1, 0, 0, 1, -1, 0, -1, 1, 1, 0, -1, 0, -1, 0, 1, 1, -1-  , 0, 0, 1, 0, 0, -1, -1, -1, 0, 1, 1, 1, 0, -1, 1, 1, 0, -1, -1, -1, 0, 0, 1-  , -1, 0, 0, 0, 1, 0, -1, 0, 1, 0, 1, 1, -1, 0, -1, 1, 0, 0, 1, -1, -1, 0, 1-  , -1, -1, 0, -1, 1, 0, 0, 1+  [ MoebiusP, MoebiusN, MoebiusN, MoebiusZ, MoebiusN, MoebiusP, MoebiusN, MoebiusZ, MoebiusZ, MoebiusP, MoebiusN, MoebiusZ, MoebiusN, MoebiusP, MoebiusP, MoebiusZ, MoebiusN, MoebiusZ, MoebiusN, MoebiusZ, MoebiusP, MoebiusP, MoebiusN+  , MoebiusZ, MoebiusZ, MoebiusP, MoebiusZ, MoebiusZ, MoebiusN, MoebiusN, MoebiusN, MoebiusZ, MoebiusP, MoebiusP, MoebiusP, MoebiusZ, MoebiusN, MoebiusP, MoebiusP, MoebiusZ, MoebiusN, MoebiusN, MoebiusN, MoebiusZ, MoebiusZ, MoebiusP+  , MoebiusN, MoebiusZ, MoebiusZ, MoebiusZ, MoebiusP, MoebiusZ, MoebiusN, MoebiusZ, MoebiusP, MoebiusZ, MoebiusP, MoebiusP, MoebiusN, MoebiusZ, MoebiusN, MoebiusP, MoebiusZ, MoebiusZ, MoebiusP, MoebiusN, MoebiusN, MoebiusZ, MoebiusP+  , MoebiusN, MoebiusN, MoebiusZ, MoebiusN, MoebiusP, MoebiusZ, MoebiusZ, MoebiusP   ]  -- | 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 == 0 || l == m+liouvilleProperty2 :: NonZero Natural -> Bool+liouvilleProperty2 (NonZero n) = m == MoebiusZ || l == runMoebius m   where     l = runFunction liouvilleA n     m = runFunction moebiusA   n@@ -176,17 +232,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 `rem` runFunction carmichaelA n == 0  -- | carmichael matches baseline from OEIS. carmichaelOeis :: Assertion@@ -198,8 +245,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@@ -230,6 +277,47 @@   , 73, 1, 1, 1, 1, 1, 79, 1, 3, 1, 83, 1, 1, 1, 1, 1, 89, 1, 1, 1, 1, 1, 1   ] +nFreedomProperty1 :: Word -> NonZero Natural -> Bool+nFreedomProperty1 n (NonZero m) =+    isNFree n m == (all ((< n) . snd) . factorise) m++nFreedomProperty2 :: Power Word -> NonNegative Int -> Bool+nFreedomProperty2 (Power n) (NonNegative m) =+    let n' | n == maxBound = n+           | otherwise     = n + 1+    in take m (filter (isNFree n') [1 ..]) == take m (nFrees n' :: [Integer])++nFreedomProperty3 :: Power Word -> Positive Int -> Bool+nFreedomProperty3 (Power n) (Positive m) = case drop (m' - 1) $ nFrees n :: [Integer] of+  [] -> True+  x : _ -> 1 / fromIntegral m >= abs (zet - fromIntegral m' / fromIntegral x)+  where+    zet :: Double+    zet = 1 / zetas 1e-14 Inf.!! n++    m' :: Int+    m' = 100 * m++-- |+-- * Using a bounded integer type like @Int@ instead of @Integer@ here means+-- even a relatively low value of @n@, e.g. 20 may cause out-of-bounds memory+-- accesses in @nFreesBlock@.+-- * Using @Integer@ prevents this, so that is the numeric type used here.+nFreesBlockProperty1 :: Power Word -> Positive Integer -> Word -> Bool+nFreesBlockProperty1 (Power n) (Positive lo) w =+    let block = nFreesBlock n lo w+        len   = length block+        blk   = take len . dropWhile (< lo) . nFrees $ n+    in block == blk++nFreedomAssertion1 :: Assertion+nFreedomAssertion1 =+    assertEqual "1 is the sole 0-free number" (nFrees 0) ([1] :: [Int])++nFreedomAssertion2 :: Assertion+nFreedomAssertion2 =+    assertEqual "1 is the sole 1-free number" (nFrees 1) ([1] :: [Int])+ testSuite :: TestTree testSuite = testGroup "ArithmeticFunctions"   [ testGroup "Divisors"@@ -238,6 +326,7 @@     , testSmallAndQuick "matches definition"       divisorsProperty3     , testSmallAndQuick "divisors = divisorsSmall" divisorsProperty4     , testSmallAndQuick "divisors = divisorsList"  divisorsProperty5+    , testSmallAndQuick "divisors = divisorsTo"  divisorsProperty6     ]   , testGroup "Tau"     [ testCase "OEIS" tauOeis@@ -251,7 +340,6 @@   , testGroup "Totient"     [ testSmallAndQuick "totient is even"      totientProperty1     , testSmallAndQuick "totient n < n"        totientProperty2-    , testSmallAndQuick "matches sieveTotient" totientProperty3     , testCase          "OEIS"                 totientOeis     ]   , testGroup "Jordan"@@ -259,9 +347,15 @@     , 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"-    [ testSmallAndQuick "moebius values" moebiusProperty1-    , testCase          "OEIS"           moebiusOeis+    [ testCase          "OEIS"           moebiusOeis     , testCase          "Lazy"           moebiusLazy     ]   , testGroup "Liouville"@@ -271,7 +365,6 @@     ]   , testGroup "Carmichael"     [ testSmallAndQuick "carmichael divides totient" carmichaelProperty1-    , testSmallAndQuick "matches sieveCarmichael"    carmichaelProperty2     , testCase          "OEIS"                       carmichaelOeis     ]   , testGroup "Omegas"@@ -281,5 +374,13 @@     ]   , testGroup "Mangoldt"     [ testCase "OEIS" mangoldtOeis+    ]+  , testGroup "N-freedom"+    [ testSmallAndQuick "`isNFree` matches the definition" nFreedomProperty1+    , testSmallAndQuick "numbers produces by `nFrees`s are `n`-free" nFreedomProperty2+    , testSmallAndQuick "distribution of n-free numbers matches expected" nFreedomProperty3+    , testSmallAndQuick "nFreesBlock matches nFrees" nFreesBlockProperty1+    , testCase "`1` is the only 0-free number" nFreedomAssertion1+    , testCase "`1` is the only 1-free number" nFreedomAssertion2     ]   ]
test-suite/Math/NumberTheory/CurvesTests.hs view
@@ -3,33 +3,25 @@ -- Copyright:   (c) 2017 Andrew Lelechenko -- Licence:     MIT -- Maintainer:  Andrew Lelechenko <andrew.lelechenko@gmail.com>--- Stability:   Provisional -- -- Tests for Math.NumberTheory.Curves -- -{-# LANGUAGE CPP                        #-} {-# LANGUAGE LambdaCase                 #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-}  module Math.NumberTheory.CurvesTests where  import Test.Tasty-import Test.Tasty.QuickCheck as QC hiding (Positive, NonNegative, generate, getNonNegative)+import Test.Tasty.QuickCheck as QC hiding (Positive(..), NonNegative(..)) -import GHC.TypeNats.Compat+import GHC.TypeNats (KnownNat)  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-  Just y  -> f y+x ==>? f = maybe discard f x  isValid :: KnownNat n => Point a24 n -> Property isValid p
+ test-suite/Math/NumberTheory/DiophantineTests.hs view
@@ -0,0 +1,38 @@+-- Tests for Math.NumberTheory.Diophantine++{-# OPTIONS_GHC -fno-warn-type-defaults #-}++module Math.NumberTheory.DiophantineTests+  ( testSuite+  ) where++import Data.List (sort)++import Test.Tasty++import Math.NumberTheory.Diophantine+import Math.NumberTheory.Roots (integerSquareRoot)+import Math.NumberTheory.TestUtils++cornacchiaTest :: Positive Integer -> Positive Integer -> Bool+cornacchiaTest (Positive d) (Positive a) = gcd d m /= 1 || all checkSoln (cornacchia d m)+  where m = d + a+        checkSoln (x, y) = x*x + d*y*y == m++-- Testing against a slower reference implementation on coprime inputs+cornacchiaBruteForce :: Positive Integer -> Positive Integer -> Bool+cornacchiaBruteForce (Positive d) (Positive a) = gcd d m /= 1 || findSolutions [] 1 == sort (cornacchia d m)+  where m = d + a+        -- Simple O(sqrt (m/d)) brute force by considering all possible y values+        findSolutions acc y+          | x2 <= 0     = acc+          | x*x == x2   = findSolutions ((x,y) : acc) (y+1)+          | otherwise   = findSolutions acc (y+1)+            where x2 = m - d*y*y+                  x = integerSquareRoot x2++testSuite :: TestTree+testSuite = testGroup "Diophantine"+  [ testSmallAndQuick "Cornacchia correct" cornacchiaTest+  , testSmallAndQuick "Cornacchia same solutions as brute force" cornacchiaBruteForce+  ]
+ test-suite/Math/NumberTheory/DirichletCharactersTests.hs view
@@ -0,0 +1,241 @@+-- |+-- Module:       Math.NumberTheory.DirichletCharactersTests+-- Copyright:    (c) 2018 Bhavik Mehta+-- License:      MIT+-- Maintainer:   Andrew Lelechenko <andrew.lelechenko@gmail.com>+--+-- Tests for Math.NumberTheory.DirichletCharacters+--++{-# LANGUAGE GADTs #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ViewPatterns #-}++module Math.NumberTheory.DirichletCharactersTests where++import Test.Tasty++import Data.Complex+import Data.List (genericLength)+import Data.Maybe (isJust, mapMaybe)+import Data.Proxy+import Data.Semigroup+import qualified Data.Vector as V+import Numeric.Natural++import GHC.TypeNats (SomeNat(..), someNatVal, KnownNat, natVal, sameNat)+import Data.Type.Equality++import Math.NumberTheory.ArithmeticFunctions (totient, divisorsList)+import Math.NumberTheory.DirichletCharacters+import qualified Math.NumberTheory.Moduli.Sqrt as J+import Math.NumberTheory.Moduli.Class (SomeMod(..), modulo)+import Math.NumberTheory.TestUtils (testSmallAndQuick, Positive(..))++-- | This tests property 6 from https://en.wikipedia.org/wiki/Dirichlet_character#Axiomatic_definition+dirCharOrder :: forall n. KnownNat n => DirichletCharacter n -> Bool+dirCharOrder chi = isPrincipal (totient n `stimes` chi)+  where n = natVal @n Proxy++-- | Tests wikipedia's property 3 (note 1,2,5 are essentially enforced by the type system).+testMultiplicative :: KnownNat n => DirichletCharacter n -> Natural -> Natural -> Bool+testMultiplicative chi (fromIntegral -> a) (fromIntegral -> b) = chiAB == chiAchiB+  where chi' = evalGeneral chi+        chiAB = chi' (a*b)+        chiAchiB = (<>) <$> chi' a <*> chi' b++-- | Test property 4 from wikipedia+testAtOne :: KnownNat n => DirichletCharacter n -> Bool+testAtOne chi = eval chi mempty == mempty++dirCharProperty :: (forall n. KnownNat n => DirichletCharacter n -> a) -> Positive Natural -> Natural -> a+dirCharProperty test (Positive n) i =+  case someNatVal n of+    SomeNat (Proxy :: Proxy n) -> test chi+      where chi = indexToChar @n (i `mod` totient n)++realCharProperty :: (forall n. KnownNat n => RealCharacter n -> a) -> Positive Natural -> Int -> a+realCharProperty test (Positive n) i =+  case someNatVal n of+    SomeNat (Proxy :: Proxy n) -> test chi+      where chi = chars !! (i `mod` length chars)+            chars = mapMaybe isRealCharacter [principalChar @n .. maxBound]++-- | There should be totient(n) characters+countCharacters :: Positive Natural -> Bool+countCharacters (Positive n) =+  case someNatVal n of+    SomeNat (Proxy :: Proxy n) ->+      genericLength (allChars @n) == totient n++-- | The principal character should be 1 if gcd k n is 1 and 0 otherwise+principalCase :: Positive Natural -> Positive Integer -> Bool+principalCase (Positive n) (Positive k) =+  case k `modulo` n of+    SomeMod a -> evalGeneral chi a == if gcd k (fromIntegral n) > 1+                                         then Zero+                                         else mempty+      where chi = principalChar+    InfMod{} -> False++-- | Test the orthogonality relations https://en.wikipedia.org/wiki/Dirichlet_character#Character_orthogonality+orthogonality1 :: forall n. KnownNat n => DirichletCharacter n -> Bool+orthogonality1 chi = magnitude (total - correct) < (1e-13 :: Double)+  where n = natVal @n Proxy+        total = sum [orZeroToNum toComplex (evalGeneral chi a) | a <- [0 .. maxBound]]+        correct = if isPrincipal chi+                     then fromIntegral $ totient n+                     else 0++orthogonality2 :: Positive Natural -> Integer -> Bool+orthogonality2 (Positive n) a =+  case a `modulo` n of+    SomeMod a' -> magnitude (total - correct) < (1e-13 :: Double)+      where total = sum [orZeroToNum toComplex (evalGeneral chi a') | chi <- allChars]+            correct = if a' == 1+                         then fromIntegral $ totient n+                         else 0+    InfMod {} -> False++-- | Manually confirm isRealCharacter is correct (in both directions)+realityCheck :: KnownNat n => DirichletCharacter n -> Bool+realityCheck chi = isJust (isRealCharacter chi) == isReal'+  where isReal' = and [real (evalGeneral chi t) | t <- [minBound..maxBound]]+        real Zero = True+        real (NonZero t) = t <> t == mempty++-- | Check real character evaluation matches normal evaluation+realEvalCheck :: KnownNat n => RealCharacter n -> Int -> Bool+realEvalCheck chi i' = fromIntegral (toRealFunction chi i) == (orZeroToNum toComplex (evalGeneral (getRealChar chi) i) :: Complex Double)+  where i = fromIntegral i'++-- | The jacobi character agrees with the jacobi symbol+jacobiCheck :: Positive Natural -> Bool+jacobiCheck (Positive n) =+  case someNatVal (2*n+1) of+    SomeNat (Proxy :: Proxy n) ->+      case jacobiCharacter @n of+        Just chi -> and [toRealFunction chi (fromIntegral j) == J.symbolToNum (J.jacobi j (2*n+1)) | j <- [0..2*n]]+        _ -> False++-- | Bulk evaluation agrees with pointwise evaluation+evalAllCheck :: forall n. KnownNat n => DirichletCharacter n -> Bool+evalAllCheck chi = V.generate (fromIntegral $ natVal @n Proxy) (evalGeneral chi . fromIntegral) == evalAll chi++-- | Induced characters agree with the original character.+-- (Except for when d=1, where chi(0) = 1, which is true for no other d)+inducedCheck :: forall d. KnownNat d => DirichletCharacter d -> Positive Natural -> Bool+inducedCheck chi (Positive k) =+  case someNatVal (d*k) of+    SomeNat (Proxy :: Proxy n) ->+      case induced @n chi of+        Just chi2 -> and (V.izipWith matchedValue (V.concat (replicate (fromIntegral k) (evalAll chi))) (evalAll chi2))+        Nothing -> False+  where d = natVal @d Proxy+        matchedValue i x1 x2 = if gcd (fromIntegral i) (d*k) > 1+                                  then x2 == Zero+                                  else x2 == x1++-- | Primitive checker is correct (in both directions)+primitiveCheck :: forall n. KnownNat n => DirichletCharacter n -> Bool+primitiveCheck chi = isJust (isPrimitive chi) == isPrimitive'+  where isPrimitive' = all (\m -> m == n || testModulus m) (divisorsList n)+        n = fromIntegral (natVal @n Proxy) :: Int+        table = evalAll chi+        testModulus d = not $ null [a | a <- [1..n-1], gcd a n == 1, a `mod` d == 1 `mod` d, table V.! a /= mempty]++-- | Ensure that makePrimitive gives primitive characters+makePrimitiveCheck :: DirichletCharacter n -> Bool+makePrimitiveCheck chi = case makePrimitive chi of+                            WithNat chi' -> isJust (isPrimitive (getPrimitiveChar chi'))++-- | sameNat also ensures the two new moduli are the same+makePrimitiveIdem :: DirichletCharacter n -> Bool+makePrimitiveIdem chi = case makePrimitive chi of+                          WithNat (chi' :: PrimitiveCharacter n') ->+                            case makePrimitive (getPrimitiveChar chi') of+                              WithNat (chi'' :: PrimitiveCharacter n'') ->+                                case sameNat (Proxy :: Proxy n') (Proxy :: Proxy n'') of+                                  Just Refl -> chi' == chi''+                                  Nothing -> False++orderCheck :: DirichletCharacter n -> Bool+orderCheck chi = isPrincipal (n `stimes` chi) && and [not (isPrincipal (i `stimes` chi)) | i <- [1..n-1]]+  where n = orderChar chi++fromTableCheck :: forall n. KnownNat n => DirichletCharacter n -> Bool+fromTableCheck chi = isJust (fromTable @n (evalAll chi))++-- A bunch of functions making sure that every function which can produce a character (in+-- particular by fiddling internal representation) produces a valid character+indexToCharValid :: KnownNat n => DirichletCharacter n -> Bool+indexToCharValid = validChar++principalCharValid :: Positive Natural -> Bool+principalCharValid (Positive n) =+  case someNatVal n of+    SomeNat (Proxy :: Proxy n) -> validChar (principalChar @n)++mulCharsValid :: KnownNat n => DirichletCharacter n -> DirichletCharacter n -> Bool+mulCharsValid chi1 chi2 = validChar (chi1 <> chi2)++mulCharsValid' :: Positive Natural -> Natural -> Natural -> Bool+mulCharsValid' (Positive n) i j =+  case someNatVal n of+    SomeNat (Proxy :: Proxy n) ->+      mulCharsValid (indexToChar @n (i `mod` totient n)) (indexToChar @n (j `mod` totient n))++stimesCharValid :: KnownNat n => DirichletCharacter n -> Int -> Bool+stimesCharValid chi n = validChar (n `stimes` chi)++succValid :: KnownNat n => DirichletCharacter n -> Bool+succValid = validChar . succ++inducedValid :: forall d. KnownNat d => DirichletCharacter d -> Positive Natural -> Bool+inducedValid chi (Positive k) = case someNatVal (natVal @d Proxy * k) of+  SomeNat (Proxy :: Proxy n) -> maybe False validChar (induced @n chi)++jacobiValid :: Positive Natural -> Bool+jacobiValid (Positive n) =+  case someNatVal (2*n+1) of+    SomeNat (Proxy :: Proxy n) ->+      case jacobiCharacter @n of+        Just chi -> validChar (getRealChar chi)+        _ -> False++makePrimitiveValid :: DirichletCharacter n -> Bool+makePrimitiveValid chi = case makePrimitive chi of+                            WithNat chi' -> validChar (getPrimitiveChar chi')++testSuite :: TestTree+testSuite = testGroup "DirichletCharacters"+  [ testSmallAndQuick "Dirichlet characters divide the right order" (dirCharProperty dirCharOrder)+  , testSmallAndQuick "Dirichlet characters are multiplicative" (dirCharProperty testMultiplicative)+  , testSmallAndQuick "Dirichlet characters are 1 at 1" (dirCharProperty testAtOne)+  , testSmallAndQuick "Right number of Dirichlet characters" countCharacters+  , testSmallAndQuick "Principal character behaves as expected" principalCase+  , testSmallAndQuick "Orthogonality relation 1" (dirCharProperty orthogonality1)+  , testSmallAndQuick "Orthogonality relation 2" orthogonality2+  , testSmallAndQuick "Real character checking is correct" (dirCharProperty realityCheck)+  , testSmallAndQuick "Real character evaluation is accurate" (realCharProperty realEvalCheck)+  , testSmallAndQuick "Jacobi character matches symbol" jacobiCheck+  , testSmallAndQuick "Bulk evaluation matches pointwise" (dirCharProperty evalAllCheck)+  , testSmallAndQuick "Induced character is correct" (dirCharProperty inducedCheck)+  , testSmallAndQuick "Primitive character checking is correct" (dirCharProperty primitiveCheck)+  , testSmallAndQuick "makePrimitive produces primitive character" (dirCharProperty makePrimitiveCheck)+  , testSmallAndQuick "makePrimitive is idempotent" (dirCharProperty makePrimitiveIdem)+  , testSmallAndQuick "Calculates correct order" (dirCharProperty orderCheck)+  , testSmallAndQuick "Can construct from table" (dirCharProperty fromTableCheck)+  , testGroup "Creates valid characters"+    [ testSmallAndQuick "indexToChar" (dirCharProperty indexToCharValid)+    , testSmallAndQuick "principalChar" principalCharValid+    , testSmallAndQuick "mulChars" mulCharsValid'+    , testSmallAndQuick "stimesChar" (dirCharProperty stimesCharValid)+    , testSmallAndQuick "succ" (dirCharProperty succValid)+    , testSmallAndQuick "induced" (dirCharProperty inducedValid)+    , testSmallAndQuick "jacobi" jacobiValid+    , testSmallAndQuick "makePrimitive" (dirCharProperty makePrimitiveValid)+    ]+  ]
+ test-suite/Math/NumberTheory/EisensteinIntegersTests.hs view
@@ -0,0 +1,187 @@+-- |+-- Module:      Math.NumberTheory.EisensteinIntegersTests+-- Copyright:   (c) 2018 Alexandre Rodrigues Baldé+-- Licence:     MIT+-- Maintainer:  Alexandre Rodrigues Baldé <alexandrer_b@outlook.+--+-- Tests for Math.NumberTheory.EisensteinIntegers+--++{-# OPTIONS_GHC -fno-warn-type-defaults #-}++module Math.NumberTheory.EisensteinIntegersTests+  ( testSuite+  ) where++import Prelude hiding (gcd, rem, quot, quotRem)+import Data.Euclidean+import qualified Data.List.Infinite as Inf+import Data.Maybe (fromJust, isJust)+import Data.Proxy+import Test.Tasty.QuickCheck as QC hiding (Positive(..), NonNegative(..))+import Test.QuickCheck.Classes+import Test.Tasty                                     (TestTree, testGroup)+import Test.Tasty.HUnit                               (Assertion, assertEqual,+                                                      testCase)++import qualified Math.NumberTheory.Quadratic.EisensteinIntegers as E+import Math.NumberTheory.Primes+import Math.NumberTheory.TestUtils++-- | Check that @signum@ and @abs@ satisfy @z == signum z * abs z@, where @z@ is+-- an @EisensteinInteger@.+signumAbsProperty :: E.EisensteinInteger -> 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 @rem@ produces a remainder smaller than the divisor with+-- regards to the Euclidean domain's function.+remProperty1 :: E.EisensteinInteger -> E.EisensteinInteger -> Bool+remProperty1 x y = (y == 0) || E.norm (x `rem` 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) = quotRem x y+    q'     = quot x y+    r'     = rem x y++-- | Verify that @quotRemE@ produces the right quotient and remainder.+quotRemProperty2 :: E.EisensteinInteger -> E.EisensteinInteger -> Bool+quotRemProperty2 x y = (y == 0) || (x `quot` y) * y + (x `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 `rem` z == 0 && z2 `rem` z == 0+  where+    z = 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+  || gcd z1' z2' `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 E.:+ 1) $ 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 = unPrime prime `mod` 6 == 1+        p = (!! index) $ filter prop $ drop 3 primes+    in isJust (isPrime (unPrime (E.findPrime p) :: E.EisensteinInteger))++-- | 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 (isJust . isPrime . (unPrime :: Prime E.EisensteinInteger -> E.EisensteinInteger)) $ Inf.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 :: [Prime E.EisensteinInteger] -> Bool+        isOrdered xs = all (\(x, y) -> E.norm (unPrime x) <= E.norm (unPrime y)) . zip xs $ drop 1 xs+    in isOrdered $ Inf.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 (unPrime e) == (unPrime e :: E.EisensteinInteger)) $ Inf.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 = factorise g+    g' = product $ map (\(p, k) -> unPrime p ^ k) factors++-- | Check that there are no factors with exponent @0@ in the factorisation.+factoriseProperty2 :: E.EisensteinInteger -> Bool+factoriseProperty2 z = z == 0 || all ((> 0) . snd) (factorise z)++-- | Check that no factor produced by @factorise@ is a unit.+factoriseProperty3 :: E.EisensteinInteger -> Bool+factoriseProperty3 z = z == 0 || all ((> 1) . E.norm . unPrime . fst) (factorise z)++factoriseSpecialCase1 :: Assertion+factoriseSpecialCase1 = assertEqual "should be equal"+  [ (fromJust $ isPrime $ 2 E.:+ 1, 3)+  , (fromJust $ isPrime $ 3 E.:+ 1, 1)+  ]+  (factorise (15 E.:+ 12))++testSuite :: TestTree+testSuite = testGroup "EisensteinIntegers"+  [ testSmallAndQuick "forall z . z == signum z * abs z" signumAbsProperty+  , testSmallAndQuick "abs z rotates to the first sextant" absProperty+  , testGroup "Division"+    [ testSmallAndQuick "The remainder's norm is smaller than the divisor's"+                        remProperty1++    , 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+    -- smallcheck takes too long+    , QC.testProperty "Common divisor divides gcd"+                        gcdEProperty2+    , testCase          "g.c.d. (12 :+ 23) (23 :+ 34)" gcdESpecialCase1+    ]+  , testSmallAndQuick "The Eisenstein norm function is multiplicative"+                    euclideanDomainProperty1+  , testGroup "Primality"+    [ testSmallAndQuick "findPrime returns prime"+                        findPrimesProperty1+    , testSmallAndQuick "primes are actually prime"+                        primesProperty1+    , testSmallAndQuick "primes is ordered"+                        primesProperty2+    , testSmallAndQuick "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+      , testCase          "factorise 15:+12" factoriseSpecialCase1+      ]+  , lawsToTest $ gcdDomainLaws (Proxy :: Proxy E.EisensteinInteger)+  , lawsToTest $ euclideanLaws (Proxy :: Proxy E.EisensteinInteger)+  ]
+ test-suite/Math/NumberTheory/EuclideanTests.hs view
@@ -0,0 +1,181 @@+-- |+-- Module:      Math.NumberTheory.EuclideanTests+-- Copyright:   (c) 2016 Andrew Lelechenko+-- Licence:     MIT+-- Maintainer:  Andrew Lelechenko <andrew.lelechenko@gmail.com>+--+-- Tests for Math.NumberTheory.Euclidean.Coprimes+--++{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}++{-# OPTIONS_GHC -fno-warn-type-defaults  #-}+{-# OPTIONS_GHC -fno-warn-unused-imports #-}++module Math.NumberTheory.EuclideanTests+  ( testSuite+  ) where++import Prelude hiding (gcd)+import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.QuickCheck as QC hiding (Positive(..), NonZero(..))++import Control.Arrow+import Data.Bits+import Data.Euclidean+import Data.Maybe+import Data.Semigroup+import Data.List (tails, sort)+import Numeric.Natural++import Math.NumberTheory.Euclidean.Coprimes+import Math.NumberTheory.Quadratic.GaussianIntegers+import Math.NumberTheory.TestUtils++-- | Check that numbers are coprime iff their gcd equals to 1.+coprimeProperty :: (Eq a, Num a, GcdDomain a, Euclidean a) => AnySign a -> AnySign a -> Bool+coprimeProperty (AnySign a) (AnySign b) = coprime a b == (gcd a b == 1)++splitIntoCoprimesProperty1+  :: (Eq a, Num a, GcdDomain a)+  => [(a, Power Word)]+  -> Bool+splitIntoCoprimesProperty1 fs' = factorback fs == factorback (unCoprimes $ splitIntoCoprimes fs)+  where+    fs = map (second getPower) fs'+    factorback = abs . product . map (uncurry (^))++splitIntoCoprimesProperty2+  :: (Eq a, Num a, GcdDomain a)+  => [(NonZero a, Power Word)]+  -> Bool+splitIntoCoprimesProperty2 fs' = multiplicities fs <= multiplicities (unCoprimes $ splitIntoCoprimes fs)+  where+    fs = map (getNonZero *** getPower) fs'+    multiplicities = sum . map snd . filter ((/= 1) . abs . fst)++splitIntoCoprimesProperty3+  :: (Eq a, Num a, GcdDomain a)+  => [(a, Power Word)]+  -> Bool+splitIntoCoprimesProperty3 fs' = and [ coprime x y | (x : xs) <- tails fs, y <- xs ]+  where+    fs = map fst $ unCoprimes $ splitIntoCoprimes $ map (second getPower) fs'++-- | Check that evaluation never freezes.+splitIntoCoprimesProperty4+  :: (Eq a, Num a, GcdDomain a)+  => [(a, Word)]+  -> Bool+splitIntoCoprimesProperty4 fs' = fs == fs+  where+    fs = splitIntoCoprimes fs'++splitIntoCoprimesProperty5+  :: (Eq a, Num a, GcdDomain a)+  => [(a, Word)]+  -> Bool+splitIntoCoprimesProperty5 =+  all ((/= 1) . abs . fst) . unCoprimes . splitIntoCoprimes++-- | This is an undefined behaviour, but at least it should not+-- throw exceptions or loop forever.+splitIntoCoprimesSpecialCase1 :: Assertion+splitIntoCoprimesSpecialCase1 =+  assertBool "should not fail" $ splitIntoCoprimesProperty4 @Integer [(0, 0), (0, 0)]++-- | This is an undefined behaviour, but at least it should not+-- throw exceptions or loop forever.+splitIntoCoprimesSpecialCase2 :: Assertion+splitIntoCoprimesSpecialCase2 =+  assertBool "should not fail" $ splitIntoCoprimesProperty4 @Integer [(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+  :: (Ord a, GcdDomain a)+  => [(a, Power Word)]+  -> [(a, Power Word)]+  -> Bool+unionProperty1 xs ys+  =  sort (unCoprimes (splitIntoCoprimes (xs' <> ys')))+  == sort (unCoprimes (splitIntoCoprimes xs' <> splitIntoCoprimes ys'))+  where+    xs' = map (second getPower) xs+    ys' = map (second getPower) ys++testSuite :: TestTree+testSuite = testGroup "Euclidean"+  [ testSameIntegralProperty "coprime"     coprimeProperty+  , testGroup "splitIntoCoprimes"+    [ testGroup "preserves product of factors"+      [ testSmallAndQuick "Natural" (splitIntoCoprimesProperty1 @Natural)+      , testSmallAndQuick "Integer" (splitIntoCoprimesProperty1 @Integer)+      , testSmallAndQuick "Gaussian" (splitIntoCoprimesProperty1 @GaussianInteger)+      ]+    , testGroup "number of factors is non-decreasing"+      [ testSmallAndQuick "Natural" (splitIntoCoprimesProperty2 @Natural)+      , testSmallAndQuick "Integer" (splitIntoCoprimesProperty2 @Integer)+      , testSmallAndQuick "Gaussian" (splitIntoCoprimesProperty2 @GaussianInteger)+      ]+    , testGroup "output factors are coprime"+      [ testSmallAndQuick "Natural" (splitIntoCoprimesProperty3 @Natural)+      , testSmallAndQuick "Integer" (splitIntoCoprimesProperty3 @Integer)+      , testSmallAndQuick "Gaussian" (splitIntoCoprimesProperty3 @GaussianInteger)+      ]+    , testGroup "does not freeze"+      [ testCase          "case 1"                   splitIntoCoprimesSpecialCase1+      , testCase          "case 2"                   splitIntoCoprimesSpecialCase2+      , testSmallAndQuick "Natural" (splitIntoCoprimesProperty4 @Natural)+      -- smallcheck for Integer and GaussianInteger takes too long+      , QC.testProperty "Integer" (splitIntoCoprimesProperty4 @Integer)+      , QC.testProperty "Gaussian" (splitIntoCoprimesProperty4 @GaussianInteger)+      ]+    , testGroup "output factors are non-unit"+      [ testSmallAndQuick "Natural" (splitIntoCoprimesProperty5 @Natural)+      -- smallcheck for Integer and GaussianInteger takes too long+      , QC.testProperty "Integer" (splitIntoCoprimesProperty5 @Integer)+      , QC.testProperty "Gaussian" (splitIntoCoprimesProperty5 @GaussianInteger)+      ]+    ]+  , 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+    ,  testGroup "property union"+      [ testSmallAndQuick "Natural" (unionProperty1 @Natural)+      -- smallcheck for Integer takes too long+      , QC.testProperty "Integer" (unionProperty1 @Integer)+      ]+    ]+  ]
− test-suite/Math/NumberTheory/GCD/LowLevelTests.hs 
@@ -1,74 +0,0 @@--- |--- Module:      Math.NumberTheory.GCD.LowLevelTests--- Copyright:   (c) 2016 Andrew Lelechenko--- Licence:     MIT--- Maintainer:  Andrew Lelechenko <andrew.lelechenko@gmail.com>--- 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#-  ]
− test-suite/Math/NumberTheory/GCDTests.hs 
@@ -1,50 +0,0 @@--- |--- Module:      Math.NumberTheory.GCDTests--- Copyright:   (c) 2016 Andrew Lelechenko--- Licence:     MIT--- Maintainer:  Andrew Lelechenko <andrew.lelechenko@gmail.com>--- Stability:   Provisional------ Tests for Math.NumberTheory.GCD-----{-# LANGUAGE ScopedTypeVariables #-}--{-# OPTIONS_GHC -fno-warn-type-defaults #-}--module Math.NumberTheory.GCDTests-  ( testSuite-  ) where--import Test.Tasty--import Data.Bits--import Math.NumberTheory.GCD-import Math.NumberTheory.TestUtils---- | Check that 'binaryGCD' matches 'gcd'.-binaryGCDProperty :: (Integral a, Bits a) => AnySign a -> AnySign a -> Bool-binaryGCDProperty (AnySign a) (AnySign b) = binaryGCD a b == gcd a b---- | Check that 'extendedGCD' is consistent with documentation.-extendedGCDProperty :: forall a. Integral a => AnySign a -> AnySign a -> Bool-extendedGCDProperty (AnySign a) (AnySign b) =-  u * a + v * b == d-  && d == gcd a b-  -- (-1) >= 0 is true for unsigned types-  && (abs u < abs b || abs b <= 1 || (-1 :: a) >= 0)-  && (abs v < abs a || abs a <= 1 || (-1 :: a) >= 0)-  where-    (d, u, v) = extendedGCD a b---- | Check that numbers are coprime iff their gcd equals to 1.-coprimeProperty :: (Integral a, Bits a) => AnySign a -> AnySign a -> Bool-coprimeProperty (AnySign a) (AnySign b) = coprime a b == (gcd a b == 1)--testSuite :: TestTree-testSuite = testGroup "GCD"-  [ testSameIntegralProperty "binaryGCD"   binaryGCDProperty-  , testSameIntegralProperty "extendedGCD" extendedGCDProperty-  , testSameIntegralProperty "coprime"     coprimeProperty-  ]
test-suite/Math/NumberTheory/GaussianIntegersTests.hs view
@@ -1,11 +1,11 @@ {-# OPTIONS_GHC -fno-warn-type-defaults #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}  -- | -- Module:      Math.NumberTheory.GaussianIntegersTests--- Copyright:   (c) 2016 Chris Fredrickson+-- Copyright:   (c) 2016 Chris Fredrickson, Google Inc. -- Licence:     MIT -- Maintainer:  Chris Fredrickson <chris.p.fredrickson@gmail.com>--- Stability:   Provisional -- -- Tests for Math.NumberTheory.GaussianIntegers --@@ -14,66 +14,180 @@   ( testSuite   ) where +import Prelude hiding (gcd, rem)+import Control.Monad (zipWithM_)+import Data.Euclidean+import Data.List (groupBy, sort)+import qualified Data.List.Infinite as Inf+import Data.Maybe (fromJust, mapMaybe)+import Data.Proxy+import Test.Tasty.QuickCheck as QC hiding (Positive(..), NonNegative(..))+import Test.QuickCheck.Classes import Test.Tasty import Test.Tasty.HUnit -import Math.NumberTheory.GaussianIntegers+import Math.NumberTheory.Quadratic.GaussianIntegers+import Math.NumberTheory.Moduli.Sqrt+import Math.NumberTheory.Roots (integerSquareRoot)+import Math.NumberTheory.Primes (Prime, unPrime, UniqueFactorisation(..)) import Math.NumberTheory.TestUtils +lazyCases :: [(GaussianInteger, [(Prime GaussianInteger, Word)])]+lazyCases =+  [ ( 14145130733+    * 10000000000000000000000000000000000000121+    * 100000000000000000000000000000000000000000000000447+    , [(fromJust $ isPrime $ 117058 :+ 21037, 1), (fromJust $ isPrime $ 21037 :+ 117058, 1)]+    )+  ]+ -- | Number is zero or is equal to the product of its factors.-factoriseProperty :: Integer -> Integer -> Bool-factoriseProperty 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 (\(p, k) -> unPrime p ^ k) factors +factoriseProperty2 :: GaussianInteger -> Bool+factoriseProperty2 z = z == 0 || all ((> 0) . snd) (factorise z)++factoriseProperty3 :: GaussianInteger -> Bool+factoriseProperty3 z = z == 0 || all ((> 1) . norm . unPrime . fst) (factorise z)++factoriseSpecialCase1 :: Assertion+factoriseSpecialCase1 = assertEqual "should be equal"+  [ (fromJust $ isPrime $ 3 :+ 0, 2)+  , (fromJust $ isPrime $ 1 :+ 2, 1)+  , (fromJust $ isPrime $ 2 :+ 3, 1)+  ]+  (factorise (63 :+ 36))++factoriseSpecialCase2 :: (GaussianInteger, [(Prime GaussianInteger, Word)]) -> Assertion+factoriseSpecialCase2 (n, fs) = zipWithM_ (assertEqual (show n)) fs (factorise n)++findPrimeReference :: Prime Integer -> GaussianInteger+findPrimeReference 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) : _ = [ (a', b') | (a', b') <- asbs, a' <= k]+    in a :+ b++findPrimeProperty1 :: Prime Integer -> Bool+findPrimeProperty1 p+  = unPrime p `mod` 4 /= (1 :: Integer)+  || p1 == p2+  || abs (p1 * p2) == fromInteger (unPrime p)+  where+    p1 = findPrimeReference p+    p2 = unPrime (findPrime 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-  || isPrime g && n == 1-  || not (isPrime g) && n /= 1+isPrimeProperty :: GaussianInteger -> Bool+isPrimeProperty 0 = True+isPrimeProperty g = case isPrime g of+  Nothing -> n /= 1+  Just{}  -> 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 $ mapMaybe isPrime [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 $ Inf.take 51 primes)+  where+    f :: [Prime GaussianInteger] -> [[Prime GaussianInteger]]+    f = map sort . groupBy (\g1 g2 -> norm (unPrime g1) == norm (unPrime g2))+ -- | The list of primes should include only primes.-primesGeneratesPrimesProperty :: NonNegative Int -> Bool-primesGeneratesPrimesProperty (NonNegative i) = isPrime (primes !! i)+primesGeneratesPrimesProperty :: Word -> Bool+primesGeneratesPrimesProperty i = case isPrime (unPrime (primes Inf.!! i) :: GaussianInteger) of+  Nothing -> False+  Just{}  -> True +-- | Check that primes generates the primes in order.+orderingPrimes :: Assertion+orderingPrimes = assertBool "primes are ordered" (and $ zipWith (<=) xs (drop 1 xs))+  where xs = map (norm . unPrime) $ Inf.take 1000 primes++numberOfPrimes :: Assertion+numberOfPrimes = assertEqual "counting primes: OEIS A091100"+  [16,100,668,4928,38404,313752]+  [4 * length (Inf.takeWhile ((<= 10^n) . norm . unPrime) primes) | n <- [1..6]]+ -- | 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] +-- | Verify that @rem@ produces a remainder smaller than the divisor with+-- regards to the Euclidean domain's function.+remProperty :: GaussianInteger -> GaussianInteger -> Bool+remProperty x y = (y == 0) || norm (x `rem` y) < norm y++gcdGProperty1 :: GaussianInteger -> GaussianInteger -> Bool+gcdGProperty1 z1 z2+  = z1 == 0 && z2 == 0+  || z1 `rem` z == 0 && z2 `rem` z == 0+  where+    z = gcd z1 z2++gcdGProperty2 :: GaussianInteger -> GaussianInteger -> GaussianInteger -> Bool+gcdGProperty2 z z1 z2+  = z == 0+  || gcd z1' z2' `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) $ gcd (12 :+ 23) (23 :+ 34) +gcdGSpecialCase2 :: Assertion+gcdGSpecialCase2 = assertEqual "gcdG" (0 :+ (-1)) $ gcd (0 :+ 3) (2 :+ 2)+ testSuite :: TestTree testSuite = testGroup "GaussianIntegers"-  [ testSmallAndQuick "factorise"         factoriseProperty-  , 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 (testCase "laziness" . factoriseSpecialCase2) 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+  , testSmallAndQuick "remProperty"              remProperty+  , testGroup "gcd"+    [ testSmallAndQuick "is divisor"            gcdGProperty1+    -- smallcheck takes too long+    , QC.testProperty   "is greatest"           gcdGProperty2+    , testCase          "(12 :+ 23) (23 :+ 34)" gcdGSpecialCase1+    , testCase          "(0 :+ 3) (2 :+ 2)"     gcdGSpecialCase2+    ]+  , lawsToTest $ gcdDomainLaws (Proxy :: Proxy GaussianInteger)+  , lawsToTest $ euclideanLaws (Proxy :: Proxy GaussianInteger)   ]
+ test-suite/Math/NumberTheory/Moduli/CbrtTests.hs view
@@ -0,0 +1,89 @@+-- |+-- Module:      Math.NumberTheory.Moduli.Cbrt+-- Copyright:   (c) 2020 Federico Bongiorno+-- Licence:     MIT+-- Maintainer:  Federico Bongiorno <federicobongiorno97@gmail.com>+--+-- Test for Math.NumberTheory.Moduli.Cbrt+--++module Math.NumberTheory.Moduli.CbrtTests+  ( testSuite+  ) where++import Math.NumberTheory.Moduli.Cbrt+import Math.NumberTheory.Quadratic.EisensteinIntegers+import Math.NumberTheory.Primes+import qualified Data.Euclidean as A+import Data.List (genericReplicate)+import Test.Tasty+import Math.NumberTheory.TestUtils++-- Checks multiplicative property of numerators. In details,+-- @cubicSymbol1 alpha1 alpha2 beta@ checks that+-- @(cubicSymbol alpha1 beta) <> (cubicSymbol alpha2 beta) == (cubicSymbol alpha1*alpha2 beta)@+cubicSymbol1 :: EisensteinInteger -> EisensteinInteger -> EisensteinInteger -> Bool+cubicSymbol1 alpha1 alpha2 beta = isBadDenominator beta || cubicSymbolNumerator alpha1 alpha2 beta++cubicSymbolNumerator :: EisensteinInteger -> EisensteinInteger -> EisensteinInteger -> Bool+cubicSymbolNumerator alpha1 alpha2 beta = (symbol1 <> symbol2) == symbolProduct+  where+    symbol1 = cubicSymbol alpha1 beta+    symbol2 = cubicSymbol alpha2 beta+    symbolProduct = cubicSymbol alphaProduct beta+    alphaProduct = alpha1 * alpha2++-- Checks multiplicative property of denominators. In details,+-- @cubicSymbol2 alpha beta1 beta2@ checks that+-- @(cubicSymbol alpha beta1) <> (cubicSymbol alpha beta2) == (cubicSymbol alpha beta1*beta2)@+cubicSymbol2 :: EisensteinInteger -> EisensteinInteger -> EisensteinInteger -> Bool+cubicSymbol2 alpha beta1 beta2 = isBadDenominator beta1 || isBadDenominator beta2 || cubicSymbolDenominator alpha beta1 beta2++cubicSymbolDenominator :: EisensteinInteger -> EisensteinInteger -> EisensteinInteger -> Bool+cubicSymbolDenominator alpha beta1 beta2 = (symbol1 <> symbol2) == symbolProduct+  where+    symbol1 = cubicSymbol alpha beta1+    symbol2 = cubicSymbol alpha beta2+    symbolProduct = cubicSymbol alpha betaProduct+    betaProduct = beta1 * beta2++-- Checks that `cubicSymbol` agrees with the computational definition+-- <https://en.wikipedia.org/wiki/Cubic_reciprocity#Definition here>+-- when the denominator is prime.+cubicSymbol3 :: EisensteinInteger -> Prime EisensteinInteger -> Bool+cubicSymbol3 alpha prime = isBadDenominator beta || cubicSymbol alpha beta == cubicSymbolPrime alpha beta+    where beta = unPrime prime++cubicSymbolPrime :: EisensteinInteger -> EisensteinInteger -> CubicSymbol+cubicSymbolPrime alpha beta = findCubicSymbol residue beta+  where+    residue = foldr f 1 listOfAlphas+    f x y = (x * y) `A.rem` beta+    listOfAlphas = genericReplicate alphaExponent alpha+    -- Exponent is defined to be 1/3*(@betaNorm@ - 1).+    alphaExponent = betaNorm `div` 3+    betaNorm = norm beta++isBadDenominator :: EisensteinInteger -> Bool+isBadDenominator x = modularNorm == 0+  where+    modularNorm = norm x `mod` 3++-- This complication is necessary because it may happen that the residue field+-- of @beta@ has characteristic two. In this case 1=-1 and the Euclidean algorithm+-- can return both. Therefore it is not enough to pattern match for the values+-- which give a well defined @cubicSymbol@.+findCubicSymbol :: EisensteinInteger -> EisensteinInteger -> CubicSymbol+findCubicSymbol residue beta+  | residue `A.rem` beta == 0             = Zero+  | (residue - ω) `A.rem` beta == 0       = Omega+  | (residue + 1 + ω) `A.rem` beta == 0   = OmegaSquare+  | (residue - 1) `A.rem` beta == 0       = One+  | otherwise                             = error "Math.NumberTheory.Moduli.Cbrt: invalid EisensteinInteger."++testSuite :: TestTree+testSuite = testGroup "CubicSymbol"+  [ testSmallAndQuick "multiplicative property of numerators" cubicSymbol1+  , testSmallAndQuick "multiplicative property of denominators" cubicSymbol2+  , testSmallAndQuick "cubic residue with prime denominator" cubicSymbol3+  ]
test-suite/Math/NumberTheory/Moduli/ChineseTests.hs view
@@ -3,46 +3,27 @@ -- Copyright:   (c) 2016 Andrew Lelechenko -- Licence:     MIT -- Maintainer:  Andrew Lelechenko <andrew.lelechenko@gmail.com>--- Stability:   Provisional -- -- Tests for Math.NumberTheory.Moduli.Chinese -- -{-# LANGUAGE CPP             #-}-{-# LANGUAGE ViewPatterns    #-}--{-# OPTIONS_GHC -fno-warn-type-defaults #-}- module Math.NumberTheory.Moduli.ChineseTests   ( testSuite   ) where  import Test.Tasty -import Control.Arrow-import Data.List (tails)--import Math.NumberTheory.Moduli hiding (invertMod)+import Math.NumberTheory.Moduli (chinese) import Math.NumberTheory.TestUtils --- | Check that 'chineseRemainder' is defined iff modulos are coprime.---   Also check that the result is a solution of input modular equations.-chineseRemainderProperty :: [(Integer, Positive Integer)] -> Bool-chineseRemainderProperty rms' = case chineseRemainder rms of-  Nothing -> not areCoprime-  Just n  -> areCoprime && map (n `mod`) ms == zipWith mod rs ms+chineseProperty :: Integer -> Positive Integer -> Integer -> Positive Integer -> Bool+chineseProperty n1 (Positive m1) n2 (Positive m2) = not compatible ||+  case chinese (n1, m1) (n2, m2) of+    Nothing -> not compatible+    Just (n, m) -> compatible && (n - n1) `rem` m1 == 0 && (n - n2) `rem` m2 == 0 && m == lcm m1 m2   where-    rms = map (second getPositive) rms'-    (rs, ms) = unzip rms-    areCoprime = all (== 1) [ gcd m1 m2 | (m1 : m2s) <- tails ms, m2 <- m2s ]---- | Check that 'chineseRemainder' matches 'chineseRemainder2'.-chineseRemainder2Property :: Integer -> Positive Integer -> Integer -> Positive Integer -> Bool-chineseRemainder2Property r1 (Positive m1) r2 (Positive m2) = gcd m1 m2 /= 1-  || Just (chineseRemainder2 (r1, m1) (r2, m2)) == chineseRemainder [(r1, m1), (r2, m2)]+    g = gcd m1 m2+    compatible = (n1 - n2) `rem` g == 0  testSuite :: TestTree-testSuite = testGroup "Chinese"-  [ testSmallAndQuick "chineseRemainder"  chineseRemainderProperty-  , testSmallAndQuick "chineseRemainder2" chineseRemainder2Property-  ]+testSuite = testSmallAndQuick "chinese" chineseProperty
test-suite/Math/NumberTheory/Moduli/ClassTests.hs view
@@ -3,13 +3,11 @@ -- Copyright:   (c) 2016 Andrew Lelechenko -- Licence:     MIT -- Maintainer:  Andrew Lelechenko <andrew.lelechenko@gmail.com>--- Stability:   Provisional -- -- Tests for Math.NumberTheory.Moduli.Class -- -{-# LANGUAGE CPP             #-}-{-# LANGUAGE ViewPatterns    #-}+{-# LANGUAGE DataKinds       #-}  {-# OPTIONS_GHC -fno-warn-type-defaults #-} @@ -18,8 +16,8 @@   ) where  import Test.Tasty+import qualified Test.Tasty.QuickCheck as QC -import Data.Bits import Data.Maybe import Numeric.Natural @@ -35,12 +33,12 @@ -- | Check that 'invertMod' inverts numbers modulo. invertModProperty :: AnySign Integer -> Positive Integer -> Bool invertModProperty (AnySign k) (Positive m) = case invertMod k m of-  Nothing            -> k `mod` m == 0 || gcd k m > 1+  Nothing            -> k `rem` m == 0 || gcd k m > 1   Just InfMod{}      -> False-  Just (SomeMod inv) -> gcd k m == 1 && k * getVal inv `mod` m == 1+  Just (SomeMod inv) -> gcd k m == 1 && k * getVal inv `mod` m == 1 `mod` m  -- | 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 +48,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@@ -95,6 +93,27 @@     m3 = toInteger $ m1 `gcd` m2     x3 = (x1 * x2) `mod` m3 +sameSomeModMulProperty :: Integer -> Integer -> Positive Natural -> Bool+sameSomeModMulProperty x1 x2 (Positive m) = case (x1 `modulo` m) * (x2 `modulo` m) of+  SomeMod z -> getMod z == toInteger m && getVal z == x3+  InfMod{}  -> False+  where+    x3 = (x1 * x2) `mod` toInteger m++sameSomeModMulHugeProperty :: Integer -> Integer -> Positive (Huge Natural) -> Bool+sameSomeModMulHugeProperty x1 x2 (Positive (Huge m)) = case (x1 `modulo` m) * (x2 `modulo` m) of+  SomeMod z -> getMod z == toInteger m && getVal z == x3+  InfMod{}  -> False+  where+    x3 = (x1 * x2) `mod` toInteger m++sameSomeModMulHugeAllProperty :: Huge Integer -> Huge Integer -> Positive (Huge Natural) -> Bool+sameSomeModMulHugeAllProperty (Huge x1) (Huge x2) (Positive (Huge m)) = case (x1 `modulo` m) * (x2 `modulo` m) of+  SomeMod z -> getMod z == toInteger m && getVal z == x3+  InfMod{}  -> False+  where+    x3 = (x1 * x2) `mod` toInteger m+ someModNegProperty :: Integer -> Positive Natural -> Bool someModNegProperty x1 (Positive m1) = case negate (x1 `modulo` m1) of   SomeMod z -> getMod z == m3 && getVal z == x3@@ -151,6 +170,11 @@       [ testSmallAndQuick "multiplicative by base"  powerModProperty2_Integer       , testSmallAndQuick "additive by exponent"    powerModProperty3_Integer       ]+    ]+  , testGroup "Same SomeMod"+    [ testSmallAndQuick "mul" sameSomeModMulProperty+    , QC.testProperty "mul huge" sameSomeModMulHugeProperty+    , QC.testProperty "mul huge all" sameSomeModMulHugeAllProperty     ]   , testGroup "SomeMod"     [ testSmallAndQuick "add" someModAddProperty
+ test-suite/Math/NumberTheory/Moduli/DiscreteLogarithmTests.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DataKinds #-}+{-# OPTIONS_GHC -fno-warn-type-defaults #-}++module Math.NumberTheory.Moduli.DiscreteLogarithmTests+  ( testSuite+  ) where++import Test.Tasty++import Data.Maybe+import Data.Mod+import Data.Proxy+import Data.Semigroup+import GHC.TypeNats (SomeNat(..), KnownNat, someNatVal)+import Numeric.Natural++import Math.NumberTheory.ArithmeticFunctions (totient)+import Math.NumberTheory.Moduli.Multiplicative+import Math.NumberTheory.Moduli.Singleton+import Math.NumberTheory.Primes+import Math.NumberTheory.TestUtils++nextPrimitiveRoot :: (KnownNat m, UniqueFactorisation a, Integral a) => CyclicGroup a m -> Mod m -> Maybe (PrimitiveRoot m)+nextPrimitiveRoot cg g = listToMaybe $ mapMaybe (isPrimitiveRoot cg) [g..g+100]++nextMultElement :: KnownNat m => Mod m -> Maybe (MultMod m)+nextMultElement g = listToMaybe $ mapMaybe isMultElement [g..g+100]++-- | 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) -> (/= Just False) $ do+      cg <- cyclicGroup :: Maybe (CyclicGroup Integer m)+      a' <- nextPrimitiveRoot cg (fromInteger a)+      b' <- nextMultElement (fromInteger b)+      return $ discreteLogarithm cg 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) -> (/= Just False) $ do+      cg <- cyclicGroup :: Maybe (CyclicGroup Integer m)+      a' <- nextPrimitiveRoot cg (fromInteger a)+      b' <- nextMultElement (fromInteger b)+      return $ discreteLogarithm cg 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) -> (/= Just False) $ do+      cg <- cyclicGroup :: Maybe (CyclicGroup Integer m)+      a'' <- nextPrimitiveRoot cg (fromInteger a)+      let a' = unPrimitiveRoot a''+      return $ discreteLogarithm cg 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'+  ]
+ test-suite/Math/NumberTheory/Moduli/EquationsTests.hs view
@@ -0,0 +1,54 @@+-- |+-- Module:      Math.NumberTheory.Moduli.EquationsTests+-- Copyright:   (c) 2018 Andrew Lelechenko+-- Licence:     MIT+-- Maintainer:  Andrew Lelechenko <andrew.lelechenko@gmail.com>+--++{-# LANGUAGE ScopedTypeVariables #-}++module Math.NumberTheory.Moduli.EquationsTests+  ( testSuite+  ) where++import Test.Tasty++import Data.List (sort)+import Data.Mod+import Data.Proxy+import GHC.TypeNats (KnownNat, SomeNat(..), someNatVal)+import Numeric.Natural++import Math.NumberTheory.Moduli (SomeMod(..))+import Math.NumberTheory.Moduli.Equations+import Math.NumberTheory.Moduli.Singleton+import Math.NumberTheory.TestUtils++wrapSome :: KnownNat m => ([Mod m], [Mod m]) -> ([SomeMod], [SomeMod])+wrapSome (xs, ys) = (map SomeMod xs, map SomeMod ys)++solveLinearProp :: KnownNat m => Mod m -> Mod m -> ([Mod m], [Mod m])+solveLinearProp a b =+  ( sort (solveLinear a b)+  , filter (\x -> a * x + b == 0) [minBound .. maxBound]+  )++solveLinearProperty1 :: (Positive Natural, Integer, Integer) -> ([SomeMod], [SomeMod])+solveLinearProperty1 (Positive m, a, b) = case someNatVal m of+  SomeNat (_ :: Proxy t) -> wrapSome $ solveLinearProp (fromInteger a :: Mod t) (fromInteger b)++solveQuadraticProp :: KnownNat m => Mod m -> Mod m -> Mod m -> ([Mod m], [Mod m])+solveQuadraticProp a b c =+  ( sort (solveQuadratic sfactors a b c)+  , filter (\x -> a * x * x + b * x + c == 0) [minBound .. maxBound]+  )++solveQuadraticProperty1 :: (Positive Natural, Integer, Integer, Integer) -> ([SomeMod], [SomeMod])+solveQuadraticProperty1 (Positive m, a, b, c) = case someNatVal m of+  SomeNat (_ :: Proxy t) -> wrapSome $ solveQuadraticProp (fromInteger a :: Mod t) (fromInteger b) (fromInteger c)++testSuite :: TestTree+testSuite = testGroup "Equations"+  [ testEqualSmallAndQuick "solveLinear"    solveLinearProperty1+  , testEqualSmallAndQuick "solveQuadratic" solveQuadraticProperty1+  ]
test-suite/Math/NumberTheory/Moduli/JacobiTests.hs view
@@ -3,14 +3,10 @@ -- Copyright:   (c) 2016 Andrew Lelechenko -- Licence:     MIT -- Maintainer:  Andrew Lelechenko <andrew.lelechenko@gmail.com>--- Stability:   Provisional -- -- Tests for Math.NumberTheory.Moduli.Jacobi -- -{-# LANGUAGE CPP                        #-}-{-# LANGUAGE ViewPatterns               #-}- {-# OPTIONS_GHC -fno-warn-type-defaults #-}  module Math.NumberTheory.Moduli.JacobiTests@@ -20,9 +16,8 @@ import Test.Tasty  import Data.Bits-import Data.Semigroup -import Math.NumberTheory.Moduli hiding (invertMod)+import Math.NumberTheory.Moduli.Sqrt import Math.NumberTheory.TestUtils  -- https://en.wikipedia.org/wiki/Jacobi_symbol#Properties, item 2@@ -38,29 +33,60 @@   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_Integer :: AnySign Integer -> AnySign Integer -> (MyCompose Positive Odd) Integer -> Bool-jacobiProperty4_Integer = jacobiProperty4+jacobiProperty4 (AnySign a) (AnySign b) (MyCompose (Positive (Odd n))) =+  doesProductOverflow a b ||+  jacobi (a * b) n == jacobi a n <> jacobi b n  -- 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_Integer :: AnySign Integer -> (MyCompose Positive Odd) Integer -> (MyCompose Positive Odd) Integer -> Bool-jacobiProperty5_Integer = jacobiProperty5+jacobiProperty5 (AnySign a) (MyCompose (Positive (Odd m))) (MyCompose (Positive (Odd n))) =+  doesProductOverflow m n ||+  jacobi a (m * n) == jacobi a m <> jacobi a n  -- 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-  , testSameIntegralProperty "law of quadratic reciprocity" jacobiProperty6+  [ testSameIntegralProperty  "same modulo n"                jacobiProperty2+  , testSameIntegralProperty  "consistent with gcd"          jacobiProperty3+  , testSameIntegralProperty3 "multiplicative 1"             jacobiProperty4+  , testSameIntegralProperty3 "multiplicative 2"             jacobiProperty5+  , testSameIntegralProperty  "law of quadratic reciprocity" jacobiProperty6+  , testSmallAndQuick         "-1 Int"                       jacobiProperty7_Int+  , testSmallAndQuick         "-1 Integer"                   jacobiProperty7_Integer+  , testIntegralProperty      "2"                            jacobiProperty8+  , testSmallAndQuick         "minBound Int"                 jacobiProperty9_Int   ]
+ test-suite/Math/NumberTheory/Moduli/PrimitiveRootTests.hs view
@@ -0,0 +1,125 @@+-- |+-- Module:      Math.NumberTheory.Moduli.PrimitiveRootTests+-- Copyright:   (c) 2017 Andrew Lelechenko+-- Licence:     MIT+-- Maintainer:  Andrew Lelechenko <andrew.lelechenko@gmail.com>+--+-- Tests for Math.NumberTheory.Moduli.PrimitiveRoot+--++{-# LANGUAGE ScopedTypeVariables #-}++{-# OPTIONS_GHC -fno-warn-type-defaults #-}++module Math.NumberTheory.Moduli.PrimitiveRootTests+  ( testSuite+  ) where++import Prelude hiding (gcd)+import Test.Tasty+import Test.Tasty.HUnit++import Data.Euclidean+import Data.List (genericTake, genericLength)+import Data.Maybe (isJust, isNothing, mapMaybe)+import Data.Mod+import Data.Proxy+import qualified Data.Set as S+import GHC.TypeNats (SomeNat(..), someNatVal)+import Numeric.Natural++import Math.NumberTheory.ArithmeticFunctions (totient)+import Math.NumberTheory.Moduli.Multiplicative+import Math.NumberTheory.Moduli.Singleton+import Math.NumberTheory.Primes+import Math.NumberTheory.TestUtils++cyclicGroupProperty1 :: (Euclidean a, Integral a, UniqueFactorisation a) => Positive a -> Bool+cyclicGroupProperty1 (Positive n) = case cyclicGroupFromModulo n of+  Nothing -> True+  Just (Some cg) -> factorBack (unSFactors (cyclicGroupToSFactors cg)) == n++-- | Multiplicative groups modulo primes are always cyclic.+cyclicGroupProperty2 :: (Integral a, UniqueFactorisation a) => Positive a -> Bool+cyclicGroupProperty2 (Positive n) = case isPrime n of+  Nothing -> True+  Just _  -> isJust (cyclicGroupFromModulo n)++-- | Multiplicative groups modulo double primes are always cyclic.+cyclicGroupProperty3 :: (Integral a, UniqueFactorisation a) => Positive a -> Bool+cyclicGroupProperty3 (Positive n) = case isPrime n of+  Nothing -> True+  Just _  -> 2 * n < n {- overflow check -}+          || isJust (cyclicGroupFromModulo n)++cyclicGroupSpecialCase1 :: Assertion+cyclicGroupSpecialCase1 = assertBool "should be non-cyclic" $ isNothing $ cyclicGroupFromModulo (8 :: Integer)++allUnique :: Ord a => [a] -> Bool+allUnique = go S.empty+  where+    go _ []         = True+    go acc (x : xs) = not (x `S.member` acc) && go (S.insert x acc) xs++isPrimitiveRoot'Property1+  :: forall a. (Euclidean a, Integral a, UniqueFactorisation a)+  => AnySign a+  -> Positive Natural+  -> Bool+isPrimitiveRoot'Property1 (AnySign n) (Positive m) = case someNatVal m of+  SomeNat (_ :: Proxy m) -> case cyclicGroup :: Maybe (CyclicGroup a m) of+    Nothing -> True+    Just cg -> case isPrimitiveRoot cg (fromIntegral n) of+      Nothing -> True+      Just rt -> gcd m (unMod (multElement (unPrimitiveRoot rt))) == 1++isPrimitiveRootProperty1 :: AnySign Integer -> Positive Natural -> Bool+isPrimitiveRootProperty1 (AnySign n) (Positive m) = case someNatVal m of+  SomeNat (_ :: Proxy m) -> case cyclicGroup :: Maybe (CyclicGroup Integer m) of+    Nothing -> True+    Just cg -> gcd n (toInteger m) == 1+            || isNothing (isPrimitiveRoot cg (fromInteger n))++isPrimitiveRootProperty2 :: Positive Natural -> Bool+isPrimitiveRootProperty2 (Positive m) = case someNatVal m of+  SomeNat (_ :: Proxy m) -> case cyclicGroup :: Maybe (CyclicGroup Integer m) of+    Nothing -> True+    Just cg -> any (isJust . isPrimitiveRoot cg) [minBound..maxBound]++isPrimitiveRootProperty3 :: AnySign Integer -> Positive Natural -> Bool+isPrimitiveRootProperty3 (AnySign n) (Positive m) = case someNatVal m of+  SomeNat (_ :: Proxy m) -> case cyclicGroup :: Maybe (CyclicGroup Integer m) of+    Nothing -> True+    Just cg -> let n' = fromInteger n+      in isNothing (isPrimitiveRoot cg n')+      || allUnique (genericTake (totient m - 1) (iterate (* n') 1))++isPrimitiveRootProperty5 :: Positive Natural -> Bool+isPrimitiveRootProperty5 (Positive m) = case someNatVal m of+  SomeNat (_ :: Proxy m) -> case cyclicGroup :: Maybe (CyclicGroup Integer m) of+    Nothing -> True+    Just cg -> genericLength (mapMaybe (isPrimitiveRoot cg) [minBound..maxBound]) == totient (totient m)++testSuite :: TestTree+testSuite = testGroup "Primitive root"+  [ testGroup "CyclicGroup"+    [ testIntegralProperty "cyclicGroupFromModulo" cyclicGroupProperty1+    , testIntegralProperty "cyclic group mod p" cyclicGroupProperty2+    , testIntegralProperty "cyclic group mod 2p" cyclicGroupProperty3+    , testCase "cyclic group mod 8" cyclicGroupSpecialCase1+    ]+  , testGroup "isPrimitiveRoot'"+    [ testGroup "primitive root is coprime with modulo"+      [ testSmallAndQuick "Integer" (isPrimitiveRoot'Property1 :: AnySign Integer -> Positive Natural -> Bool)+      , testSmallAndQuick "Natural" (isPrimitiveRoot'Property1 :: AnySign Natural -> Positive Natural -> Bool)+      , testSmallAndQuick "Int"     (isPrimitiveRoot'Property1 :: AnySign Int     -> Positive Natural -> Bool)+      , testSmallAndQuick "Word"    (isPrimitiveRoot'Property1 :: AnySign Word    -> Positive Natural -> Bool)+      ]+    ]+  , 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 "cyclic group has right number of primitive roots" isPrimitiveRootProperty5+    ]+  ]
+ test-suite/Math/NumberTheory/Moduli/SingletonTests.hs view
@@ -0,0 +1,46 @@+-- |+-- Module:      Math.NumberTheory.Moduli.SingletonTests+-- Copyright:   (c) 2019 Andrew Lelechenko+-- Licence:     MIT+-- Maintainer:  Andrew Lelechenko <andrew.lelechenko@gmail.com>+--+-- Tests for Math.NumberTheory.Moduli.Singleton+--++{-# LANGUAGE TypeApplications #-}++{-# OPTIONS_GHC -fno-warn-type-defaults #-}++module Math.NumberTheory.Moduli.SingletonTests+  ( testSuite+  ) where++import Test.Tasty++import qualified Data.Map as M++import Math.NumberTheory.Moduli.Singleton+import Math.NumberTheory.Primes+import Math.NumberTheory.TestUtils++someSFactorsProperty1+  :: (Ord a, Num a)+  => [(Prime a, Word)]+  -> Bool+someSFactorsProperty1 xs = case someSFactors xs of+  Some sm -> unSFactors sm == M.assocs (M.fromListWith (+) xs)++cyclicGroupFromModuloProperty1+  :: (Integral a, UniqueFactorisation a)+  => Positive a+  -> Bool+cyclicGroupFromModuloProperty1 (Positive m) = mcg1 == mcg2+  where+    mcg1 = cyclicGroupFromModulo m+    mcg2 = cyclicGroupFromFactors (factorise m)++testSuite :: TestTree+testSuite = testGroup "Singleton"+  [ testSmallAndQuick "unSFactors . someSFactors = id" (someSFactorsProperty1 @Integer)+  , testIntegralPropertyNoLarge "cyclicGroupFromModulo = cyclicGroupFromFactors . factorise" cyclicGroupFromModuloProperty1+  ]
test-suite/Math/NumberTheory/Moduli/SqrtTests.hs view
@@ -3,15 +3,14 @@ -- Copyright:   (c) 2016 Andrew Lelechenko -- Licence:     MIT -- Maintainer:  Andrew Lelechenko <andrew.lelechenko@gmail.com>--- Stability:   Provisional -- -- Tests for Math.NumberTheory.Moduli.Sqrt -- -{-# LANGUAGE CPP             #-} {-# LANGUAGE ViewPatterns    #-}  {-# OPTIONS_GHC -fno-warn-type-defaults #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}  module Math.NumberTheory.Moduli.SqrtTests   ( testSuite@@ -20,102 +19,217 @@ import Test.Tasty import Test.Tasty.HUnit -import Data.List (nub)+import Control.Arrow+import Data.List (sort)+import qualified Data.List.NonEmpty as NE+import Data.Maybe (fromJust, listToMaybe)+import Numeric.Natural  import Math.NumberTheory.Moduli hiding (invertMod)+import Math.NumberTheory.Primes (unPrime, isPrime, Prime) import Math.NumberTheory.TestUtils -unwrapPP :: (Prime, Power Int) -> (Integer, Int)-unwrapPP (Prime p, Power e) = (p, e)+unwrapPP :: (Prime Integer, Power Word) -> (Prime Integer, Word)+unwrapPP (p, Power e) = (p, e `mod` 5) +nubOrd :: Ord a => [a] -> [a]+nubOrd = map NE.head . NE.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 -> Prime -> Bool-sqrtModPProperty (AnySign n) (Prime 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 -> Prime Integer -> Bool+sqrtsModPrimeProperty1 (AnySign n) p'@(unPrime -> p) = case sqrtsModPrime n p' of+  []     -> jacobi n p == MinusOne+  rt : _ -> (p == 2 || jacobi n p /= MinusOne) && (rt ^ 2 - n) `rem` p == 0 -sqrtModPListProperty :: AnySign Integer -> Prime -> Bool-sqrtModPListProperty (AnySign n) (Prime p) = all (\rt -> rt ^ 2 `mod` p == n `mod` p) (sqrtModPList n p)+sqrtsModPrimeProperty2 :: AnySign Integer -> Prime Integer -> Bool+sqrtsModPrimeProperty2 (AnySign n) p'@(unPrime -> p) = all (\rt -> (rt ^ 2 - n) `rem` p == 0) (sqrtsModPrime n p') -sqrtModP'Property :: Positive Integer -> Prime -> Bool-sqrtModP'Property (Positive n) (Prime p) = (p /= 2 && jacobi n p /= One) || rt ^ 2 `mod` p == n `mod` p+sqrtsModPrimeProperty3 :: AnySign Integer -> Prime Integer -> Bool+sqrtsModPrimeProperty3 (AnySign n) p'@(unPrime -> p) = nubOrd rts == sort rts   where-    rt = sqrtModP' n p+    rts = map (`mod` p) $ sqrtsModPrime n p' -tonelliShanksProperty1 :: Positive Integer -> Prime -> Bool-tonelliShanksProperty1 (Positive n) (Prime p) = p `mod` 4 /= 1 || jacobi n p /= One || rt ^ 2 `mod` p == n `mod` p+sqrtsModPrimeProperty4 :: AnySign Integer -> Prime Integer -> Bool+sqrtsModPrimeProperty4 (AnySign n) p'@(unPrime -> p) = all (\rt -> rt >= 0 && rt < p) (sqrtsModPrime n p')++tonelliShanksProperty1 :: Positive Integer -> Prime Integer -> Bool+tonelliShanksProperty1 (Positive n) 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 :: Prime -> Bool-tonelliShanksProperty2 (Prime p) = p `mod` 4 /= 1 || rt ^ 2 `mod` p == n `mod` p+tonelliShanksProperty2 :: Prime Integer -> Bool+tonelliShanksProperty2 p'@(unPrime -> p) = p `mod` 4 /= 1 || (rt ^ 2 - n) `rem` p == 0   where-    n  = head $ filter (\s -> jacobi s p == One) [2..p-1]-    rt = tonelliShanks n p+    n : _ = filter (\s -> jacobi s p == One) [2..p-1]+    rt : _ = sqrtsModPrime n p' +tonelliShanksProperty3 :: Prime Integer -> Bool+tonelliShanksProperty3 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+  assertEqual "OEIS A002224" (map Just [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 (listToMaybe . sqrtsModPrime 2 . fromJust . isPrime) ps -sqrtModPPProperty :: AnySign Integer -> (Prime, Power Int) -> Bool-sqrtModPPProperty (AnySign n) (Prime 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 -> (Prime Integer, Power Word) -> Bool+sqrtsModPrimePowerProperty1 (AnySign n) (p'@(unPrime -> p), Power e) = gcd n p > 1+  || all (\rt -> (rt ^ 2 - n) `rem` (p ^ e) == 0) (sqrtsModPrimePower n p' e) -sqrtModPPBase2Property :: AnySign Integer -> Power Int -> Bool-sqrtModPPBase2Property n e = sqrtModPPProperty n (Prime 2, e)+sqrtsModPrimePowerProperty2 :: AnySign Integer -> Power Word -> Bool+sqrtsModPrimePowerProperty2 n e = sqrtsModPrimePowerProperty1 n (fromJust $ isPrime (2 :: Integer), e) -sqrtModPPSpecialCase1 :: Assertion-sqrtModPPSpecialCase1 =-  assertEqual "sqrtModPP 16 2 2 = 4" (Just 0) (sqrtModPP 16 (2, 2))+sqrtsModPrimePowerProperty3 :: AnySign Integer -> (Prime Integer, Power Word) -> Bool+sqrtsModPrimePowerProperty3 (AnySign n) (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 (fromJust $ isPrime (2 :: Integer), e) -sqrtModPPListProperty :: AnySign Integer -> (Prime, Power Int) -> Bool-sqrtModPPListProperty (AnySign n) (Prime 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 -> (Prime Integer, Power Word) -> Bool+sqrtsModPrimePowerProperty5 (AnySign n) (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 -> [(Prime, 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 (fromJust $ isPrime (2 :: Integer), e) -sqrtModFListProperty :: AnySign Integer -> [(Prime, Power Int)] -> Bool-sqrtModFListProperty (AnySign n) (map unwrapPP -> pes)-  = nub ps /= ps || all-    (\rt -> all (\(p, e) -> rt ^ 2 `mod` (p ^ e) == n `mod` (p ^ e)) pes)-    (sqrtModFList n pes)+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 -> [(Prime 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 - n) `rem` (p ^ e) == 0) 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 -> [(Prime 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 (uncurry (^)) pes+    rts = map (`mod` m) $ take 1000 $ sqrtsModFactorisation n pes' +sqrtsModFactorisationProperty3 :: AnySign Integer -> [(Prime 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 (uncurry (^)) 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 sfactors 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+    ]   ]
− test-suite/Math/NumberTheory/MoebiusInversion/IntTests.hs 
@@ -1,53 +0,0 @@--- |--- Module:      Math.NumberTheory.MoebiusInversion.IntTests--- Copyright:   (c) 2016 Andrew Lelechenko--- Licence:     MIT--- Maintainer:  Andrew Lelechenko <andrew.lelechenko@gmail.com>--- Stability:   Provisional------ Tests for Math.NumberTheory.MoebiusInversion.Int-----{-# OPTIONS_GHC -fno-warn-type-defaults #-}--module Math.NumberTheory.MoebiusInversion.IntTests-  ( testSuite-  ) where--import Test.Tasty-import Test.Tasty.HUnit-import Test.Tasty.QuickCheck as QC hiding (Positive)--import Math.NumberTheory.MoebiusInversion.Int-import Math.NumberTheory.ArithmeticFunctions-import Math.NumberTheory.TestUtils--totientSumProperty :: Positive Int -> Bool-totientSumProperty (Positive n) = toInteger (totientSum n) == sum (map totient [1 .. toInteger n])--totientSumSpecialCase1 :: Assertion-totientSumSpecialCase1 = assertEqual "totientSum" 4496 (totientSum 121)--totientSumSpecialCase2 :: Assertion-totientSumSpecialCase2 = assertEqual "totientSum" 0 (totientSum (-9001))--totientSumZero :: Assertion-totientSumZero = assertEqual "totientSum" 0 (totientSum 0)--generalInversionProperty :: (Int -> Int) -> Positive Int -> Bool-generalInversionProperty g (Positive n)-  =  g n == sum [f (n `quot` k) | k <- [1 .. n]]-  && f n == sum [fromInteger (moebius (toInteger k)) * g (n `quot` k) | k <- [1 .. n]]-  where-    f = generalInversion g--testSuite :: TestTree-testSuite = testGroup "Int"-  [ testGroup "totientSum"-    [ testSmallAndQuick "matches definitions" totientSumProperty-    , testCase          "special case 1"      totientSumSpecialCase1-    , testCase          "special case 2"      totientSumSpecialCase2-    , testCase          "zero"                totientSumZero-    ]-  , QC.testProperty "generalInversion" generalInversionProperty-  ]
test-suite/Math/NumberTheory/MoebiusInversionTests.hs view
@@ -3,7 +3,6 @@ -- Copyright:   (c) 2016 Andrew Lelechenko -- Licence:     MIT -- Maintainer:  Andrew Lelechenko <andrew.lelechenko@gmail.com>--- Stability:   Provisional -- -- Tests for Math.NumberTheory.MoebiusInversion --@@ -18,35 +17,37 @@ import Test.Tasty.HUnit import Test.Tasty.QuickCheck as QC hiding (Positive) +import Data.Proxy+import Data.Vector.Unboxed (Vector)+ import Math.NumberTheory.MoebiusInversion import Math.NumberTheory.ArithmeticFunctions import Math.NumberTheory.TestUtils -totientSumProperty :: Positive Int -> Bool-totientSumProperty (Positive n) = totientSum n == sum (map totient [1 .. toInteger n])+proxy :: Proxy Vector+proxy = Proxy -totientSumSpecialCase1 :: Assertion-totientSumSpecialCase1 = assertEqual "totientSum" 4496 (totientSum 121)+totientSumProperty :: AnySign Word -> Bool+totientSumProperty (AnySign n) = (totientSum proxy n :: Word) == sum (map totient [1..n]) -totientSumSpecialCase2 :: Assertion-totientSumSpecialCase2 = assertEqual "totientSum" 0 (totientSum (-9001))+totientSumSpecialCase1 :: Assertion+totientSumSpecialCase1 = assertEqual "totientSum" 4496 (totientSum proxy 121 :: Word)  totientSumZero :: Assertion-totientSumZero = assertEqual "totientSum" 0 (totientSum 0)+totientSumZero = assertEqual "totientSum" 0 (totientSum proxy 0 :: Word) -generalInversionProperty :: (Int -> Integer) -> Positive Int -> Bool+generalInversionProperty :: (Word -> Word) -> Positive Word -> Bool generalInversionProperty g (Positive n)   =  g n == sum [f (n `quot` k) | k <- [1 .. n]]-  && f n == sum [moebius (toInteger k) * g (n `quot` k) | k <- [1 .. n]]+  && f n == sum [runMoebius (moebius k) * g (n `quot` k) | k <- [1 .. n]]   where-    f = generalInversion g+    f = generalInversion proxy g  testSuite :: TestTree testSuite = testGroup "MoebiusInversion"   [ testGroup "totientSum"     [ testSmallAndQuick "matches definitions" totientSumProperty     , testCase          "special case 1"      totientSumSpecialCase1-    , testCase          "special case 2"      totientSumSpecialCase2     , testCase          "zero"                totientSumZero     ]   , QC.testProperty "generalInversion" generalInversionProperty
− test-suite/Math/NumberTheory/Powers/CubesTests.hs 
@@ -1,156 +0,0 @@--- |--- Module:      Math.NumberTheory.Powers.CubesTests--- Copyright:   (c) 2016 Andrew Lelechenko--- Licence:     MIT--- Maintainer:  Andrew Lelechenko <andrew.lelechenko@gmail.com>--- Stability:   Provisional------ Tests for Math.NumberTheory.Powers.Cubes-----{-# LANGUAGE CPP #-}--{-# OPTIONS_GHC -fno-warn-type-defaults #-}--module Math.NumberTheory.Powers.CubesTests-  ( testSuite-  ) where--import Test.Tasty-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--#include "MachDeps.h"---- | Check that 'integerCubeRoot' returns the largest integer @m@ with @m^3 <= n@.------ (m + 1) ^ 3 /= n && cond--- means--- (m + 1) ^ 3 > n--- but without overflow for bounded types-integerCubeRootProperty :: Integral a => AnySign a -> Bool-integerCubeRootProperty (AnySign n) = m ^ 3 <= n && (m + 1) ^ 3 /= n && cond-  where-    m = integerCubeRoot n-    cond-      | m == -1   = n == -1-      | m < 0     = (m + 1) ^ 2 <= n `div` (m + 1)-      | otherwise = (m + 1) ^ 2 >= n `div` (m + 1)---- | Specialized to trigger 'cubeRootInt''.-integerCubeRootProperty_Int :: AnySign Int -> Bool-integerCubeRootProperty_Int = integerCubeRootProperty---- | Specialized to trigger 'cubeRootWord'.-integerCubeRootProperty_Word :: AnySign Word -> Bool-integerCubeRootProperty_Word = integerCubeRootProperty---- | Specialized to trigger 'cubeRootIgr'.-integerCubeRootProperty_Integer :: AnySign Integer -> Bool-integerCubeRootProperty_Integer = integerCubeRootProperty---- | Check that 'integerCubeRoot' returns the largest integer @m@ with @m^3 <= n@, , where @n@ has form @k@^3-1.-integerCubeRootProperty2 :: Integral a => AnySign a -> Bool-integerCubeRootProperty2 (AnySign k) = m ^ 3 <= n && (m + 1) ^ 3 /= n && cond-  where-    n = k ^ 3 - 1-    m = integerCubeRoot n-    cond-      | m == -1   = n == -1-      | m < 0     = (m + 1) ^ 2 <= n `div` (m + 1)-      | otherwise = (m + 1) ^ 2 >= n `div` (m + 1)---- | Specialized to trigger 'cubeRootInt''.-integerCubeRootProperty2_Int :: AnySign Int -> Bool-integerCubeRootProperty2_Int = integerCubeRootProperty2---- | Specialized to trigger 'cubeRootWord'.-integerCubeRootProperty2_Word :: AnySign Word -> Bool-integerCubeRootProperty2_Word = integerCubeRootProperty2--#if WORD_SIZE_IN_BITS == 64---- | Check that 'integerCubeRoot' of 2^63-1 is 2^21-1, not 2^21.-integerCubeRootSpecialCase1_Int :: Assertion-integerCubeRootSpecialCase1_Int =-  assertEqual "integerCubeRoot" (integerCubeRoot (maxBound :: Int)) (2 ^ 21 - 1)---- | Check that 'integerCubeRoot' of 2^63-1 is 2^21-1, not 2^21.-integerCubeRootSpecialCase1_Word :: Assertion-integerCubeRootSpecialCase1_Word =-  assertEqual "integerCubeRoot" (integerCubeRoot (maxBound `div` 2 :: Word)) (2 ^ 21 - 1)---- | Check that 'integerCubeRoot' of 2^64-1 is 2642245.-integerCubeRootSpecialCase2 :: Assertion-integerCubeRootSpecialCase2 =-  assertEqual "integerCubeRoot" (integerCubeRoot (maxBound :: Word)) 2642245--#endif---- | Check that 'integerCubeRoot'' returns the largest integer @m@ with @m^3 <= n@.-integerCubeRoot'Property :: Integral a => NonNegative a -> Bool-integerCubeRoot'Property (NonNegative n) = m ^ 3 <= n && (m + 1) ^ 3 /= n && (m + 1) ^ 2 >= n `div` (m + 1)-  where-    m = integerCubeRoot' n---- | Check that the number 'isCube' iff its 'integerCubeRoot' is exact.-isCubeProperty :: Integral a => AnySign a -> Bool-isCubeProperty (AnySign n) = (n /= m ^ 3 && not t) || (n == m ^ 3 && t)-  where-    t = isCube n-    m = integerCubeRoot n---- | Check that the number 'isCube'' iff its 'integerCubeRoot'' is exact.-isCube'Property :: Integral a => NonNegative a -> Bool-isCube'Property (NonNegative n) = (n /= m ^ 3 && not t) || (n == m ^ 3 && t)-  where-    t = isCube' n-    m = integerCubeRoot' n---- | Check that 'exactCubeRoot' returns an exact integer cubic root--- and is consistent with 'isCube'.-exactCubeRootProperty :: Integral a => AnySign a -> Bool-exactCubeRootProperty (AnySign n) = case exactCubeRoot n of-  Nothing -> not (isCube n)-  Just m  -> isCube n && n == m ^ 3---- | Check that 'isPossibleCube' is consistent with 'exactCubeRoot'.-isPossibleCubeProperty :: Integral a => NonNegative a -> Bool-isPossibleCubeProperty (NonNegative n) = t || not t && isNothing m-  where-    t = isPossibleCube n-    m = exactCubeRoot n--testSuite :: TestTree-testSuite = testGroup "Cubes"-  [ testGroup "integerCubeRoot"-    [ testIntegralProperty "generic"         integerCubeRootProperty-    , testSmallAndQuick    "generic Int"     integerCubeRootProperty_Int-    , testSmallAndQuick    "generic Word"    integerCubeRootProperty_Word-    , testSmallAndQuick    "generic Integer" integerCubeRootProperty_Integer--    , testIntegralProperty "almost cube"      integerCubeRootProperty2-    , testSmallAndQuick    "almost cube Int"  integerCubeRootProperty2_Int-    , testSmallAndQuick    "almost cube Word" integerCubeRootProperty2_Word--#if WORD_SIZE_IN_BITS == 64-    , testCase             "maxBound :: Int"      integerCubeRootSpecialCase1_Int-    , testCase             "maxBound / 2 :: Word" integerCubeRootSpecialCase1_Word-    , testCase             "maxBound :: Word"     integerCubeRootSpecialCase2-#endif-    ]-  , testIntegralProperty "integerCubeRoot'" integerCubeRoot'Property-  , testIntegralProperty "isCube"           isCubeProperty-  , testIntegralProperty "isCube'"          isCube'Property-  , testIntegralProperty "exactCubeRoot"    exactCubeRootProperty-  , testIntegralProperty "isPossibleCube"   isPossibleCubeProperty-  ]
− test-suite/Math/NumberTheory/Powers/FourthTests.hs 
@@ -1,147 +0,0 @@--- |--- Module:      Math.NumberTheory.Powers.FourthTests--- Copyright:   (c) 2016 Andrew Lelechenko--- Licence:     MIT--- Maintainer:  Andrew Lelechenko <andrew.lelechenko@gmail.com>--- Stability:   Provisional------ Tests for Math.NumberTheory.Powers.Fourth-----{-# LANGUAGE CPP #-}--{-# OPTIONS_GHC -fno-warn-type-defaults #-}--module Math.NumberTheory.Powers.FourthTests-  ( testSuite-  ) where--import Test.Tasty-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--#include "MachDeps.h"---- | Check that 'integerFourthRoot' returns the largest integer @m@ with @m^4 <= n@.------ (m + 1) ^ 4 /= n && (m + 1) ^ 3 >= n `div` (m + 1)--- means--- (m + 1) ^ 4 > n--- but without overflow for bounded types-integerFourthRootProperty :: Integral a => NonNegative a -> Bool-integerFourthRootProperty (NonNegative n) = m >= 0 && m ^ 4 <= n && (m + 1) ^ 4 /= n && (m + 1) ^ 3 >= n `div` (m + 1)-  where-    m = integerFourthRoot n---- | Specialized to trigger 'biSqrtInt'.-integerFourthRootProperty_Int :: NonNegative Int -> Bool-integerFourthRootProperty_Int = integerFourthRootProperty---- | Specialized to trigger 'biSqrtWord'.-integerFourthRootProperty_Word :: NonNegative Word -> Bool-integerFourthRootProperty_Word = integerFourthRootProperty---- | Specialized to trigger 'biSqrtIgr'.-integerFourthRootProperty_Integer :: NonNegative Integer -> Bool-integerFourthRootProperty_Integer = integerFourthRootProperty---- | Check that 'integerFourthRoot' returns the largest integer @m@ with @m^4 <= n@, , where @n@ has form @k@^4-1.-integerFourthRootProperty2 :: Integral a => NonNegative a -> Bool-integerFourthRootProperty2 (NonNegative k) = n < 0 || m >= 0 && m ^ 4 <= n && (m + 1) ^ 4 /= n && (m + 1) ^ 3 >= n `div` (m + 1)-  where-    n = k ^ 4 - 1-    m = integerFourthRoot n---- | Specialized to trigger 'biSqrtInt.-integerFourthRootProperty2_Int :: NonNegative Int -> Bool-integerFourthRootProperty2_Int = integerFourthRootProperty2---- | Specialized to trigger 'biSqrtWord'.-integerFourthRootProperty2_Word :: NonNegative Word -> Bool-integerFourthRootProperty2_Word = integerFourthRootProperty2--#if WORD_SIZE_IN_BITS == 64---- | Check that 'integerFourthRoot' of 2^60-1 is 2^15-1, not 2^15.-integerFourthRootSpecialCase1_Int :: Assertion-integerFourthRootSpecialCase1_Int =-  assertEqual "integerFourthRoot" (integerFourthRoot (maxBound `div` 8 :: Int)) (2 ^ 15 - 1)---- | Check that 'integerFourthRoot' of 2^60-1 is 2^15-1, not 2^15.-integerFourthRootSpecialCase1_Word :: Assertion-integerFourthRootSpecialCase1_Word =-  assertEqual "integerFourthRoot" (integerFourthRoot (maxBound `div` 16 :: Word)) (2 ^ 15 - 1)---- | Check that 'integerFourthRoot' of 2^64-1 is 2^16-1, not 2^16.-integerFourthRootSpecialCase2 :: Assertion-integerFourthRootSpecialCase2 =-  assertEqual "integerFourthRoot" (integerFourthRoot (maxBound :: Word)) (2 ^ 16 - 1)--#endif---- | Check that 'integerFourthRoot'' returns the largest integer @m@ with @m^4 <= n@.-integerFourthRoot'Property :: Integral a => NonNegative a -> Bool-integerFourthRoot'Property (NonNegative n) = m >= 0 && m ^ 4 <= n && (m + 1) ^ 4 /= n && (m + 1) ^ 3 >= n `div` (m + 1)-  where-    m = integerFourthRoot' n---- | Check that the number 'isFourthPower' iff its 'integerFourthRoot' is exact.-isFourthPowerProperty :: Integral a => AnySign a -> Bool-isFourthPowerProperty (AnySign n) = (n < 0 && not t) || (n /= m ^ 4 && not t) || (n == m ^ 4 && t)-  where-    t = isFourthPower n-    m = integerFourthRoot n---- | Check that the number 'isFourthPower'' iff its 'integerFourthRoot'' is exact.-isFourthPower'Property :: Integral a => NonNegative a -> Bool-isFourthPower'Property (NonNegative n) = (n /= m ^ 4 && not t) || (n == m ^ 4 && t)-  where-    t = isFourthPower' n-    m = integerFourthRoot' n---- | Check that 'exactFourthRoot' returns an exact integer root of fourth power--- and is consistent with 'isFourthPower'.-exactFourthRootProperty :: Integral a => AnySign a -> Bool-exactFourthRootProperty (AnySign n) = case exactFourthRoot n of-  Nothing -> not (isFourthPower n)-  Just m  -> isFourthPower n && n == m ^ 4---- | Check that 'isPossibleFourthPower' is consistent with 'exactFourthRoot'.-isPossibleFourthPowerProperty :: Integral a => NonNegative a -> Bool-isPossibleFourthPowerProperty (NonNegative n) = t || not t && isNothing m-  where-    t = isPossibleFourthPower n-    m = exactFourthRoot n--testSuite :: TestTree-testSuite = testGroup "Fourth"-  [ testGroup "integerFourthRoot"-    [ testIntegralProperty "generic"         integerFourthRootProperty-    , testSmallAndQuick    "generic Int"     integerFourthRootProperty_Int-    , testSmallAndQuick    "generic Word"    integerFourthRootProperty_Word-    , testSmallAndQuick    "generic Integer" integerFourthRootProperty_Integer--    , testIntegralProperty "almost Fourth"      integerFourthRootProperty2-    , testSmallAndQuick    "almost Fourth Int"  integerFourthRootProperty2_Int-    , testSmallAndQuick    "almost Fourth Word" integerFourthRootProperty2_Word--#if WORD_SIZE_IN_BITS == 64-    , testCase             "maxBound / 8 :: Int"   integerFourthRootSpecialCase1_Int-    , testCase             "maxBound / 16 :: Word" integerFourthRootSpecialCase1_Word-    , testCase             "maxBound :: Word"      integerFourthRootSpecialCase2-#endif-    ]-  , testIntegralProperty "integerFourthRoot'"    integerFourthRoot'Property-  , testIntegralProperty "isFourthPower"         isFourthPowerProperty-  , testIntegralProperty "isFourthPower'"        isFourthPower'Property-  , testIntegralProperty "exactFourthRoot"       exactFourthRootProperty-  , testIntegralProperty "isPossibleFourthPower" isPossibleFourthPowerProperty-  ]
− test-suite/Math/NumberTheory/Powers/GeneralTests.hs 
@@ -1,128 +0,0 @@--- |--- Module:      Math.NumberTheory.Powers.GeneralTests--- Copyright:   (c) 2016 Andrew Lelechenko--- Licence:     MIT--- Maintainer:  Andrew Lelechenko <andrew.lelechenko@gmail.com>--- Stability:   Provisional------ Tests for Math.NumberTheory.Powers.General-----{-# LANGUAGE CPP #-}--{-# OPTIONS_GHC -fno-warn-type-defaults #-}--module Math.NumberTheory.Powers.GeneralTests-  ( testSuite-  ) where--import Test.Tasty-import Test.Tasty.HUnit--import Math.NumberTheory.Powers.General-import Math.NumberTheory.TestUtils---- | Check that 'integerRoot' @pow@ returns the largest integer @m@ with @m^pow <= n@.-integerRootProperty :: (Integral a, Integral b) => AnySign a -> Power b -> Bool-integerRootProperty (AnySign n) (Power pow) = (even pow && n < 0)-  || (toInteger root ^ pow <= toInteger n && toInteger n < toInteger (root + 1) ^ pow)-    where-      root = integerRoot pow n---- | Check that the number 'isKthPower' iff its 'integerRoot' is exact.-isKthPowerProperty :: (Integral a, Integral b) => AnySign a -> Power b -> Bool-isKthPowerProperty (AnySign n) (Power pow) = (even pow && n < 0 && not t) || (n /= root ^ pow && not t) || (n == root ^ pow && t)-  where-    t = isKthPower pow n-    root = integerRoot pow n---- | Check that 'exactRoot' returns an exact integer root--- and is consistent with 'isKthPower'.-exactRootProperty :: (Integral a, Integral b) => AnySign a -> Power b -> Bool-exactRootProperty (AnySign n) (Power pow) = case exactRoot pow n of-  Nothing   -> not (isKthPower pow n)-  Just root -> isKthPower pow n && n == root ^ pow---- | Check that 'isPerfectPower' is consistent with 'highestPower'.-isPerfectPowerProperty :: Integral a => AnySign a -> Bool-isPerfectPowerProperty (AnySign n) = (k > 1 && t) || (k == 1 && not t)-  where-    t = isPerfectPower n-    (_, k) = highestPower n---- | Check that the first component of 'highestPower' is square-free.-highestPowerProperty :: Integral a => AnySign a -> Bool-highestPowerProperty (AnySign n) = (n `elem` [-1, 0, 1] && k == 3) || (b ^ k == n && b' == b && k' == 1)-  where-    (b, k) = highestPower n-    (b', k') = highestPower b---- | Check that 'largePFPower' is consistent with documentation.-largePFPowerProperty :: Positive Integer -> Integer -> Bool-largePFPowerProperty (Positive bd) n = bd == 1 || b == 0 || d' /= 0 || n <= b * d * d || any (\p -> gcd n p > 1) [2..bd] || b ^ k == n-  where-    (b, k) = largePFPower bd n-    (d, d') = bd `quotRem` b--highestPowerSpecialCases :: [Assertion]-highestPowerSpecialCases =-  -- Freezes before d44a13b.-  [ a ( 1013582159576576-      , 1013582159576576-      , 1)-  -- Freezes before d44a13b.-  , a ( 1013582159576576 ^ 7-      , 1013582159576576-      , 7)--  , a ( -2 ^ 63 :: Int-      , -2 :: Int-      , 63)--  , a ( (2 ^ 63 - 1) ^ 21-      , 2 ^ 63 - 1-      , 21)--  , a ( 576116746989720969230211509779286598589421531472851155101032940901763389787901933902294777750323196846498573545522289802689311975294763847414975335235584-      , 576116746989720969230211509779286598589421531472851155101032940901763389787901933902294777750323196846498573545522289802689311975294763847414975335235584-      , 1)--  , a ( -340282366920938463500268095579187314689-      , -340282366920938463500268095579187314689-      , 1)--  , a ( 268398749 :: Int-      , 268398749 :: Int-      , 1)--  , a ( 118372752099 :: Int-      , 118372752099 :: Int-      , 1)--  , a ( 1409777209 :: Int-      , 37547 :: Int-      , 2)--  , a ( -6277101735386680764856636523970481806547819498980467802113-      , -18446744073709551617-      , 3)--  , a ( -18446744073709551619 ^ 5-      , -18446744073709551619-      , 5)-  ]-  where-    a (n, b, k) = assertEqual "highestPower" (b, k) (highestPower n)--testSuite :: TestTree-testSuite = testGroup "General"-  [ testIntegral2Property "integerRoot"    integerRootProperty-  , testIntegral2Property "isKthPower"     isKthPowerProperty-  , testIntegral2Property "exactRoot"      exactRootProperty-  , testIntegralProperty  "isPerfectPower" isPerfectPowerProperty-  , testGroup "highestPower"-    ( testIntegralProperty  "highestPower"   highestPowerProperty-    : zipWith (\i a -> testCase ("special case " ++ show i) a) [1..] highestPowerSpecialCases-    )-  , testSmallAndQuick     "largePFPower"   largePFPowerProperty-  ]
− test-suite/Math/NumberTheory/Powers/SquaresTests.hs 
@@ -1,165 +0,0 @@--- |--- Module:      Math.NumberTheory.Powers.SquaresTests--- Copyright:   (c) 2016 Andrew Lelechenko--- Licence:     MIT--- Maintainer:  Andrew Lelechenko <andrew.lelechenko@gmail.com>--- Stability:   Provisional------ Tests for Math.NumberTheory.Powers.Squares-----{-# LANGUAGE CPP #-}--{-# OPTIONS_GHC -fno-warn-type-defaults #-}--module Math.NumberTheory.Powers.SquaresTests-  ( testSuite-  ) where--import Test.Tasty-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--#include "MachDeps.h"---- | Check that 'integerSquareRoot' returns the largest integer @m@ with @m*m <= n@.------ (m + 1) ^ 2 /= n && m + 1 >= n `div` (m + 1)--- means--- (m + 1) ^ 2 > n--- but without overflow for bounded types-integerSquareRootProperty :: Integral a => NonNegative a -> Bool-integerSquareRootProperty (NonNegative n) = m >=0 && m * m <= n && (m + 1) ^ 2 /= n && m + 1 >= n `div` (m + 1)-  where-    m = integerSquareRoot n---- | Specialized to trigger 'isqrtInt''.-integerSquareRootProperty_Int :: NonNegative Int -> Bool-integerSquareRootProperty_Int = integerSquareRootProperty---- | Specialized to trigger 'isqrtWord'.-integerSquareRootProperty_Word :: NonNegative Word -> Bool-integerSquareRootProperty_Word = integerSquareRootProperty---- | Specialized to trigger 'isqrtInteger'.-integerSquareRootProperty_Integer :: NonNegative Integer -> Bool-integerSquareRootProperty_Integer = integerSquareRootProperty---- | Check that 'integerSquareRoot' returns the largest integer @m@ with @m*m <= n@, where @n@ has form @k@^2-1.-integerSquareRootProperty2 :: Integral a => NonNegative a -> Bool-integerSquareRootProperty2 (NonNegative k) = n < 0-  || m >=0 && m * m <= n && (m + 1) ^ 2 /= n && m + 1 >= n `div` (m + 1)-  where-    n = k ^ 2 - 1-    m = integerSquareRoot n---- | Specialized to trigger 'isqrtInt''.-integerSquareRootProperty2_Int :: NonNegative Int -> Bool-integerSquareRootProperty2_Int = integerSquareRootProperty2---- | Specialized to trigger 'isqrtWord'.-integerSquareRootProperty2_Word :: NonNegative Word -> Bool-integerSquareRootProperty2_Word = integerSquareRootProperty2---- | Specialized to trigger 'isqrtInteger'.-integerSquareRootProperty2_Integer :: NonNegative Integer -> Bool-integerSquareRootProperty2_Integer = integerSquareRootProperty2--#if WORD_SIZE_IN_BITS == 64---- | Check that 'integerSquareRoot' of 2^62-1 is 2^31-1, not 2^31.-integerSquareRootSpecialCase1_Int :: Assertion-integerSquareRootSpecialCase1_Int =-  assertEqual "integerSquareRoot" (integerSquareRoot (maxBound `div` 2 :: Int)) (2 ^ 31 - 1)---- | Check that 'integerSquareRoot' of 2^62-1 is 2^31-1, not 2^31.-integerSquareRootSpecialCase1_Word :: Assertion-integerSquareRootSpecialCase1_Word =-  assertEqual "integerSquareRoot" (integerSquareRoot (maxBound `div` 4 :: Word)) (2 ^ 31 - 1)---- | Check that 'integerSquareRoot' of 2^64-1 is 2^32-1, not 2^32.-integerSquareRootSpecialCase2 :: Assertion-integerSquareRootSpecialCase2 =-  assertEqual "integerSquareRoot" (integerSquareRoot (maxBound :: Word)) (2 ^ 32 - 1)--#endif---- | Check that 'integerSquareRoot'' returns the largest integer @r@ with @r*r <= n@.-integerSquareRoot'Property :: Integral a => NonNegative a -> Bool-integerSquareRoot'Property (NonNegative n) = m >=0 && m * m <= n && (m + 1) ^ 2 /= n && m + 1 >= n `div` (m + 1)-  where-    m = integerSquareRoot' n---- | Check that the number 'isSquare' iff its 'integerSquareRoot' is exact.-isSquareProperty :: Integral a => AnySign a -> Bool-isSquareProperty (AnySign n) = (n < 0 && not t) || (n /= m * m && not t) || (n == m * m && t)-  where-    t = isSquare n-    m = integerSquareRoot n---- | Check that the number 'isSquare'' iff its 'integerSquareRoot'' is exact.-isSquare'Property :: Integral a => NonNegative a -> Bool-isSquare'Property (NonNegative n) = (n /= m * m && not t) || (n == m * m && t)-  where-    t = isSquare' n-    m = integerSquareRoot' n---- | Check that 'exactSquareRoot' returns an exact integer square root--- and is consistent with 'isSquare'.-exactSquareRootProperty :: Integral a => AnySign a -> Bool-exactSquareRootProperty (AnySign n) = case exactSquareRoot n of-  Nothing -> not (isSquare n)-  Just m  -> isSquare n && n == m * m---- | Check that 'isPossibleSquare' is consistent with 'exactSquareRoot'--- and that 'isPossibleSquare2' is a refinement of 'isPossibleSquare'.-isPossibleSquareProperty :: Integral a => NonNegative a -> Bool-isPossibleSquareProperty (NonNegative n) = t || not t && not t2 && isNothing m-  where-    t = isPossibleSquare n-    t2 = isPossibleSquare2 n-    m = exactSquareRoot n---- | Check that 'isPossibleSquare2'' is consistent with 'exactSquareRoot'.-isPossibleSquare2Property :: Integral a => NonNegative a -> Bool-isPossibleSquare2Property (NonNegative n) = t || not t && isNothing m-  where-    t = isPossibleSquare2 n-    m = exactSquareRoot n---testSuite :: TestTree-testSuite = testGroup "Squares"-  [ testGroup "integerSquareRoot"-    [ testIntegralProperty "generic"          integerSquareRootProperty-    , testSmallAndQuick    "generic Int"      integerSquareRootProperty_Int-    , testSmallAndQuick    "generic Word"     integerSquareRootProperty_Word-    , testSmallAndQuick    "generic Integer"  integerSquareRootProperty_Integer--    , testIntegralProperty "almost square"         integerSquareRootProperty2-    , testSmallAndQuick    "almost square Int"     integerSquareRootProperty2_Int-    , testSmallAndQuick    "almost square Word"    integerSquareRootProperty2_Word-    , testSmallAndQuick    "almost square Integer" integerSquareRootProperty2_Integer--#if WORD_SIZE_IN_BITS == 64-    , testCase             "maxBound / 2 :: Int"  integerSquareRootSpecialCase1_Int-    , testCase             "maxBound / 4 :: Word" integerSquareRootSpecialCase1_Word-    , testCase             "maxBound :: Word"     integerSquareRootSpecialCase2-#endif-    ]--  , testIntegralProperty "integerSquareRoot'" integerSquareRoot'Property-  , testIntegralProperty "isSquare"           isSquareProperty-  , testIntegralProperty "isSquare'"          isSquare'Property-  , testIntegralProperty "exactSquareRoot"    exactSquareRootProperty-  , testIntegralProperty "isPossibleSquare"   isPossibleSquareProperty-  , testIntegralProperty "isPossibleSquare2"  isPossibleSquare2Property-  ]
+ test-suite/Math/NumberTheory/PrefactoredTests.hs view
@@ -0,0 +1,94 @@+-- |+-- Module:      Math.NumberTheory.PrefactoredTests+-- Copyright:   (c) 2017 Andrew Lelechenko+-- Licence:     MIT+-- Maintainer:  Andrew Lelechenko <andrew.lelechenko@gmail.com>+--+-- Tests for Math.NumberTheory.Prefactored+--++{-# OPTIONS_GHC -fno-warn-type-defaults #-}++module Math.NumberTheory.PrefactoredTests+  ( testSuite+  ) where++import Test.Tasty++import Control.Arrow (second)+import Data.Euclidean+import Data.List (tails)+import Numeric.Natural++import Math.NumberTheory.Euclidean.Coprimes+import Math.NumberTheory.Prefactored+import Math.NumberTheory.TestUtils++isValid :: (Eq a, Num a, GcdDomain a, 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 = unCoprimes $ prefFactors pref++fromValueProperty :: Integer -> Bool+fromValueProperty n = isValid pref && prefValue pref == n+  where+    pref = fromValue n++fromFactorsProperty :: [(Integer, Power Word)] -> Bool+fromFactorsProperty fs' = isValid pref && abs (prefValue pref) == abs (product (map (uncurry (^)) fs))+  where+    fs   = map (second getPower) fs'+    pref = fromFactors (splitIntoCoprimes fs)++plusProperty :: Integer -> Integer -> Bool+plusProperty x y = isValid z && prefValue z == x + y+  where+    z = fromValue x + fromValue y++minusProperty :: Integer -> Integer -> Bool+minusProperty x y = isValid z && prefValue z == x - y+  where+    z = fromValue x - fromValue y++minusNaturalProperty :: Natural -> Natural -> Bool+minusNaturalProperty x y = x < y || (isValid z && prefValue z == x - y)+  where+    z = fromValue x - fromValue y++multiplyProperty :: Integer -> Integer -> Bool+multiplyProperty x y = isValid z && prefValue z == x * y+  where+    z = fromValue x * fromValue y++negateProperty :: Integer -> Bool+negateProperty x = isValid z && prefValue z == negate x+  where+    z = negate (fromValue x)++absSignumProperty :: Integer -> Bool+absSignumProperty x = isValid z && prefValue z == x+  where+    z = abs (fromValue x) * signum (fromValue x)++fromIntegerProperty :: Integer -> Bool+fromIntegerProperty n = isValid pref && prefValue pref == n+  where+    pref = fromInteger n++testSuite :: TestTree+testSuite = testGroup "Prefactored"+  [ testSmallAndQuick "fromValue"   fromValueProperty+  , testSmallAndQuick "fromFactors" fromFactorsProperty+  , testGroup "Num instance"+    [ testSmallAndQuick "plus"         plusProperty+    , testSmallAndQuick "minus"        minusProperty+    , testSmallAndQuick "minusNatural" minusNaturalProperty+    , testSmallAndQuick "multiply"     multiplyProperty+    , testSmallAndQuick "negate"       negateProperty+    , testSmallAndQuick "absSignum"    absSignumProperty+    , testSmallAndQuick "fromInteger"  fromIntegerProperty+    ]+  ]
test-suite/Math/NumberTheory/Primes/CountingTests.hs view
@@ -3,7 +3,6 @@ -- Copyright:   (c) 2016 Andrew Lelechenko -- Licence:     MIT -- Maintainer:  Andrew Lelechenko <andrew.lelechenko@gmail.com>--- Stability:   Provisional -- -- Tests for Math.NumberTheory.Primes.Counting --@@ -17,6 +16,7 @@ import Test.Tasty import Test.Tasty.HUnit +import Math.NumberTheory.Primes (unPrime) import Math.NumberTheory.Primes.Counting import Math.NumberTheory.Primes.Testing import Math.NumberTheory.TestUtils@@ -36,7 +36,9 @@   , (10^10,  455052511)   , (10^11,  4118054813)   , (10^12,  37607912018)-  , (10^13,  346065536839)+  -- Enable tests below to validate any changes to 'primeCount' implementation:+  -- certain routines are not triggered until very large numbers.+  -- , (10^13,  346065536839)   -- , (10^14,  3204941750802)   -- , (10^15,  29844570422669)   -- , (10^16,  279238341033925)@@ -73,34 +75,31 @@ primeCountSpecialCases :: [Assertion] primeCountSpecialCases = map a table   where-  a (n, m) = assertEqual "primeCount" m (primeCount n)+    a (n, m) = assertEqual "primeCount" m (primeCount n)   -- | Check that values of 'nthPrime' are positive.-nthPrimeProperty1 :: Positive Integer -> Bool-nthPrimeProperty1 (Positive n) = n > nthPrimeMaxArg-  || nthPrime n > 0+nthPrimeProperty1 :: Positive Int -> Bool+nthPrimeProperty1 (Positive n) = unPrime (nthPrime n) > 0  -- | Check that 'nthPrime' is monotonically increasing function.-nthPrimeProperty2 :: Positive Integer -> Positive Integer -> Bool+nthPrimeProperty2 :: Positive Int -> Positive Int -> Bool nthPrimeProperty2 (Positive n1) (Positive n2)-  =  n1 > nthPrimeMaxArg-  || n2 > nthPrimeMaxArg-  || n1 <= n2 && p1 <= p2+  =  n1 <= n2 && p1 <= p2   || n1 >  n2 && p1 >= p2   where     p1 = nthPrime n1     p2 = nthPrime n2  -- | Check that values of 'nthPrime' are prime.-nthPrimeProperty3 :: Positive Integer -> Bool-nthPrimeProperty3 (Positive n) = isPrime $ nthPrime n+nthPrimeProperty3 :: Positive Int -> Bool+nthPrimeProperty3 (Positive n) = isPrime $ unPrime $ nthPrime n  -- | Check tabulated values. nthPrimeSpecialCases :: [Assertion] nthPrimeSpecialCases = map a table   where-  a (n, m) = assertBool "nthPrime" $ n > nthPrime m+    a (n, m) = assertBool "nthPrime" $ n > unPrime (nthPrime (fromInteger m))   -- | Check that values of 'approxPrimeCount' are non-negative.@@ -120,7 +119,7 @@ -- | Check that 'nthPrimeApprox' is consistent with 'nthPrimeApproxUnderestimateLimit'. nthPrimeApproxProperty2 :: Positive Integer -> Bool nthPrimeApproxProperty2 (Positive a) = a >= nthPrimeApproxUnderestimateLimit-  || toInteger (nthPrimeApprox a) <= nthPrime (toInteger a)+  || nthPrimeApprox a <= unPrime (nthPrime (fromInteger a))   testSuite :: TestTree
test-suite/Math/NumberTheory/Primes/FactorisationTests.hs view
@@ -3,7 +3,6 @@ -- Copyright:   (c) 2017 Andrew Lelechenko -- Licence:     MIT -- Maintainer:  Andrew Lelechenko <andrew.lelechenko@gmail.com>--- Stability:   Provisional -- -- Tests for Math.NumberTheory.Primes.Factorisation --@@ -17,15 +16,27 @@ import Test.Tasty import Test.Tasty.HUnit +import Control.Arrow+import Control.Monad (zipWithM_) import Data.List (nub, sort)+import Data.Maybe -import Math.NumberTheory.Primes.Factorisation-import Math.NumberTheory.Primes.Testing+import Math.NumberTheory.Primes import Math.NumberTheory.TestUtils -specialCases :: [(Integer, [(Integer, Int)])]+specialCases :: [(Integer, [(Integer, Word)])] specialCases =-  [ (4181339589500970917,[(15034813,1),(278110515209,1)])+  [ (35,[(5,1),(7,1)])+  , (75,[(3,1),(5,2)])+  , (65521^2,[(65521,2)])+  , (65537^2,[(65537,2)])+  , (2147483647, [(2147483647, 1)])+  , (4294967291, [(4294967291, 1)])+  , (19000000000000000001, [(19000000000000000001, 1)])+  , (3 * 5^2 * 7^21, [(3,1), (5,2), (7, 21)])+  , (9223372036854775783, [(9223372036854775783, 1)])+  , (18446744073709551557, [(18446744073709551557, 1)])+  , (4181339589500970917,[(15034813,1),(278110515209,1)])   , (4181339589500970918,[(2,1),(3,2),(7,1),(2595773,1),(12784336241,1)])   , (2227144715990344929,[(3,1),(317,1),(17381911,1),(134731889,1)])   , (10489674846272137811130167281,[(1312601,1),(9555017,1),(836368815445393,1)])@@ -43,37 +54,64 @@   , (16757651897802863152387219654541878160,[(2,4),(5,1),(12323,1),(1424513,1),(6205871923,1),(1922815011093901,1)])   , (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)])+  -- , (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)])+  , (623506907396924300595652906937, [(300137,1),(825131,2),(1746779,2)])+  , (626472835738582668418814215862, [(2,1),(150211,1),(11746151,2),(122939,2)])+  , (638396704483535474833679624037, [(3,1),(11,2),(100519,1),(104281,2),(1268419,2)])   ] +lazyCases :: [(Integer, [(Integer, Word)])]+lazyCases =+  [ ( 14145130711+    * 10000000000000000000000000000000000000121+    * 100000000000000000000000000000000000000000000000447+    , [(14145130711, 1)]+    )+  ]++shortenNumber :: Integer -> String+shortenNumber n+  | l <= 10 = xs+  | otherwise = take 5 xs ++ "..." ++ drop (l - 5) xs+  where+    xs = show n+    l = length xs+ factoriseProperty1 :: Assertion-factoriseProperty1 = assertEqual "0" [] (factorise 1)+factoriseProperty1 = assertEqual "0" [] (factorise (1 :: Int))  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)+factoriseProperty3 (Positive n) = all (isJust . isPrime . unPrime . fst) (factorise n)  factoriseProperty4 :: Positive Integer -> Bool-factoriseProperty4 (Positive n) = bases == nub (sort bases)+factoriseProperty4 (Positive n) = sort bases == nub (sort bases)   where     bases = map fst $ factorise n  factoriseProperty5 :: Positive Integer -> Bool-factoriseProperty5 (Positive n) = product (map (uncurry (^)) (factorise n)) == n+factoriseProperty5 (Positive n) = product (map (\(p, k) -> unPrime p ^ k) (factorise n)) == n -factoriseProperty6 :: (Integer, [(Integer, Int)]) -> Assertion-factoriseProperty6 (n, fs) = assertEqual (show n) fs (factorise n)+factoriseProperty6 :: (Integer, [(Integer, Word)]) -> Assertion+factoriseProperty6 (n, fs) = assertEqual (show n) (sort fs) (sort $ map (first unPrime) $ factorise n) +factoriseProperty7 :: (Integer, [(Integer, Word)]) -> Assertion+factoriseProperty7 (n, fs) = zipWithM_ (assertEqual (show n)) fs (map (first unPrime) $ factorise n)+ testSuite :: TestTree testSuite = testGroup "Factorisation"   [ testGroup "factorise" $     [ testCase          "0"                              factoriseProperty1     , testSmallAndQuick "negate"                         factoriseProperty2     , testSmallAndQuick "bases are prime"                factoriseProperty3-    , testSmallAndQuick "bases are ordered and distinct" factoriseProperty4+    , testSmallAndQuick "bases are distinct"             factoriseProperty4     , testSmallAndQuick "factorback"                     factoriseProperty5     ] ++-    map (\x -> testCase ("special case " ++ show (fst x)) (factoriseProperty6 x)) specialCases+    map (\x -> testCase ("special case " ++ shortenNumber (fst x)) (factoriseProperty6 x)) specialCases+    +++    map (\x -> testCase ("laziness " ++ shortenNumber (fst x)) (factoriseProperty7 x)) lazyCases   ]
− test-suite/Math/NumberTheory/Primes/HeapTests.hs 
@@ -1,67 +0,0 @@--- |--- Module:      Math.NumberTheory.Primes.HeapTests--- Copyright:   (c) 2016 Andrew Lelechenko--- Licence:     MIT--- Maintainer:  Andrew Lelechenko <andrew.lelechenko@gmail.com>--- Stability:   Provisional------ Tests for Math.NumberTheory.Primes.Heap-----{-# LANGUAGE CPP #-}--{-# OPTIONS_GHC -fno-warn-type-defaults #-}--module Math.NumberTheory.Primes.HeapTests-  ( testSuite-  ) where--import Prelude hiding (words)--import Test.Tasty-import Test.Tasty.HUnit--#if MIN_VERSION_base(4,8,0)-#else-import Data.Word-#endif--import Math.NumberTheory.Primes.Heap-import Math.NumberTheory.Primes.Testing-import Math.NumberTheory.TestUtils---- | Check that 'primes' over different integral types matches with 'isPrime'.-primesProperty1 :: Assertion-primesProperty1 = do-  assertEqual "ints  == integers" (trim ints)  (trim integers)-  assertEqual "words == integers" (trim words) (trim integers)-  assertEqual "naive == integers" (trim naive) (trim integers)-  where-    trim :: Integral a => [a] -> [Integer]-    trim = map toInteger . take 100000--    ints     = primes :: [Int]-    words    = primes :: [Word]-    integers = primes :: [Integer]-    naive    = filter isPrime [1..] :: [Integer]---- | Check that 'sieveFrom' over different integral types matches with 'isPrime'.-sieveFromProperty1 :: NonNegative Integer -> Bool-sieveFromProperty1 (NonNegative lowBound)-  =  trim ints  == trim integers-  && trim words == trim integers-  && trim naive == trim integers-  where-    trim :: Integral a => [a] -> [Integer]-    trim = map toInteger . take 1000--    ints     = sieveFrom (fromInteger lowBound) :: [Int]-    words    = sieveFrom (fromInteger lowBound) :: [Word]-    integers = sieveFrom lowBound               :: [Integer]-    naive    = filter isPrime [lowBound..]      :: [Integer]--testSuite :: TestTree-testSuite = testGroup "Heap"-  [ testCase          "primes"    primesProperty1-  , testSmallAndQuick "sieveFrom" sieveFromProperty1-  ]
+ test-suite/Math/NumberTheory/Primes/SequenceTests.hs view
@@ -0,0 +1,173 @@+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}++module Math.NumberTheory.Primes.SequenceTests+  ( testSuite+  ) where++import Test.Tasty+import Test.Tasty.HUnit++import Data.Bits+import Data.Maybe+import Data.Proxy+import Numeric.Natural++import Math.NumberTheory.Primes+import Math.NumberTheory.Primes.Counting (nthPrime, primeCount)+import Math.NumberTheory.TestUtils++nextPrimeProperty+  :: (Bits a, Integral a, UniqueFactorisation a)+  => AnySign a+  -> Bool+nextPrimeProperty (AnySign n) = unPrime (nextPrime n) >= n++precPrimeProperty+  :: (Bits a, Integral a, UniqueFactorisation a)+  => Positive a+  -> Bool+precPrimeProperty (Positive n) = n <= 2 || unPrime (precPrime n) <= n++toEnumProperty+  :: forall a.+     (Enum (Prime a), Integral a)+  => Proxy a+  -> Int+  -> Bool+toEnumProperty _ n = n <= 0 || unPrime (toEnum n :: Prime a) == fromInteger (unPrime (nthPrime n))++fromEnumProperty+  :: (Enum (Prime a), Integral a)+  => Prime a+  -> Bool+fromEnumProperty p = fromEnum p == fromInteger (primeCount (toInteger (unPrime p)))++succProperty+  :: (Enum a, Enum (Prime a), Num a, UniqueFactorisation a)+  => Prime a+  -> Bool+succProperty p = all (isNothing . isPrime) [unPrime p + 1 .. unPrime (succ p) - 1]++predProperty+  :: (Enum a, Enum (Prime a), Ord a, Num a, UniqueFactorisation a)+  => Prime a+  -> Bool+predProperty p = unPrime p <= 2 || all (isNothing . isPrime) [unPrime (pred p) + 1 .. unPrime p - 1]++enumFrom2To2 :: Assertion+enumFrom2To2 = assertEqual "should be equal"+  [two]+  [two..two]+  where+    two = minBound :: Prime Word++enumFrom65500To65600 :: Assertion+enumFrom65500To65600 = assertEqual "should be equal"+  [65519, 65521, 65537, 65539, 65543, 65551, 65557, 65563, 65579, 65581, 65587, 65599]+  (map unPrime [low..high])+  where+    low  = nextPrime (65500 :: Word)+    high = precPrime (65600 :: Word)++enumFrom2To100000 :: Assertion+enumFrom2To100000 = assertEqual "should be equal"+  (takeWhile (<= high) [low..])+  [low..high]+  where+    low  = minBound :: Prime Word+    high = precPrime (100000 :: Word)++enumFromProperty+  :: (Ord a, Enum (Prime a))+  => Prime a+  -> Prime a+  -> Bool+enumFromProperty p q = [p..q] == takeWhile (<= q) [p..]++enumFromToProperty+  :: (Eq a, Enum a, Enum (Prime a), UniqueFactorisation a)+  => Prime a+  -> Prime a+  -> Bool+enumFromToProperty p q = [p..q] == mapMaybe isPrime [unPrime p .. unPrime q]++enumFromThenProperty+  :: (Show a, Ord a, Enum (Prime a))+  => Prime a+  -> Prime a+  -> Prime a+  -> Bool+enumFromThenProperty p q r = case p `compare` q of+  LT -> enumFromThenTo p q r == takeWhile (<= r) (enumFromThen p q)+  EQ -> True+  GT -> enumFromThenTo p q r == takeWhile (>= r) (enumFromThen p q)++enumFromThenToProperty+  :: (Ord a, Enum a, Enum (Prime a), UniqueFactorisation a, Show a)+  => Prime a+  -> Prime a+  -> Prime a+  -> Bool+enumFromThenToProperty p q r+  | p == q && q <= r = True+  | otherwise+  = [p, q .. r] == mapMaybe isPrime [unPrime p, unPrime q .. unPrime r]++testSuite :: TestTree+testSuite = testGroup "Sequence"+  [ testIntegralPropertyNoLarge "nextPrime" nextPrimeProperty+  , testIntegralPropertyNoLarge "precPrime" precPrimeProperty+  , testGroup "toEnum"+    [ testSmallAndQuick "Int" (toEnumProperty (Proxy @Int))+    , testSmallAndQuick "Word" (toEnumProperty (Proxy @Word))+    , testSmallAndQuick "Integer" (toEnumProperty (Proxy @Integer))+    , testSmallAndQuick "Natural" (toEnumProperty (Proxy @Natural))+    ]+  , testGroup "fromEnum"+    [ testSmallAndQuick "Int" (fromEnumProperty @Int)+    , testSmallAndQuick "Word" (fromEnumProperty @Word)+    , testSmallAndQuick "Integer" (fromEnumProperty @Integer)+    , testSmallAndQuick "Natural" (fromEnumProperty @Natural)+    ]+  , testGroup "succ"+    [ testSmallAndQuick "Int" (succProperty @Int)+    , testSmallAndQuick "Word" (succProperty @Word)+    , testSmallAndQuick "Integer" (succProperty @Integer)+    , testSmallAndQuick "Natural" (succProperty @Natural)+    ]+  , testGroup "pred"+    [ testSmallAndQuick "Int" (predProperty @Int)+    , testSmallAndQuick "Word" (predProperty @Word)+    , testSmallAndQuick "Integer" (predProperty @Integer)+    , testSmallAndQuick "Natural" (predProperty @Natural)+    ]+  , testCase "[2..2] == [2]"  enumFrom2To2+  , testCase "[65500..65600]" enumFrom65500To65600+  , testCase "[2..100000]"    enumFrom2To100000+  , testGroup "enumFrom"+    [ testSmallAndQuick "Int" (enumFromProperty @Int)+    , testSmallAndQuick "Word" (enumFromProperty @Word)+    , testSmallAndQuick "Integer" (enumFromProperty @Integer)+    , testSmallAndQuick "Natural" (enumFromProperty @Natural)+    ]+  , testGroup "enumFromTo"+    [ testSmallAndQuick "Int" (enumFromToProperty @Int)+    , testSmallAndQuick "Word" (enumFromToProperty @Word)+    , testSmallAndQuick "Integer" (enumFromToProperty @Integer)+    , testSmallAndQuick "Natural" (enumFromToProperty @Natural)+    ]+  , testGroup "enumFromThen"+    [ testSmallAndQuick "Int" (enumFromThenProperty @Int)+    , testSmallAndQuick "Word" (enumFromThenProperty @Word)+    , testSmallAndQuick "Integer" (enumFromThenProperty @Integer)+    , testSmallAndQuick "Natural" (enumFromThenProperty @Natural)+    ]+  , testGroup "enumFromThenTo"+    [ testSmallAndQuick "Int" (enumFromThenToProperty @Int)+    , testSmallAndQuick "Word" (enumFromThenToProperty @Word)+    , testSmallAndQuick "Integer" (enumFromThenToProperty @Integer)+    , testSmallAndQuick "Natural" (enumFromThenToProperty @Natural)+    ]+  ]
test-suite/Math/NumberTheory/Primes/SieveTests.hs view
@@ -1,14 +1,14 @@ -- | -- Module:      Math.NumberTheory.Primes.SieveTests--- Copyright:   (c) 2016 Andrew Lelechenko+-- Copyright:   (c) 2016-2018 Andrew Lelechenko -- Licence:     MIT -- Maintainer:  Andrew Lelechenko <andrew.lelechenko@gmail.com>--- Stability:   Provisional -- -- Tests for Math.NumberTheory.Primes.Sieve -- -{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE ScopedTypeVariables #-}  {-# OPTIONS_GHC -fno-warn-type-defaults #-} @@ -21,49 +21,75 @@ import Test.Tasty import Test.Tasty.HUnit -import Math.NumberTheory.Primes.Sieve-import qualified Math.NumberTheory.Primes.Heap as H+import Data.Bits+import Data.Int+import Data.Proxy (Proxy(..))+import Data.Word+import Numeric.Natural (Natural)++import Math.NumberTheory.Primes (Prime, unPrime, primes, nextPrime, precPrime, UniqueFactorisation)+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 +-- | Check that 'primes' matches 'isPrime'.+primesProperty1 :: forall a. (Integral a, Show a) => Proxy a -> Assertion+primesProperty1 _ = assertEqual "primes matches isPrime"+  (takeWhile (<= lim1) (map unPrime primes) :: [a])+  (filter (isPrime . toInteger) [1..lim1])++primesProperty2 :: forall a. (Integral a, Bounded a, Show a) => Proxy a -> Assertion+primesProperty2 _ = assertEqual "primes matches isPrime"+  (map unPrime 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---- | Check that 'primeList' from 'psieveList' matches 'primes'.-psieveListProperty1 :: Assertion-psieveListProperty1 = do-  assertEqual "primes == primeList . psieveList" (trim primes) (trim $ concatMap primeList psieveList)+primeSieveProperty1 (AnySign highBound')+  =  [nextPrime 2 .. precPrime highBound]+  == takeWhile (\p -> unPrime p <= highBound) primes   where-    trim = take 100000+    highBound = max 2 (highBound' `rem` lim1) --- | Check that 'primeList' from 'psieveFrom' matches 'sieveFrom'.-psieveFromProperty1 :: AnySign Integer -> Bool-psieveFromProperty1 (AnySign lowBound)-  = trim (sieveFrom lowBound) == trim (filter (>= lowBound) (concatMap primeList $ psieveFrom lowBound))-  where-    trim = take 1000+-- | Check that 'primeList' from 'psieveList' matches 'primes'.+psieveListProperty1 :: forall a. (Integral a, Show a, Enum (Prime a), Bits a, UniqueFactorisation a) => Proxy a -> Assertion+psieveListProperty1 _ = assertEqual "primes == primeList . psieveList"+  (take lim2 primes :: [Prime a])+  (take lim2 [nextPrime 1..]) +psieveListProperty2 :: forall a. (Integral a, Bounded a, Show a) => Proxy a -> Assertion+psieveListProperty2 _ = assertEqual "primes == primeList . psieveList"+  (map unPrime primes :: [a])+  (filter (isPrime . toInteger) [0..maxBound])  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))+    ]   ]
test-suite/Math/NumberTheory/Primes/TestingTests.hs view
@@ -3,7 +3,6 @@ -- Copyright:   (c) 2017 Andrew Lelechenko -- Licence:     MIT -- Maintainer:  Andrew Lelechenko <andrew.lelechenko@gmail.com>--- Stability:   Provisional -- -- Tests for Math.NumberTheory.Primes.Testing --@@ -17,8 +16,6 @@ import Test.Tasty import Test.Tasty.HUnit -import GHC.Integer.GMP.Internals (nextPrimeInteger)- import Math.NumberTheory.Primes.Testing import Math.NumberTheory.TestUtils @@ -32,28 +29,23 @@ isPrimeProperty2 n = isPrime n == isPrime (negate n)  isPrimeProperty3 :: Assertion-isPrimeProperty3 = assertBool "Carmichael pseudoprimes" $ all (not . isPrime) pseudoprimes+isPrimeProperty3 = assertBool "Carmichael pseudoprimes" $ not $ any isPrime pseudoprimes   where     -- OEIS A002997     pseudoprimes = [561, 1105, 1729, 2465, 2821, 6601, 8911, 10585, 15841, 29341, 41041, 46657, 52633, 62745, 63973, 75361, 101101, 115921, 126217, 162401, 172081, 188461, 252601, 278545, 294409, 314821, 334153, 340561, 399001, 410041, 449065, 488881, 512461]  isPrimeProperty4 :: Assertion-isPrimeProperty4 = assertBool "strong pseudoprimes to base 2" $ all (not . isPrime) pseudoprimes+isPrimeProperty4 = assertBool "strong pseudoprimes to base 2" $ not $ any isPrime pseudoprimes   where     -- OEIS A001262     pseudoprimes = [2047, 3277, 4033, 4681, 8321, 15841, 29341, 42799, 49141, 52633, 65281, 74665, 80581, 85489, 88357, 90751, 104653, 130561, 196093, 220729, 233017, 252601, 253241, 256999, 271951, 280601, 314821, 357761, 390937, 458989, 476971, 486737]  isPrimeProperty5 :: Assertion-isPrimeProperty5 = assertBool "strong Lucas pseudoprimes" $ all (not . isPrime) pseudoprimes+isPrimeProperty5 = assertBool "strong Lucas pseudoprimes" $ not $ any isPrime pseudoprimes   where     -- OEIS A217255     pseudoprimes = [5459, 5777, 10877, 16109, 18971, 22499, 24569, 25199, 40309, 58519, 75077, 97439, 100127, 113573, 115639, 130139, 155819, 158399, 161027, 162133, 176399, 176471, 189419, 192509, 197801, 224369, 230691, 231703, 243629, 253259, 268349, 288919, 313499, 324899] -isPrimeProperty6 :: NonNegative Integer -> Bool-isPrimeProperty6 (NonNegative n) = if isPrime n-  then nextPrimeInteger (n - 1) == n-  else isPrime (nextPrimeInteger n)- isStrongFermatPPProperty :: NonNegative Integer -> Integer -> Bool isStrongFermatPPProperty (NonNegative n) b = not (isPrime n) || isStrongFermatPP n b @@ -65,7 +57,6 @@     , testCase          "Carmichael pseudoprimes"    isPrimeProperty3     , testCase          "strong pseudoprimes base 2" isPrimeProperty4     , testCase          "strong Lucas pseudoprimes"  isPrimeProperty5-    , testSmallAndQuick "matches GMP"                isPrimeProperty6     ]   , testGroup "isStrongFermatPP"     [ testSmallAndQuick "matches isPrime" isStrongFermatPPProperty
test-suite/Math/NumberTheory/PrimesTests.hs view
@@ -3,11 +3,13 @@ -- Copyright:   (c) 2016 Andrew Lelechenko -- Licence:     MIT -- Maintainer:  Andrew Lelechenko <andrew.lelechenko@gmail.com>--- Stability:   Provisional -- -- Tests for Math.NumberTheory.Primes -- +{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}+ {-# OPTIONS_GHC -fno-warn-type-defaults #-}  module Math.NumberTheory.PrimesTests@@ -15,32 +17,43 @@   ) where  import Test.Tasty-import Test.Tasty.HUnit +import Data.Bits+import Data.Int+import Data.Proxy+ import Math.NumberTheory.Primes+import qualified Math.NumberTheory.Primes.IntSet as PS import Math.NumberTheory.TestUtils  primesSumWonk :: Int -> Int-primesSumWonk upto = sum . takeWhile (< upto) . map fromInteger . primeList $ primeSieve (toInteger upto)+primesSumWonk upto = sum $ map unPrime [nextPrime 2 .. precPrime upto]  primesSum :: Int -> Int-primesSum upto = sum . takeWhile (< upto) . map fromInteger $ primes+primesSum upto = sum . takeWhile (<= upto) . map unPrime $ primes  primesSumProperty :: NonNegative Int -> Bool-primesSumProperty (NonNegative n) = primesSumWonk n == primesSum n-+primesSumProperty (NonNegative n) = n < 2 || 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)+symmetricDifferenceProperty :: [Prime Int] -> [Prime Int] -> Bool+symmetricDifferenceProperty xs ys = z1 == z2+  where+    x = PS.fromList xs+    y = PS.fromList ys+    z1 = (x PS.\\ PS.unPrimeIntSet y) <> (y PS.\\ PS.unPrimeIntSet x)+    z2 = PS.symmetricDifference x y -sieveFactorProperty :: Integer -> Bool-sieveFactorProperty n = (n==0) || factorise n == sieveFactor (factorSieve 25) n+toPrimeIntegralTest :: forall a b. (Bits a, Integral a, Bits b, Integral b) => Proxy a -> Prime b -> Bool+toPrimeIntegralTest _ p =+  toIntegralSized (unPrime p) == (fmap unPrime (toPrimeIntegral p) :: Maybe a)  testSuite :: TestTree testSuite = testGroup "Primes"   [ testSmallAndQuick "primesSum"   primesSumProperty-  , testCase          "sieveFactor special"  sieveFactorSpecialCase1-  , testSmallAndQuick "sieveFactor property" sieveFactorProperty+  , testSmallAndQuick "symmetricDifference" symmetricDifferenceProperty+  , testGroup "toPrimeIntegral"+    [ testSmallAndQuick "Int -> Integer" $ toPrimeIntegralTest @Integer @Int     Proxy+    , testSmallAndQuick "Int -> Int8"    $ toPrimeIntegralTest @Int8    @Int     Proxy+    , testSmallAndQuick "Integer -> Int" $ toPrimeIntegralTest @Int     @Integer Proxy+    ]   ]
+ test-suite/Math/NumberTheory/Recurrences/BilinearTests.hs view
@@ -0,0 +1,294 @@+-- |+-- Module:      Math.NumberTheory.Recurrences.BilinearTests+-- Copyright:   (c) 2016 Andrew Lelechenko+-- Licence:     MIT+-- Maintainer:  Andrew Lelechenko <andrew.lelechenko@gmail.com>+--+-- Tests for Math.NumberTheory.Recurrences.Bilinear+--++{-# LANGUAGE TypeApplications #-}++{-# OPTIONS_GHC -fno-warn-type-defaults #-}++module Math.NumberTheory.Recurrences.BilinearTests+  ( testSuite+  ) where++import Test.Tasty+import Test.Tasty.HUnit++import Control.Arrow+import Data.List (sort)+import qualified Data.List.Infinite as Inf+import Data.Ratio++import Math.NumberTheory.Primes+import Math.NumberTheory.Recurrences.Bilinear+import Math.NumberTheory.TestUtils++binomialProperty1 :: Word -> Bool+binomialProperty1 i = length (binomial @Integer Inf.!! i) == fromIntegral i + 1++binomialProperty2 :: Word -> Bool+binomialProperty2 i = take 1 (binomial @Integer Inf.!! i) == [1]++binomialProperty3 :: Word -> Bool+binomialProperty3 i = binomial @Integer Inf.!! i !! fromIntegral i == 1++binomialProperty4 :: Positive Int -> Positive Int -> Bool+binomialProperty4 (Positive i) (Positive j)+  =  j >= i+  || binomial @Integer Inf.!! fromIntegral i !! j+  == binomial Inf.!! (fromIntegral i - 1) !! (j - 1)+  +  binomial Inf.!! (fromIntegral i - 1) !! j++binomialProperty5 :: Word -> Word -> Bool+binomialProperty5 n m' = n > 100000 ||+  sort (map (first unPrime) (factorise (binomial Inf.!! n !! fromIntegral m))) ==+    sort (map (first (toInteger . unPrime)) (binomialFactors n m))+  where+    m = m' `mod` (n + 1)++binomialProperty6 :: Word -> Word -> Bool+binomialProperty6 n m' = n > 100000 ||+  binomial Inf.!! n !! fromIntegral m ==+    product (map (\(p, k) -> toInteger (unPrime p) ^ k) (binomialFactors n m))+  where+    m = m' `mod` (n + 1)++binomialRotatedProperty2 :: Word -> Bool+binomialRotatedProperty2 i = Inf.head (binomialRotated @Integer Inf.!! i) == 1++binomialRotatedProperty3 :: Word -> Bool+binomialRotatedProperty3 i = Inf.head (binomialRotated @Integer) Inf.!! i == 1++binomialRotatedProperty4 :: Positive Int -> Positive Int -> Bool+binomialRotatedProperty4 (Positive i) (Positive j)+  =  binomialRotated @Integer Inf.!! fromIntegral i Inf.!! fromIntegral j+  == binomialRotated Inf.!! fromIntegral i Inf.!! (fromIntegral j - 1)+  +  binomialRotated Inf.!! (fromIntegral i - 1) Inf.!! fromIntegral j++binomialLineProperty1 :: Word -> Word -> Bool+binomialLineProperty1 i j+  =  j >= i+  || binomial @Integer Inf.!! i !! fromIntegral j == binomialLine (toInteger i) !! fromIntegral j++binomialLineProperty2 :: Word -> Word -> Bool+binomialLineProperty2 i j+  = binomialRotated @Integer Inf.!! i Inf.!! j == binomialLine (toInteger (i + j)) !! fromIntegral j++binomialDiagonalProperty1 :: Word -> Word -> Bool+binomialDiagonalProperty1 i j+  = binomialRotated @Integer Inf.!! i Inf.!! j == binomialDiagonal (toInteger i) Inf.!! j++binomialDiagonalProperty2 :: Word -> Word -> Bool+binomialDiagonalProperty2 i j+  = binomial @Integer Inf.!! (i + j) !! fromIntegral j == binomialDiagonal (toInteger i) Inf.!! j++stirling1Property1 :: Word -> Bool+stirling1Property1 i = length (stirling1 Inf.!! i) == fromIntegral i + 1++stirling1Property2 :: Word -> Bool+stirling1Property2 i+  =  take 1 (stirling1 Inf.!! i)+  == [if i == 0 then 1 else 0]++stirling1Property3 :: Word -> Bool+stirling1Property3 i = stirling1 Inf.!! i !! fromIntegral i == 1++stirling1Property4 :: Positive Int -> Positive Int -> Bool+stirling1Property4 (Positive i) (Positive j)+  =  j >= i+  || stirling1 Inf.!! fromIntegral i !! j+  == stirling1 Inf.!! (fromIntegral i - 1) !! (j - 1)+  +  (toInteger i - 1) * stirling1 Inf.!! (fromIntegral i - 1) !! j++stirling2Property1 :: Word -> Bool+stirling2Property1 i = length (stirling2 Inf.!! i) == fromIntegral i + 1++stirling2Property2 :: Word -> Bool+stirling2Property2 i+  =  take 1 (stirling2 Inf.!! i)+  == [if i == 0 then 1 else 0]++stirling2Property3 :: Word -> Bool+stirling2Property3 i = stirling2 Inf.!! i !! fromIntegral i == 1++stirling2Property4 :: Positive Int -> Positive Int -> Bool+stirling2Property4 (Positive i) (Positive j)+  =  j >= i+  || stirling2 Inf.!! fromIntegral i !! j+  == stirling2 Inf.!! (fromIntegral i - 1) !! (j - 1)+  +  toInteger j * stirling2 Inf.!! (fromIntegral i - 1) !! j++lahProperty1 :: Word -> Bool+lahProperty1 i = length (lah Inf.!! i) == fromIntegral i + 1++lahProperty2 :: Word -> Bool+lahProperty2 i+  =  take 1 (lah Inf.!! i)+  == [product [1 .. i+1]]++lahProperty3 :: Word -> Bool+lahProperty3 i = lah Inf.!! i !! fromIntegral i == 1++lahProperty4 :: Positive Int -> Positive Int -> Bool+lahProperty4 (Positive i) (Positive j)+  =  j >= i+  || lah Inf.!! fromIntegral i !! j+  == sum [ stirling1 Inf.!! (fromIntegral i + 1) !! k * stirling2 Inf.!! fromIntegral k !! (j + 1) | k <- [j + 1 .. i + 1] ]++eulerian1Property1 :: Word -> Bool+eulerian1Property1 i = length (eulerian1 Inf.!! i) == fromIntegral i++eulerian1Property2 :: Positive Int -> Bool+eulerian1Property2 (Positive i)+  =  take 1 (eulerian1 Inf.!! fromIntegral i)+  == [1]++eulerian1Property3 :: Positive Int -> Bool+eulerian1Property3 (Positive i) = eulerian1 Inf.!! fromIntegral i !! (i - 1) == 1++eulerian1Property4 :: Positive Int -> Positive Int -> Bool+eulerian1Property4 (Positive i) (Positive j)+  =  j >= i - 1+  || eulerian1 Inf.!! fromIntegral i !! j+  == toInteger (i - j) * eulerian1 Inf.!! (fromIntegral i - 1) !! (j - 1)+  +  (toInteger j + 1) * eulerian1 Inf.!! (fromIntegral i - 1) !! j++eulerian2Property1 :: Word -> Bool+eulerian2Property1 i = length (eulerian2 Inf.!! i) == fromIntegral i++eulerian2Property2 :: Positive Int -> Bool+eulerian2Property2 (Positive i)+  =  take 1 (eulerian2 Inf.!! fromIntegral i)+  == [1]++eulerian2Property3 :: Positive Int -> Bool+eulerian2Property3 (Positive i)+  =  eulerian2 Inf.!! fromIntegral i !! (i - 1)+  == product [1 .. toInteger i]++eulerian2Property4 :: Positive Int -> Positive Int -> Bool+eulerian2Property4 (Positive i) (Positive j)+  =  j >= i - 1+  || eulerian2 Inf.!! fromIntegral i !! j+  == toInteger (2 * i - j - 1) * eulerian2 Inf.!! (fromIntegral i - 1) !! (j - 1)+  +  (toInteger j + 1) * eulerian2 Inf.!! (fromIntegral i - 1) !! j++bernoulliSpecialCase1 :: Assertion+bernoulliSpecialCase1 = assertEqual "B_0 = 1" (Inf.head bernoulli) 1++bernoulliSpecialCase2 :: Assertion+bernoulliSpecialCase2 = assertEqual "B_1 = -1/2" (bernoulli Inf.!! 1) (- 1 % 2)++bernoulliProperty1 :: Word -> Bool+bernoulliProperty1 m+  = case signum (bernoulli Inf.!! m) of+    1  -> m == 0 || m `mod` 4 == 2+    0  -> m /= 1 && odd m+    -1 -> m == 1 || (m /= 0 && m `rem` 4 == 0)+    _  -> False++bernoulliProperty2 :: Word -> (Rational, Rational)+bernoulliProperty2 m =+  ( bernoulli Inf.!! m+  , (if m == 0 then 1 else 0)+  -  sum [ bernoulli Inf.!! k+         * (binomial Inf.!! m !! fromIntegral k % toInteger (m - k + 1))+         | k <- map fromIntegral [(0 :: Int) .. fromIntegral m - 1]+         ]+  )++-- | For every odd positive integer @n@, @E_n@ is @0@.+eulerProperty1 :: Positive Int -> Bool+eulerProperty1 (Positive n) = euler Inf.!! (2 * fromIntegral n - 1) == 0++-- | Every positive even index produces a negative result.+eulerProperty2 :: Word -> Bool+eulerProperty2 n = euler Inf.!! (2 + 4 * n) < 0++-- | The Euler number sequence is https://oeis.org/A122045+eulerSpecialCase1 :: Assertion+eulerSpecialCase1 = assertEqual "euler"+    (Inf.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 Inf.!! (2 * fromIntegral 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"+    (Inf.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"+    [ testSmallAndQuick "shape"      binomialProperty1+    , testSmallAndQuick "left side"  binomialProperty2+    , testSmallAndQuick "right side" binomialProperty3+    , testSmallAndQuick "recurrency" binomialProperty4+    , testSmallAndQuick "factorise . binomial = binomialFactors"  binomialProperty5+    , testSmallAndQuick "binomial = factorBack . binomialFactors" binomialProperty6+    , testSmallAndQuick "line"       binomialLineProperty1+    , testSmallAndQuick "diagonal"   binomialDiagonalProperty2+    ]+  , testGroup "binomialRotated"+    [ testSmallAndQuick "left side"  binomialRotatedProperty2+    , testSmallAndQuick "right side" binomialRotatedProperty3+    , testSmallAndQuick "recurrency" binomialRotatedProperty4+    , testSmallAndQuick "line"       binomialLineProperty2+    , testSmallAndQuick "diagonal"   binomialDiagonalProperty1+    ]+  , testGroup "stirling1"+    [ testSmallAndQuick "shape"      stirling1Property1+    , testSmallAndQuick "left side"  stirling1Property2+    , testSmallAndQuick "right side" stirling1Property3+    , testSmallAndQuick "recurrency" stirling1Property4+    ]+  , testGroup "stirling2"+    [ testSmallAndQuick "shape"      stirling2Property1+    , testSmallAndQuick "left side"  stirling2Property2+    , testSmallAndQuick "right side" stirling2Property3+    , testSmallAndQuick "recurrency" stirling2Property4+    ]+  , testGroup "lah"+    [ testSmallAndQuick "shape"         lahProperty1+    , testSmallAndQuick "left side"     lahProperty2+    , testSmallAndQuick "right side"    lahProperty3+    , testSmallAndQuick "zip stirlings" lahProperty4+    ]+  , testGroup "eulerian1"+    [ testSmallAndQuick "shape"      eulerian1Property1+    , testSmallAndQuick "left side"  eulerian1Property2+    , testSmallAndQuick "right side" eulerian1Property3+    , testSmallAndQuick "recurrency" eulerian1Property4+    ]+  , testGroup "eulerian2"+    [ testSmallAndQuick "shape"      eulerian2Property1+    , testSmallAndQuick "left side"  eulerian2Property2+    , testSmallAndQuick "right side" eulerian2Property3+    , testSmallAndQuick "recurrency" eulerian2Property4+    ]+  , testGroup "bernoulli"+    [ testCase "B_0"                           bernoulliSpecialCase1+    , testCase "B_1"                           bernoulliSpecialCase2+    , testSmallAndQuick "sign"                 bernoulliProperty1+    , testEqualSmallAndQuick "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+    ]+  ]
+ test-suite/Math/NumberTheory/Recurrences/LinearTests.hs view
@@ -0,0 +1,120 @@+-- |+-- Module:      Math.NumberTheory.Recurrences.LinearTests+-- Copyright:   (c) 2016 Andrew Lelechenko+-- Licence:     MIT+-- Maintainer:  Andrew Lelechenko <andrew.lelechenko@gmail.com>+--+-- Tests for Math.NumberTheory.Recurrences.Linear+--++{-# OPTIONS_GHC -fno-warn-type-defaults #-}++module Math.NumberTheory.Recurrences.LinearTests+  ( testSuite+  ) where++import Test.Tasty+import Test.Tasty.HUnit++import Control.Arrow+import Data.List (sort)+import qualified Data.List.Infinite as Inf++import Math.NumberTheory.Primes+import Math.NumberTheory.Recurrences.Linear+import Math.NumberTheory.TestUtils++-- | Check that 'fibonacci' matches the definition of Fibonacci sequence.+fibonacciProperty1 :: AnySign Int -> Bool+fibonacciProperty1 (AnySign n) = fibonacci n + fibonacci (n + 1) == fibonacci (n +2)++-- | Check that 'fibonacci' for negative indices is correctly defined.+fibonacciProperty2 :: Word -> Bool+fibonacciProperty2 n = fibonacci (fromIntegral n) == (if even n then negate else id) (fibonacci (- fromIntegral n))++-- | Check that 'fibonacciPair' is a pair of consequent 'fibonacci'.+fibonacciPairProperty :: AnySign Int -> Bool+fibonacciPairProperty (AnySign n) = fibonacciPair n == (fibonacci n, fibonacci (n + 1))++-- | Check that 'fibonacci 0' is 0.+fibonacciSpecialCase0 :: Assertion+fibonacciSpecialCase0 = assertEqual "fibonacci" (fibonacci 0) 0++-- | Check that 'fibonacci 1' is 1.+fibonacciSpecialCase1 :: Assertion+fibonacciSpecialCase1 = assertEqual "fibonacci" (fibonacci 1) 1+++-- | Check that 'lucas' matches the definition of Lucas sequence.+lucasProperty1 :: AnySign Int -> Bool+lucasProperty1 (AnySign n) = lucas n + lucas (n + 1) == lucas (n +2)++-- | Check that 'lucas' for negative indices is correctly defined.+lucasProperty2 :: Word -> Bool+lucasProperty2 n = lucas (fromIntegral n) == (if odd n then negate else id) (lucas (- fromIntegral n))++-- | Check that 'lucasPair' is a pair of consequent 'lucas'.+lucasPairProperty :: AnySign Int -> Bool+lucasPairProperty (AnySign n) = lucasPair n == (lucas n, lucas (n + 1))++-- | Check that 'lucas 0' is 2.+lucasSpecialCase0 :: Assertion+lucasSpecialCase0 = assertEqual "lucas" (lucas 0) 2++-- | Check that 'lucas 1' is 1.+lucasSpecialCase1 :: Assertion+lucasSpecialCase1 = assertEqual "lucas" (lucas 1) 1++-- | Check that 'generalLucas' matches its definition.+generalLucasProperty1 :: AnySign Integer -> AnySign Integer -> Word -> Bool+generalLucasProperty1 (AnySign p) (AnySign q) n = un1 == un1' && vn1 == vn1' && un2 == p * un1 - q * un && vn2 == p * vn1 - q * vn+  where+    (un, un1, vn, vn1) = generalLucas p q (fromIntegral n)+    (un1', un2, vn1', vn2) = generalLucas p q (fromIntegral n + 1)++-- | Check that 'generalLucas' 1 (-1) is 'fibonacciPair' plus 'lucasPair'.+generalLucasProperty2 :: Word -> Bool+generalLucasProperty2 n = (un, un1) == fibonacciPair (fromIntegral n) && (vn, vn1) == lucasPair (fromIntegral n)+  where+    (un, un1, vn, vn1) = generalLucas 1 (-1) (fromIntegral n)++-- | Check that 'generalLucas' p _ 0 is (0, 1, 2, p).+generalLucasProperty3 :: AnySign Integer -> AnySign Integer -> Bool+generalLucasProperty3 (AnySign p) (AnySign q) = generalLucas p q 0 == (0, 1, 2, p)++factorialProperty1 :: Word -> Bool+factorialProperty1 n = n > 100000 ||+  sort (map (first unPrime) (factorise (factorial Inf.!! n))) ==+    sort (map (first (toInteger . unPrime)) (factorialFactors n))++factorialProperty2 :: Word -> Bool+factorialProperty2 n = n > 100000 ||+  factorial Inf.!! n ==+    product (map (\(p, k) -> toInteger (unPrime p) ^ k) (factorialFactors n))++testSuite :: TestTree+testSuite = testGroup "Linear"+  [ testGroup "fibonacci"+    [ testSmallAndQuick "matches definition"  fibonacciProperty1+    , testSmallAndQuick "negative indices"    fibonacciProperty2+    , testSmallAndQuick "pair"                fibonacciPairProperty+    , testCase          "fibonacci 0"         fibonacciSpecialCase0+    , testCase          "fibonacci 1"         fibonacciSpecialCase1+    ]+  , testGroup "lucas"+    [ testSmallAndQuick "matches definition"  lucasProperty1+    , testSmallAndQuick "negative indices"    lucasProperty2+    , testSmallAndQuick "pair"                lucasPairProperty+    , testCase          "lucas 0"             lucasSpecialCase0+    , testCase          "lucas 1"             lucasSpecialCase1+    ]+  , testGroup "generalLucas"+    [ testSmallAndQuick "matches definition"  generalLucasProperty1+    , testSmallAndQuick "generalLucas 1 (-1)" generalLucasProperty2+    , testSmallAndQuick "generalLucas _ _ 0"  generalLucasProperty3+    ]+  , testGroup "factorial"+    [ testSmallAndQuick "factorise . factorial = factorialFactors"  factorialProperty1+    , testSmallAndQuick "factorial = factorBack . factorialFactors" factorialProperty2+    ]+  ]
+ test-suite/Math/NumberTheory/Recurrences/PentagonalTests.hs view
@@ -0,0 +1,101 @@+-- |+-- Module:      Math.NumberTheory.Recurrences.PentagonalTests+-- Copyright:   (c) 2018 Alexandre Rodrigues Baldé+-- Licence:     MIT+-- Maintainer:  Alexandre Rodrigues Baldé <alexandrer_b@outlook.com>+--+-- Tests for Math.NumberTheory.Recurrences.Pentagonal+--++{-# LANGUAGE PostfixOperators    #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns        #-}++{-# OPTIONS_GHC -fno-warn-type-defaults #-}++module Math.NumberTheory.Recurrences.PentagonalTests+  ( testSuite+  ) where++import Data.List.Infinite (Infinite(..), (...))+import qualified Data.List.Infinite as Inf+import Data.Proxy                    (Proxy (..))+import GHC.Natural                   (Natural)+import GHC.TypeNats                  (SomeNat (..), someNatVal)++import Math.NumberTheory.Moduli      (Mod, getVal)+import Math.NumberTheory.Recurrences (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 Inf.!!) . fromIntegral++-- | 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    = Inf.head pents           == 0+    | n > 0     = pents Inf.!! (2 * fromIntegral n - 1) == pent n+    | otherwise = pents Inf.!! (2 * fromIntegral (- 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"+    (Inf.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.Recurrences.Pentagonal@ to test the+-- reference implementation of @partition@.+pentagonalSigns :: Num a => [a] -> [a]+pentagonalSigns = zipWith (*) (cycle [1, 1, -1, -1])++-- | Copied from @Math.NumberTheory.Recurrences.Pentagonal@ to test the+-- reference implementation of @partition@.+pents :: (Enum a, Num a) => Infinite a+pents = Inf.interleave+  (Inf.scanl (\acc n -> acc + 3 * n - 1) 0 (1...))+  (Inf.scanl (\acc n -> acc + 3 * n - 2) 1 (2...))++-- | 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)) .+                     Inf.takeWhile (\m -> n - m >= 0) .+                     Inf.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))) =+    (Inf.take m' . Inf.map getVal $ (partition :: Infinite (Mod n))) ==+    map helper (Inf.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 "mod n" partitionProperty2+    , testCase          "first 20 elements of partition are correct"+                        partitionSpecialCase20+    ]+  , testGroup "Generalized pentagonal numbers"+    [ testSmallAndQuick "matches definition" pentagonalNumbersProperty1+    ]+  ]
− test-suite/Math/NumberTheory/Recurrencies/BilinearTests.hs 
@@ -1,196 +0,0 @@--- |--- Module:      Math.NumberTheory.Recurrencies.BilinearTests--- Copyright:   (c) 2016 Andrew Lelechenko--- Licence:     MIT--- Maintainer:  Andrew Lelechenko <andrew.lelechenko@gmail.com>--- Stability:   Provisional------ Tests for Math.NumberTheory.Recurrencies.Bilinear-----{-# OPTIONS_GHC -fno-warn-type-defaults #-}--module Math.NumberTheory.Recurrencies.BilinearTests-  ( testSuite-  ) where--import Test.Tasty-import Test.Tasty.HUnit--import Data.Ratio--import Math.NumberTheory.Recurrencies.Bilinear-import Math.NumberTheory.TestUtils--binomialProperty1 :: NonNegative Int -> Bool-binomialProperty1 (NonNegative i) = length (binomial !! i) == i + 1--binomialProperty2 :: NonNegative Int -> Bool-binomialProperty2 (NonNegative i) = binomial !! i !! 0 == 1--binomialProperty3 :: NonNegative Int -> Bool-binomialProperty3 (NonNegative i) = binomial !! i !! i == 1--binomialProperty4 :: Positive Int -> Positive Int -> Bool-binomialProperty4 (Positive i) (Positive j)-  =  j >= i-  || binomial !! i !! j-  == binomial !! (i - 1) !! (j - 1)-  +  binomial !! (i - 1) !! j--stirling1Property1 :: NonNegative Int -> Bool-stirling1Property1 (NonNegative i) = length (stirling1 !! i) == i + 1--stirling1Property2 :: NonNegative Int -> Bool-stirling1Property2 (NonNegative i)-  =  stirling1 !! i !! 0-  == if i == 0 then 1 else 0--stirling1Property3 :: NonNegative Int -> Bool-stirling1Property3 (NonNegative i) = stirling1 !! i !! i == 1--stirling1Property4 :: Positive Int -> Positive Int -> Bool-stirling1Property4 (Positive i) (Positive j)-  =  j >= i-  || stirling1 !! i !! j-  == stirling1 !! (i - 1) !! (j - 1)-  +  (toInteger i - 1) * stirling1 !! (i - 1) !! j--stirling2Property1 :: NonNegative Int -> Bool-stirling2Property1 (NonNegative i) = length (stirling2 !! i) == i + 1--stirling2Property2 :: NonNegative Int -> Bool-stirling2Property2 (NonNegative i)-  =  stirling2 !! i !! 0-  == if i == 0 then 1 else 0--stirling2Property3 :: NonNegative Int -> Bool-stirling2Property3 (NonNegative i) = stirling2 !! i !! i == 1--stirling2Property4 :: Positive Int -> Positive Int -> Bool-stirling2Property4 (Positive i) (Positive j)-  =  j >= i-  || stirling2 !! i !! j-  == stirling2 !! (i - 1) !! (j - 1)-  +  toInteger j * stirling2 !! (i - 1) !! j--lahProperty1 :: NonNegative Int -> Bool-lahProperty1 (NonNegative i) = length (lah !! i) == i + 1--lahProperty2 :: NonNegative Int -> Bool-lahProperty2 (NonNegative i)-  =  lah !! i !! 0-  == product [1 .. i+1]--lahProperty3 :: NonNegative Int -> Bool-lahProperty3 (NonNegative i) = lah !! i !! i == 1--lahProperty4 :: Positive Int -> Positive Int -> Bool-lahProperty4 (Positive i) (Positive j)-  =  j >= i-  || lah !! i !! j-  == sum [ stirling1 !! (i + 1) !! k * stirling2 !! k !! (j + 1) | k <- [j + 1 .. i + 1] ]--eulerian1Property1 :: NonNegative Int -> Bool-eulerian1Property1 (NonNegative i) = length (eulerian1 !! i) == i--eulerian1Property2 :: Positive Int -> Bool-eulerian1Property2 (Positive i) = eulerian1 !! i !! 0 == 1--eulerian1Property3 :: Positive Int -> Bool-eulerian1Property3 (Positive i) = eulerian1 !! i !! (i - 1) == 1--eulerian1Property4 :: Positive Int -> Positive Int -> Bool-eulerian1Property4 (Positive i) (Positive j)-  =  j >= i - 1-  || eulerian1 !! i !! j-  == (toInteger $ i - j) * eulerian1 !! (i - 1) !! (j - 1)-  +  (toInteger   j + 1) * eulerian1 !! (i - 1) !! j--eulerian2Property1 :: NonNegative Int -> Bool-eulerian2Property1 (NonNegative i) = length (eulerian2 !! i) == i--eulerian2Property2 :: Positive Int -> Bool-eulerian2Property2 (Positive i)-  =  eulerian2 !! i !! 0 == 1--eulerian2Property3 :: Positive Int -> Bool-eulerian2Property3 (Positive i)-  =  eulerian2 !! i !! (i - 1)-  == product [1 .. toInteger i]--eulerian2Property4 :: Positive Int -> Positive Int -> Bool-eulerian2Property4 (Positive i) (Positive j)-  =  j >= i - 1-  || eulerian2 !! i !! j-  == (toInteger $ 2 * i - j - 1) * eulerian2 !! (i - 1) !! (j - 1)-  +  (toInteger j + 1) * eulerian2 !! (i - 1) !! j--bernoulliSpecialCase1 :: Assertion-bernoulliSpecialCase1 = assertEqual "B_0 = 1" (bernoulli !! 0) 1--bernoulliSpecialCase2 :: Assertion-bernoulliSpecialCase2 = assertEqual "B_1 = -1/2" (bernoulli !! 1) (- 1 % 2)--bernoulliProperty1 :: NonNegative Int -> Bool-bernoulliProperty1 (NonNegative m)-  = case signum (bernoulli !! m) of-    1  -> m == 0 || m `mod` 4 == 2-    0  -> m /= 1 && odd m-    -1 -> m == 1 || (m /= 0 && m `mod` 4 == 0)-    _  -> False--bernoulliProperty2 :: NonNegative Int -> Bool-bernoulliProperty2 (NonNegative m)-  =  bernoulli !! m-  == (if m == 0 then 1 else 0)-  -  sum [ bernoulli !! k-         * (binomial !! m !! k % (toInteger $ m - k + 1))-         | k <- [0 .. m - 1]-         ]--testSuite :: TestTree-testSuite = testGroup "Bilinear"-  [ testGroup "binomial"-    [ testSmallAndQuick "shape"      binomialProperty1-    , testSmallAndQuick "left side"  binomialProperty2-    , testSmallAndQuick "right side" binomialProperty3-    , testSmallAndQuick "recurrency" binomialProperty4-    ]-  , testGroup "stirling1"-    [ testSmallAndQuick "shape"      stirling1Property1-    , testSmallAndQuick "left side"  stirling1Property2-    , testSmallAndQuick "right side" stirling1Property3-    , testSmallAndQuick "recurrency" stirling1Property4-    ]-  , testGroup "stirling2"-    [ testSmallAndQuick "shape"      stirling2Property1-    , testSmallAndQuick "left side"  stirling2Property2-    , testSmallAndQuick "right side" stirling2Property3-    , testSmallAndQuick "recurrency" stirling2Property4-    ]-  , testGroup "lah"-    [ testSmallAndQuick "shape"         lahProperty1-    , testSmallAndQuick "left side"     lahProperty2-    , testSmallAndQuick "right side"    lahProperty3-    , testSmallAndQuick "zip stirlings" lahProperty4-    ]-  , testGroup "eulerian1"-    [ testSmallAndQuick "shape"      eulerian1Property1-    , testSmallAndQuick "left side"  eulerian1Property2-    , testSmallAndQuick "right side" eulerian1Property3-    , testSmallAndQuick "recurrency" eulerian1Property4-    ]-  , testGroup "eulerian2"-    [ testSmallAndQuick "shape"      eulerian2Property1-    , testSmallAndQuick "left side"  eulerian2Property2-    , testSmallAndQuick "right side" eulerian2Property3-    , testSmallAndQuick "recurrency" eulerian2Property4-    ]-  , testGroup "bernoulli"-    [ testCase "B_0"                           bernoulliSpecialCase1-    , testCase "B_1"                           bernoulliSpecialCase2-    , testSmallAndQuick "sign"                 bernoulliProperty1-    , testSmallAndQuick "recursive definition" bernoulliProperty2-    ]-  ]
− test-suite/Math/NumberTheory/Recurrencies/LinearTests.hs 
@@ -1,104 +0,0 @@--- |--- Module:      Math.NumberTheory.Recurrencies.LinearTests--- Copyright:   (c) 2016 Andrew Lelechenko--- Licence:     MIT--- Maintainer:  Andrew Lelechenko <andrew.lelechenko@gmail.com>--- Stability:   Provisional------ Tests for Math.NumberTheory.Recurrencies.Linear-----{-# LANGUAGE CPP       #-}--{-# OPTIONS_GHC -fno-warn-type-defaults #-}--module Math.NumberTheory.Recurrencies.LinearTests-  ( testSuite-  ) where--import Test.Tasty-import Test.Tasty.HUnit--import Math.NumberTheory.Recurrencies.Linear-import Math.NumberTheory.TestUtils---- | Check that 'fibonacci' matches the definition of Fibonacci sequence.-fibonacciProperty1 :: AnySign Int -> Bool-fibonacciProperty1 (AnySign n) = fibonacci n + fibonacci (n + 1) == fibonacci (n +2)---- | Check that 'fibonacci' for negative indices is correctly defined.-fibonacciProperty2 :: NonNegative Int -> Bool-fibonacciProperty2 (NonNegative n) = fibonacci n == (if even n then negate else id) (fibonacci (- n))---- | Check that 'fibonacciPair' is a pair of consequent 'fibonacci'.-fibonacciPairProperty :: AnySign Int -> Bool-fibonacciPairProperty (AnySign n) = fibonacciPair n == (fibonacci n, fibonacci (n + 1))---- | Check that 'fibonacci 0' is 0.-fibonacciSpecialCase0 :: Assertion-fibonacciSpecialCase0 = assertEqual "fibonacci" (fibonacci 0) 0---- | Check that 'fibonacci 1' is 1.-fibonacciSpecialCase1 :: Assertion-fibonacciSpecialCase1 = assertEqual "fibonacci" (fibonacci 1) 1----- | Check that 'lucas' matches the definition of Lucas sequence.-lucasProperty1 :: AnySign Int -> Bool-lucasProperty1 (AnySign n) = lucas n + lucas (n + 1) == lucas (n +2)---- | Check that 'lucas' for negative indices is correctly defined.-lucasProperty2 :: NonNegative Int -> Bool-lucasProperty2 (NonNegative n) = lucas n == (if odd n then negate else id) (lucas (- n))---- | Check that 'lucasPair' is a pair of consequent 'lucas'.-lucasPairProperty :: AnySign Int -> Bool-lucasPairProperty (AnySign n) = lucasPair n == (lucas n, lucas (n + 1))---- | Check that 'lucas 0' is 2.-lucasSpecialCase0 :: Assertion-lucasSpecialCase0 = assertEqual "lucas" (lucas 0) 2---- | Check that 'lucas 1' is 1.-lucasSpecialCase1 :: Assertion-lucasSpecialCase1 = assertEqual "lucas" (lucas 1) 1---- | Check that 'generalLucas' matches its definition.-generalLucasProperty1 :: AnySign Integer -> AnySign Integer -> NonNegative Int -> Bool-generalLucasProperty1 (AnySign p) (AnySign q) (NonNegative n) = un1 == un1' && vn1 == vn1' && un2 == p * un1 - q * un && vn2 == p * vn1 - q * vn-  where-    (un, un1, vn, vn1) = generalLucas p q n-    (un1', un2, vn1', vn2) = generalLucas p q (n + 1)---- | Check that 'generalLucas' 1 (-1) is 'fibonacciPair' plus 'lucasPair'.-generalLucasProperty2 :: NonNegative Int -> Bool-generalLucasProperty2 (NonNegative n) = (un, un1) == fibonacciPair n && (vn, vn1) == lucasPair n-  where-    (un, un1, vn, vn1) = generalLucas 1 (-1) n---- | Check that 'generalLucas' p _ 0 is (0, 1, 2, p).-generalLucasProperty3 :: AnySign Integer -> AnySign Integer -> Bool-generalLucasProperty3 (AnySign p) (AnySign q) = generalLucas p q 0 == (0, 1, 2, p)--testSuite :: TestTree-testSuite = testGroup "Linear"-  [ testGroup "fibonacci"-    [ testSmallAndQuick "matches definition"  fibonacciProperty1-    , testSmallAndQuick "negative indices"    fibonacciProperty2-    , testSmallAndQuick "pair"                fibonacciPairProperty-    , testCase          "fibonacci 0"         fibonacciSpecialCase0-    , testCase          "fibonacci 1"         fibonacciSpecialCase1-    ]-  , testGroup "lucas"-    [ testSmallAndQuick "matches definition"  lucasProperty1-    , testSmallAndQuick "negative indices"    lucasProperty2-    , testSmallAndQuick "pair"                lucasPairProperty-    , testCase          "lucas 0"             lucasSpecialCase0-    , testCase          "lucas 1"             lucasSpecialCase1-    ]-  , testGroup "generalLucas"-    [ testSmallAndQuick "matches definition"  generalLucasProperty1-    , testSmallAndQuick "generalLucas 1 (-1)" generalLucasProperty2-    , testSmallAndQuick "generalLucas _ _ 0"  generalLucasProperty3-    ]-  ]
+ test-suite/Math/NumberTheory/RootsOfUnityTests.hs view
@@ -0,0 +1,25 @@+-- |+-- Module:       Math.NumberTheory.RootsOfUnityTests+-- Copyright:    (c) 2018 Bhavik Mehta+-- License:      MIT+-- Maintainer:   Andrew Lelechenko <andrew.lelechenko@gmail.com>+--+-- Tests for Math.NumberTheory.RootsOfUnity+--++module Math.NumberTheory.RootsOfUnityTests where++import Test.Tasty++import Data.Complex+import Data.Ratio+import Data.Semigroup++import Math.NumberTheory.DirichletCharacters (toRootOfUnity, toComplex)+import Math.NumberTheory.TestUtils (testSmallAndQuick, Positive(..))++rootOfUnityTest :: Integer -> Positive Integer -> Bool+rootOfUnityTest n (Positive d) = toComplex ((d `div` gcd n d) `stimes` toRootOfUnity (n % d)) == (1 :: Complex Double)++testSuite :: TestTree+testSuite = testSmallAndQuick "RootOfUnity contains roots of unity" rootOfUnityTest
+ test-suite/Math/NumberTheory/SmoothNumbersTests.hs view
@@ -0,0 +1,126 @@+-- |+-- Module:      Math.NumberTheory.SmoothNumbersTests+-- Copyright:   (c) 2018 Andrew Lelechenko+-- Licence:     MIT+-- Maintainer:  Andrew Lelechenko <andrew.lelechenko@gmail.com>+--+-- Tests for Math.NumberTheory.SmoothNumbersTests+--++{-# LANGUAGE TypeApplications    #-}++{-# OPTIONS_GHC -fno-warn-type-defaults #-}++module Math.NumberTheory.SmoothNumbersTests+  ( testSuite+  ) where++import Prelude hiding (mod, rem)+import Test.Tasty+import Test.Tasty.HUnit++import Data.Coerce+import Data.Euclidean+import Data.List (nub)+import Data.List.Infinite (Infinite(..))+import qualified Data.List.Infinite as Inf+import Numeric.Natural++import Math.NumberTheory.Primes (Prime (..))+import qualified Math.NumberTheory.Quadratic.GaussianIntegers as G+import qualified Math.NumberTheory.Quadratic.EisensteinIntegers as E+import Math.NumberTheory.SmoothNumbers (SmoothBasis, fromList, isSmooth, smoothOver, smoothOver')+import Math.NumberTheory.TestUtils++isSmoothPropertyHelper+  :: (Eq a, Num a, Euclidean a)+  => (a -> Integer)+  -> Infinite a+  -> Int+  -> Int+  -> Bool+isSmoothPropertyHelper norm primes' i1 i2 =+    let primes = Inf.take i1 primes'+        basis  = fromList primes+    in all (isSmooth basis) $ take i2 $ smoothOver' norm basis++isSmoothProperty1 :: Positive Int -> Positive Int -> Bool+isSmoothProperty1 (Positive i1) (Positive i2) =+    isSmoothPropertyHelper G.norm (fmap unPrime G.primes) i1 i2++isSmoothProperty2 :: Positive Int -> Positive Int -> Bool+isSmoothProperty2 (Positive i1) (Positive i2) =+    isSmoothPropertyHelper E.norm (fmap unPrime E.primes) i1 i2++smoothOverInRange :: Integral a => SmoothBasis a -> a -> a -> [a]+smoothOverInRange s lo hi+  = takeWhile (<= hi)+  $ dropWhile (< lo)+  $ smoothOver s++smoothOverInRangeBF+  :: (Eq a, Enum a, GcdDomain a)+  => SmoothBasis a+  -> a+  -> a+  -> [a]+smoothOverInRangeBF prs lo hi+  = coerce+  $ filter (isSmooth prs)+  $ coerce [lo..hi]++smoothOverInRangeProperty+  :: (Show a, Integral a)+  => (SmoothBasis a, Positive a, Positive a)+  -> ([a], [a])+smoothOverInRangeProperty (s, Positive lo', Positive diff') =+  (map unwrapIntegral xs, map unwrapIntegral ys)+  where+    lo   = WrapIntegral lo'   `rem` 2^18+    diff = WrapIntegral diff' `rem` 2^18+    hi   = lo + diff+    xs   = smoothOverInRange   (coerce s) lo hi+    ys   = smoothOverInRangeBF (coerce s) lo hi++smoothNumbersAreUniqueProperty+  :: (Show a, Integral a)+  => SmoothBasis a+  -> Positive Int+  -> Bool+smoothNumbersAreUniqueProperty s (Positive len)+  = nub l == l+  where+    l = take len $ smoothOver s++isSmoothSpecialCase1 :: Assertion+isSmoothSpecialCase1 = assertBool "should be distinct" $ nub l == l+  where+    b = fromList [1+3*G.ι,6+8*G.ι]+    l = take 10 $ map abs $ smoothOver' G.norm b++isSmoothSpecialCase2 :: Assertion+isSmoothSpecialCase2 = assertBool "should be smooth" $ isSmooth b 6+  where+    b = fromList [4, 3, 6, 10, 7::Int]++testSuite :: TestTree+testSuite = testGroup "SmoothNumbers"+  [ testGroup "smoothOverInRange == smoothOverInRangeBF"+    [ testEqualSmallAndQuick "Int"     (smoothOverInRangeProperty @Int)+    , testEqualSmallAndQuick "Word"    (smoothOverInRangeProperty @Word)+    , testEqualSmallAndQuick "Integer" (smoothOverInRangeProperty @Integer)+    , testEqualSmallAndQuick "Natural" (smoothOverInRangeProperty @Natural)+    ]+  , testGroup "smoothOver generates a list without duplicates"+    [ testSmallAndQuick "Integer" (smoothNumbersAreUniqueProperty @Integer)+    , testSmallAndQuick "Natural" (smoothNumbersAreUniqueProperty @Natural)+    ]+  , testGroup "Quadratic rings"+    [ testGroup "smoothOver generates valid smooth numbers"+      [ testSmallAndQuick "Gaussian"   isSmoothProperty1+      , testSmallAndQuick "Eisenstein" isSmoothProperty2+      ]+    , testCase "all distinct for base [1+3*i,6+8*i]" isSmoothSpecialCase1+    , testCase "6 is smooth for base [4,3,6,10,7]" isSmoothSpecialCase2+    ]+  ]
test-suite/Math/NumberTheory/TestUtils.hs view
@@ -3,8 +3,6 @@ -- Copyright:   (c) 2016 Andrew Lelechenko -- Licence:     MIT -- Maintainer:  Andrew Lelechenko <andrew.lelechenko@gmail.com>--- Stability:   Provisional--- Portability: Non-portable (GHC extensions) -- -- Utils to test Math.NumberTheory --@@ -14,19 +12,15 @@ {-# LANGUAGE DataKinds                  #-} {-# LANGUAGE FlexibleContexts           #-} {-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE KindSignatures             #-} {-# LANGUAGE MultiParamTypeClasses      #-} {-# LANGUAGE RankNTypes                 #-} {-# LANGUAGE ScopedTypeVariables        #-} {-# LANGUAGE TypeFamilies               #-} {-# LANGUAGE TypeOperators              #-} {-# LANGUAGE UndecidableInstances       #-}--#if __GLASGOW_HASKELL__ >= 800 {-# LANGUAGE UndecidableSuperClasses    #-}  {-# OPTIONS_GHC -fconstraint-solver-iterations=0 #-}-#endif  {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-}@@ -36,152 +30,251 @@   , module Math.NumberTheory.TestUtils.MyCompose   , module Test.SmallCheck.Series   , Large(..)+  , NonZero(..)   , testIntegralProperty+  , testIntegralPropertyNoLarge   , testSameIntegralProperty+  , testSameIntegralProperty3   , testIntegral2Property   , testSmallAndQuick+  , testEqualSmallAndQuick++  -- * Export for @Zeta@ tests+  , assertEqualUpToEps++  -- * Export for Inverse tests+  , TestableIntegral++  , lawsToTest   ) where -import Test.SmallCheck.Series (cons2)+import Test.QuickCheck.Classes+import Test.SmallCheck.Series (Positive(..), NonNegative(..), NonZero(..), Serial(..), Series, generate, (\/), 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.SmallCheck.Series (Positive(..), NonNegative(..), Serial(..), Series, generate)--#if !(MIN_VERSION_base(4,8,0))-import Control.Applicative-import Data.Word-#endif+import Test.Tasty.QuickCheck as QC hiding (Positive(..), NonNegative(..), NonZero(..), generate)  import Data.Bits-import GHC.Exts+import Data.Euclidean+import Data.Kind+import Data.Semiring (Semiring) import Numeric.Natural -import Math.NumberTheory.GaussianIntegers (GaussianInteger(..))+import qualified Math.NumberTheory.Quadratic.EisensteinIntegers as E (EisensteinInteger(..))+import Math.NumberTheory.Quadratic.GaussianIntegers (GaussianInteger(..))+import Math.NumberTheory.Primes (Prime, UniqueFactorisation)+import qualified Math.NumberTheory.SmoothNumbers as SN  import Math.NumberTheory.TestUtils.MyCompose import Math.NumberTheory.TestUtils.Wrappers +#if !MIN_VERSION_QuickCheck(2,17,0) instance Arbitrary Natural where   arbitrary = fromInteger <$> (arbitrary `suchThat` (>= 0))   shrink = map fromInteger . filter (>= 0) . shrink . toInteger+#endif -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 (:+) +-------------------------------------------------------------------------------+-- SmoothNumbers++instance (Ord a, Num a, Euclidean a, Arbitrary a) => Arbitrary (SN.SmoothBasis a) where+  arbitrary = SN.fromList <$> arbitrary+  shrink xs = SN.fromList <$> shrink (SN.unSmoothBasis xs)++instance (Ord a, Num a, Euclidean a, Serial m a) => Serial m (SN.SmoothBasis a) where+  series = SN.fromList <$> series++-------------------------------------------------------------------------------+ -- 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 instance (f (g x)) => (f `Compose` g) x -type family ConcatMap (w :: * -> Constraint) (cs :: [*]) :: Constraint+type family ConcatMap (w :: Type -> Constraint) (cs :: [Type]) :: Constraint   where     ConcatMap w '[] = ()     ConcatMap w (c ': cs) = (w c, ConcatMap w cs) -type family Matrix (as :: [* -> Constraint]) (w :: * -> *) (bs :: [*]) :: Constraint+type family Matrix (as :: [Type -> Constraint]) (w :: Type -> Type) (bs :: [Type]) :: Constraint   where     Matrix '[] w bs = ()     Matrix (a ': as) w bs = (ConcatMap (a `Compose` w) bs, Matrix as w bs)  type TestableIntegral wrapper =-  ( Matrix '[Arbitrary, Show, Serial IO] wrapper '[Int, Word, Integer]-  , Matrix '[Arbitrary, Show] wrapper '[Large Int, Large Word, Huge Integer]+  ( Matrix '[Arbitrary, Show, Serial IO] wrapper '[Int, Word, Integer, Natural]+  , Matrix '[Arbitrary, Show] wrapper '[Large Int, Large Word, Huge Integer, Huge Natural]   , Matrix '[Bounded, Integral] wrapper '[Int, Word]   , Num (wrapper Integer)+  , Num (wrapper Natural)   , Functor wrapper   ) - testIntegralProperty   :: forall wrapper bool. (TestableIntegral wrapper, SC.Testable IO bool, QC.Testable bool)-  => String -> (forall a. (Integral a, Bits a) => wrapper a -> bool) -> TestTree+  => String -> (forall a. (GcdDomain a, Euclidean a, Semiring 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)   , SC.testProperty "smallcheck Integer" (f :: wrapper Integer -> bool)+  , SC.testProperty "smallcheck Natural" (f :: wrapper Natural -> bool)   , QC.testProperty "quickcheck Int"     (f :: wrapper Int     -> bool)   , QC.testProperty "quickcheck Word"    (f :: wrapper Word    -> bool)   , QC.testProperty "quickcheck Integer" (f :: wrapper Integer -> bool)+  , QC.testProperty "quickcheck Natural" (f :: wrapper Natural -> bool)   , QC.testProperty "quickcheck Large Int"     ((f :: wrapper Int     -> bool) . getLarge)   , QC.testProperty "quickcheck Large Word"    ((f :: wrapper Word    -> bool) . getLarge)   , QC.testProperty "quickcheck Huge  Integer" ((f :: wrapper Integer -> bool) . getHuge)+  , QC.testProperty "quickcheck Huge  Natural" ((f :: wrapper Natural -> bool) . getHuge)   ] +testIntegralPropertyNoLarge+  :: forall wrapper bool. (TestableIntegral wrapper, SC.Testable IO bool, QC.Testable bool)+  => String -> (forall a. (Euclidean a, Semiring a, Integral a, Bits a, UniqueFactorisation a, Show a, Enum (Prime a)) => wrapper a -> bool) -> TestTree+testIntegralPropertyNoLarge name f = testGroup name+  [ SC.testProperty "smallcheck Int"     (f :: wrapper Int     -> bool)+  , SC.testProperty "smallcheck Word"    (f :: wrapper Word    -> bool)+  , SC.testProperty "smallcheck Integer" (f :: wrapper Integer -> bool)+  , SC.testProperty "smallcheck Natural" (f :: wrapper Natural -> bool)+  , QC.testProperty "quickcheck Int"     (f :: wrapper Int     -> bool)+  , QC.testProperty "quickcheck Word"    (f :: wrapper Word    -> bool)+  , QC.testProperty "quickcheck Integer" (f :: wrapper Integer -> bool)+  , QC.testProperty "quickcheck Natural" (f :: wrapper Natural -> bool)+  ]+ testSameIntegralProperty   :: forall wrapper1 wrapper2 bool. (TestableIntegral wrapper1, TestableIntegral wrapper2, SC.Testable IO bool, QC.Testable bool)-  => String -> (forall a. (Integral a, Bits a) => wrapper1 a -> wrapper2 a -> bool) -> TestTree+  => String -> (forall a. (GcdDomain a, Euclidean a, Integral a, Bits a, UniqueFactorisation a, Show a) => wrapper1 a -> wrapper2 a -> bool) -> TestTree testSameIntegralProperty name f = testGroup name   [ SC.testProperty "smallcheck Int"     (f :: wrapper1 Int     -> wrapper2 Int     -> bool)   , SC.testProperty "smallcheck Word"    (f :: wrapper1 Word    -> wrapper2 Word    -> bool)   , SC.testProperty "smallcheck Integer" (f :: wrapper1 Integer -> wrapper2 Integer -> bool)+  , SC.testProperty "smallcheck Natural" (f :: wrapper1 Natural -> wrapper2 Natural -> bool)   , QC.testProperty "quickcheck Int"     (f :: wrapper1 Int     -> wrapper2 Int     -> bool)   , QC.testProperty "quickcheck Word"    (f :: wrapper1 Word    -> wrapper2 Word    -> bool)   , QC.testProperty "quickcheck Integer" (f :: wrapper1 Integer -> wrapper2 Integer -> bool)+  , QC.testProperty "quickcheck Natural" (f :: wrapper1 Natural -> wrapper2 Natural -> bool)   , QC.testProperty "quickcheck Large Int"     (\a b -> (f :: wrapper1 Int     -> wrapper2 Int     -> bool) (getLarge <$> a) (getLarge <$> b))   , QC.testProperty "quickcheck Large Word"    (\a b -> (f :: wrapper1 Word    -> wrapper2 Word    -> bool) (getLarge <$> a) (getLarge <$> b))   , QC.testProperty "quickcheck Huge  Integer" (\a b -> (f :: wrapper1 Integer -> wrapper2 Integer -> bool) (getHuge  <$> a) (getHuge  <$> b))+  , QC.testProperty "quickcheck Huge  Natural" (\a b -> (f :: wrapper1 Natural -> wrapper2 Natural -> bool) (getHuge  <$> a) (getHuge  <$> b))   ] +testSameIntegralProperty3+  :: forall wrapper1 wrapper2 wrapper3 bool. (TestableIntegral wrapper1, TestableIntegral wrapper2, TestableIntegral wrapper3, SC.Testable IO bool, QC.Testable bool)+  => String -> (forall a. (Euclidean a, Integral a, Bits a, UniqueFactorisation a, Show a) => wrapper1 a -> wrapper2 a -> wrapper3 a -> bool) -> TestTree+testSameIntegralProperty3 name f = testGroup name+  [ SC.testProperty "smallcheck Int"     (f :: wrapper1 Int     -> wrapper2 Int     -> wrapper3 Int     -> bool)+  , SC.testProperty "smallcheck Word"    (f :: wrapper1 Word    -> wrapper2 Word    -> wrapper3 Word    -> bool)+  , SC.testProperty "smallcheck Integer" (f :: wrapper1 Integer -> wrapper2 Integer -> wrapper3 Integer -> bool)+  , SC.testProperty "smallcheck Natural" (f :: wrapper1 Natural -> wrapper2 Natural -> wrapper3 Natural -> bool)+  , QC.testProperty "quickcheck Int"     (f :: wrapper1 Int     -> wrapper2 Int     -> wrapper3 Int     -> bool)+  , QC.testProperty "quickcheck Word"    (f :: wrapper1 Word    -> wrapper2 Word    -> wrapper3 Word    -> bool)+  , QC.testProperty "quickcheck Integer" (f :: wrapper1 Integer -> wrapper2 Integer -> wrapper3 Integer -> bool)+  , QC.testProperty "quickcheck Natural" (f :: wrapper1 Natural -> wrapper2 Natural -> wrapper3 Natural -> bool)+  , QC.testProperty "quickcheck Large Int"     (\a b c -> (f :: wrapper1 Int     -> wrapper2 Int     -> wrapper3 Int     -> bool) (getLarge <$> a) (getLarge <$> b) (getLarge <$> c))+  , QC.testProperty "quickcheck Large Word"    (\a b c -> (f :: wrapper1 Word    -> wrapper2 Word    -> wrapper3 Word    -> bool) (getLarge <$> a) (getLarge <$> b) (getLarge <$> c))+  , QC.testProperty "quickcheck Huge  Integer" (\a b c -> (f :: wrapper1 Integer -> wrapper2 Integer -> wrapper3 Integer -> bool) (getHuge  <$> a) (getHuge  <$> b) (getHuge  <$> c))+  , QC.testProperty "quickcheck Huge  Natural" (\a b c -> (f :: wrapper1 Natural -> wrapper2 Natural -> wrapper3 Natural -> bool) (getHuge  <$> a) (getHuge  <$> b) (getHuge  <$> c))+  ]+ testIntegral2Property   :: forall wrapper1 wrapper2 bool. (TestableIntegral wrapper1, TestableIntegral wrapper2, SC.Testable IO bool, QC.Testable bool)-  => String -> (forall a1 a2. (Integral a1, Integral a2, Bits a1, Bits a2) => wrapper1 a1 -> wrapper2 a2 -> bool) -> TestTree+  => String -> (forall a1 a2. (Integral a1, Integral a2, Bits a1, Bits a2, UniqueFactorisation a1, UniqueFactorisation a2, Show a1, Show a2) => wrapper1 a1 -> wrapper2 a2 -> bool) -> TestTree testIntegral2Property name f = testGroup name   [ SC.testProperty "smallcheck Int Int"         (f :: wrapper1 Int     -> wrapper2 Int     -> bool)   , SC.testProperty "smallcheck Int Word"        (f :: wrapper1 Int     -> wrapper2 Word    -> bool)   , SC.testProperty "smallcheck Int Integer"     (f :: wrapper1 Int     -> wrapper2 Integer -> bool)+  , SC.testProperty "smallcheck Int Natural"     (f :: wrapper1 Int     -> wrapper2 Natural -> bool)   , SC.testProperty "smallcheck Word Int"        (f :: wrapper1 Word    -> wrapper2 Int     -> bool)   , SC.testProperty "smallcheck Word Word"       (f :: wrapper1 Word    -> wrapper2 Word    -> bool)   , SC.testProperty "smallcheck Word Integer"    (f :: wrapper1 Word    -> wrapper2 Integer -> bool)+  , SC.testProperty "smallcheck Word Natural"    (f :: wrapper1 Word    -> wrapper2 Natural -> bool)   , SC.testProperty "smallcheck Integer Int"     (f :: wrapper1 Integer -> wrapper2 Int     -> bool)   , SC.testProperty "smallcheck Integer Word"    (f :: wrapper1 Integer -> wrapper2 Word    -> bool)   , SC.testProperty "smallcheck Integer Integer" (f :: wrapper1 Integer -> wrapper2 Integer -> bool)+  , SC.testProperty "smallcheck Integer Natural" (f :: wrapper1 Integer -> wrapper2 Natural -> bool)+  , SC.testProperty "smallcheck Natural Int"     (f :: wrapper1 Natural -> wrapper2 Int     -> bool)+  , SC.testProperty "smallcheck Natural Word"    (f :: wrapper1 Natural -> wrapper2 Word    -> bool)+  , SC.testProperty "smallcheck Natural Integer" (f :: wrapper1 Natural -> wrapper2 Integer -> bool)+  , SC.testProperty "smallcheck Natural Natural" (f :: wrapper1 Natural -> wrapper2 Natural -> bool)    , QC.testProperty "quickcheck Int Int"         (f :: wrapper1 Int     -> wrapper2 Int     -> bool)   , QC.testProperty "quickcheck Int Word"        (f :: wrapper1 Int     -> wrapper2 Word    -> bool)   , QC.testProperty "quickcheck Int Integer"     (f :: wrapper1 Int     -> wrapper2 Integer -> bool)+  , QC.testProperty "quickcheck Int Natural"     (f :: wrapper1 Int     -> wrapper2 Natural -> bool)   , QC.testProperty "quickcheck Word Int"        (f :: wrapper1 Word    -> wrapper2 Int     -> bool)   , QC.testProperty "quickcheck Word Word"       (f :: wrapper1 Word    -> wrapper2 Word    -> bool)   , QC.testProperty "quickcheck Word Integer"    (f :: wrapper1 Word    -> wrapper2 Integer -> bool)+  , QC.testProperty "quickcheck Word Natural"    (f :: wrapper1 Word    -> wrapper2 Natural -> bool)   , QC.testProperty "quickcheck Integer Int"     (f :: wrapper1 Integer -> wrapper2 Int     -> bool)   , QC.testProperty "quickcheck Integer Word"    (f :: wrapper1 Integer -> wrapper2 Word    -> bool)   , QC.testProperty "quickcheck Integer Integer" (f :: wrapper1 Integer -> wrapper2 Integer -> bool)+  , QC.testProperty "quickcheck Integer Natural" (f :: wrapper1 Integer -> wrapper2 Natural -> bool)+  , QC.testProperty "quickcheck Natural Int"     (f :: wrapper1 Natural -> wrapper2 Int     -> bool)+  , QC.testProperty "quickcheck Natural Word"    (f :: wrapper1 Natural -> wrapper2 Word    -> bool)+  , QC.testProperty "quickcheck Natural Integer" (f :: wrapper1 Natural -> wrapper2 Integer -> bool)+  , QC.testProperty "quickcheck Natural Natural" (f :: wrapper1 Natural -> wrapper2 Natural -> bool)    , QC.testProperty "quickcheck Large Int Int"         ((f :: wrapper1 Int     -> wrapper2 Int     -> bool) . fmap getLarge)   , QC.testProperty "quickcheck Large Int Word"        ((f :: wrapper1 Int     -> wrapper2 Word    -> bool) . fmap getLarge)   , QC.testProperty "quickcheck Large Int Integer"     ((f :: wrapper1 Int     -> wrapper2 Integer -> bool) . fmap getLarge)+  , QC.testProperty "quickcheck Large Int Natural"     ((f :: wrapper1 Int     -> wrapper2 Natural -> bool) . fmap getLarge)   , QC.testProperty "quickcheck Large Word Int"        ((f :: wrapper1 Word    -> wrapper2 Int     -> bool) . fmap getLarge)   , QC.testProperty "quickcheck Large Word Word"       ((f :: wrapper1 Word    -> wrapper2 Word    -> bool) . fmap getLarge)   , QC.testProperty "quickcheck Large Word Integer"    ((f :: wrapper1 Word    -> wrapper2 Integer -> bool) . fmap getLarge)+  , QC.testProperty "quickcheck Large Word Natural"    ((f :: wrapper1 Word    -> wrapper2 Natural -> bool) . fmap getLarge)   , QC.testProperty "quickcheck Huge  Integer Int"     ((f :: wrapper1 Integer -> wrapper2 Int     -> bool) . fmap getHuge)   , QC.testProperty "quickcheck Huge  Integer Word"    ((f :: wrapper1 Integer -> wrapper2 Word    -> bool) . fmap getHuge)   , QC.testProperty "quickcheck Huge  Integer Integer" ((f :: wrapper1 Integer -> wrapper2 Integer -> bool) . fmap getHuge)+  , QC.testProperty "quickcheck Huge  Integer Natural" ((f :: wrapper1 Integer -> wrapper2 Natural -> bool) . fmap getHuge)+  , QC.testProperty "quickcheck Huge  Natural Int"     ((f :: wrapper1 Natural -> wrapper2 Int     -> bool) . fmap getHuge)+  , QC.testProperty "quickcheck Huge  Natural Word"    ((f :: wrapper1 Natural -> wrapper2 Word    -> bool) . fmap getHuge)+  , QC.testProperty "quickcheck Huge  Natural Integer" ((f :: wrapper1 Natural -> wrapper2 Integer -> bool) . fmap getHuge)+  , QC.testProperty "quickcheck Huge  Natural Natural" ((f :: wrapper1 Natural -> wrapper2 Natural -> bool) . fmap getHuge)   ]  testSmallAndQuick-  :: SC.Testable IO a-  => QC.Testable a-  => String -> a -> TestTree+  :: (SC.Testable IO a, QC.Testable a)+  => String+  -> a+  -> TestTree testSmallAndQuick name f = testGroup name   [ SC.testProperty "smallcheck" f   , QC.testProperty "quickcheck" f   ]++testEqualSmallAndQuick+  :: (Serial IO a, Arbitrary a, Show a, Eq b, Show b)+  => String+  -> (a -> (b, b))+  -> TestTree+testEqualSmallAndQuick name f = testGroup name+  [ SC.testProperty "smallcheck" (uncurry (==)  . f)+  , QC.testProperty "quickcheck" (uncurry (===) . 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)++lawsToTest :: Laws -> TestTree+lawsToTest (Laws name props) =+  testGroup name $ map (uncurry QC.testProperty) props
test-suite/Math/NumberTheory/TestUtils/MyCompose.hs view
@@ -3,8 +3,6 @@ -- Copyright:   (c) 2016-2017 Andrew Lelechenko -- Licence:     MIT -- Maintainer:  Andrew Lelechenko <andrew.lelechenko@gmail.com>--- Stability:   Provisional--- Portability: Non-portable (GHC extensions) -- -- Utils to test Math.NumberTheory --@@ -25,6 +23,8 @@ import Test.QuickCheck (Arbitrary) import Test.SmallCheck.Series (Serial) +-- | As of @base-4.19@ Data.Functor.Compose has every instance we need,+-- except for instance Arbitrary, which overzealously requires Arbitrary1. newtype MyCompose f g a = MyCompose { getMyCompose :: f (g a) }   deriving (Eq, Ord, Show, Functor, Num, Enum, Bounded, Real, Integral, Arbitrary, Generic)
test-suite/Math/NumberTheory/TestUtils/Wrappers.hs view
@@ -3,21 +3,19 @@ -- Copyright:   (c) 2016 Andrew Lelechenko -- Licence:     MIT -- Maintainer:  Andrew Lelechenko <andrew.lelechenko@gmail.com>--- Stability:   Provisional--- Portability: Non-portable (GHC extensions) -- -- Utils to test Math.NumberTheory -- -{-# LANGUAGE CPP                        #-}-{-# LANGUAGE DeriveFoldable             #-}-{-# LANGUAGE DeriveFunctor              #-} {-# LANGUAGE DeriveTraversable          #-}+{-# LANGUAGE FlexibleContexts           #-} {-# LANGUAGE FlexibleInstances          #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses      #-} {-# LANGUAGE ScopedTypeVariables        #-} {-# LANGUAGE StandaloneDeriving         #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE UndecidableInstances       #-}  {-# OPTIONS_GHC -fno-warn-orphans       #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-}@@ -25,23 +23,21 @@ module Math.NumberTheory.TestUtils.Wrappers where  import Control.Applicative+import Data.Coerce+import Data.Euclidean import Data.Functor.Classes-#if MIN_VERSION_base(4,8,0)-#else-import Data.Foldable (Foldable)-import Data.Traversable (Traversable)-#endif+import Data.Semiring (Semiring) -import Test.Tasty.QuickCheck as QC hiding (Positive, NonNegative, generate, getNonNegative, getPositive)-import Test.SmallCheck.Series (Positive(..), NonNegative(..), Serial(..), Series)+import Test.Tasty.QuickCheck as QC hiding (Positive(..), NonNegative(..), NonZero(..))+import Test.SmallCheck.Series (Positive(..), NonNegative(..), NonZero(..), Serial(..), Series) -import Math.NumberTheory.Primes (isPrime, nthPrime)+import Math.NumberTheory.Primes (Prime, UniqueFactorisation(..))  ------------------------------------------------------------------------------- -- AnySign  newtype AnySign a = AnySign { getAnySign :: a }-  deriving (Eq, Ord, Read, Show, Num, Enum, Bounded, Integral, Real, Functor, Foldable, Traversable, Arbitrary)+  deriving (Eq, Ord, Read, Show, Num, Enum, Bounded, Integral, Real, Functor, Foldable, Traversable, Arbitrary, Semiring, GcdDomain, Euclidean)  instance (Monad m, Serial m a) => Serial m (AnySign a) where   series = AnySign <$> series@@ -58,16 +54,14 @@ ------------------------------------------------------------------------------- -- Positive from smallcheck -deriving instance Functor Positive+deriving instance Semiring a => Semiring (Positive a)+deriving instance GcdDomain a => GcdDomain (Positive a)+deriving instance Euclidean a => Euclidean (Positive a)  instance (Num a, Ord a, Arbitrary a) => Arbitrary (Positive a) where   arbitrary = Positive <$> (arbitrary `suchThat` (> 0))   shrink (Positive x) = Positive <$> filter (> 0) (shrink x) -instance (Num a, Bounded a) => Bounded (Positive a) where-  minBound = Positive 1-  maxBound = Positive (maxBound :: a)- instance Eq1 Positive where   liftEq eq (Positive a) (Positive b) = a `eq` b @@ -80,16 +74,14 @@ ------------------------------------------------------------------------------- -- NonNegative from smallcheck -deriving instance Functor NonNegative+deriving instance Semiring a => Semiring (NonNegative a)+deriving instance GcdDomain a => GcdDomain (NonNegative a)+deriving instance Euclidean a => Euclidean (NonNegative a)  instance (Num a, Ord a, Arbitrary a) => Arbitrary (NonNegative a) where   arbitrary = NonNegative <$> (arbitrary `suchThat` (>= 0))   shrink (NonNegative x) = NonNegative <$> filter (>= 0) (shrink x) -instance (Num a, Bounded a) => Bounded (NonNegative a) where-  minBound = NonNegative 0-  maxBound = NonNegative (maxBound :: a)- instance Eq1 NonNegative where   liftEq eq (NonNegative a) (NonNegative b) = a `eq` b @@ -100,6 +92,26 @@   liftShowsPrec shw _ p (NonNegative a) = shw p a  -------------------------------------------------------------------------------+-- NonZero from smallcheck++deriving instance Semiring a => Semiring (NonZero a)+deriving instance GcdDomain a => GcdDomain (NonZero a)+deriving instance Euclidean a => Euclidean (NonZero a)++instance (Num a, Ord a, Arbitrary a) => Arbitrary (NonZero a) where+  arbitrary = NonZero <$> (arbitrary `suchThat` (/= 0))+  shrink (NonZero x) = NonZero <$> filter (/= 0) (shrink x)++instance Eq1 NonZero where+  liftEq eq (NonZero a) (NonZero b) = a `eq` b++instance Ord1 NonZero where+  liftCompare cmp (NonZero a) (NonZero b) = a `cmp` b++instance Show1 NonZero where+  liftShowsPrec shw _ p (NonZero a) = shw p a++------------------------------------------------------------------------------- -- Huge  newtype Huge a = Huge { getHuge :: a }@@ -110,6 +122,7 @@     Positive l <- arbitrary     ds <- vector l     return $ Huge $ foldl1 (\acc n -> acc * 2^63 + n) ds+  shrink (Huge n) = Huge <$> shrink n  instance Eq1 Huge where   liftEq eq (Huge a) (Huge b) = a `eq` b@@ -124,13 +137,13 @@ -- Power  newtype Power a = Power { getPower :: a }-  deriving (Eq, Ord, Read, Show, Num, Enum, Bounded, Integral, Real, Functor, Foldable, Traversable)+  deriving (Eq, Ord, Read, Show, Num, Enum, Bounded, Integral, Real, Functor, Foldable, Traversable, Semiring, GcdDomain, Euclidean)  instance (Monad m, Num a, Ord a, Serial m a) => Serial m (Power a) where   series = Power <$> series `suchThatSerial` (> 0)  instance (Num a, Ord a, Integral a, Arbitrary a) => Arbitrary (Power a) where-  arbitrary = Power <$> (getSmall <$> arbitrary) `suchThat` (> 0)+  arbitrary = Power <$> arbitrarySizedNatural `suchThat` (> 0)   shrink (Power x) = Power <$> filter (> 0) (shrink x)  instance Eq1 Power where@@ -167,19 +180,28 @@ ------------------------------------------------------------------------------- -- Prime -newtype Prime = Prime { getPrime :: Integer }-  deriving (Eq, Ord, Show)+instance (Arbitrary a, UniqueFactorisation a) => Arbitrary (Prime a) where+  arbitrary = (arbitrary :: Gen a) `suchThatMap` isPrime -instance Arbitrary Prime where-  arbitrary = do-    n <- arbitrary-    return $ Prime $ head $ filter isPrime [abs n ..]+instance (Monad m, Serial m a, UniqueFactorisation a) => Serial m (Prime a) where+  series = (series :: Series m a) `suchThatMapSerial` isPrime -instance Monad m => Serial m Prime where-  series = Prime . nthPrime <$> series `suchThatSerial` (> 0)+-------------------------------------------------------------------------------+-- UniqueFactorisation +instance UniqueFactorisation a => UniqueFactorisation (Large a) where+  factorise (Large x) = coerce $ factorise x+  isPrime (Large x) = coerce $ isPrime x++instance UniqueFactorisation a => UniqueFactorisation (Huge a) where+  factorise (Huge x) = coerce $ factorise x+  isPrime (Huge x) = coerce $ isPrime x+ ------------------------------------------------------------------------------- -- Utils  suchThatSerial :: Series m a -> (a -> Bool) -> Series m a suchThatSerial s p = s >>= \x -> if p x then pure x else empty++suchThatMapSerial :: Series m a -> (a -> Maybe b) -> Series m b+suchThatMapSerial s p = s >>= maybe empty pure . p
test-suite/Math/NumberTheory/UniqueFactorisationTests.hs view
@@ -3,12 +3,10 @@ -- Copyright:   (c) 2016 Andrew Lelechenko -- Licence:     MIT -- Maintainer:  Andrew Lelechenko <andrew.lelechenko@gmail.com>--- Stability:   Provisional -- -- Tests for Math.NumberTheory.ArithmeticFunctions -- -{-# LANGUAGE CPP                 #-} {-# LANGUAGE ScopedTypeVariables #-}  {-# OPTIONS_GHC -fno-warn-type-defaults #-}@@ -19,14 +17,10 @@  import Test.Tasty -#if MIN_VERSION_base(4,8,0)-#else-import Data.Word-#endif--import Math.NumberTheory.GaussianIntegers hiding (factorise)-import Math.NumberTheory.UniqueFactorisation-import Math.NumberTheory.TestUtils hiding (Prime)+import Math.NumberTheory.Quadratic.EisensteinIntegers+import Math.NumberTheory.Quadratic.GaussianIntegers+import Math.NumberTheory.Primes+import Math.NumberTheory.TestUtils  import Numeric.Natural @@ -48,5 +42,6 @@   , testSmallAndQuick "Integer" (testRules :: Integer -> Bool)   , testSmallAndQuick "Natural" (testRules :: Natural -> Bool) -  , testSmallAndQuick "GaussianInteger" (testRules :: GaussianInteger -> Bool)+  , testSmallAndQuick "GaussianInteger"   (testRules :: GaussianInteger   -> Bool)+  , testSmallAndQuick "EisensteinInteger" (testRules :: EisensteinInteger -> Bool)   ]
+ test-suite/Math/NumberTheory/Zeta/DirichletTests.hs view
@@ -0,0 +1,116 @@+-- |+-- Module:      Math.NumberTheory.Zeta.DirichletTests+-- Copyright:   (c) 2018 Alexandre Rodrigues Baldé+-- Licence:     MIT+-- Maintainer:  Alexandre Rodrigues Baldé <alexandrer_b@outlook.com>+--+-- Tests for Math.NumberTheory.Zeta.Dirichlet+--++{-# OPTIONS_GHC -fno-warn-type-defaults #-}++module Math.NumberTheory.Zeta.DirichletTests+  ( testSuite+  ) where++import Data.ExactPi                (approximateValue)+import Data.List.Infinite (Infinite(..))+import qualified Data.List.Infinite as Inf++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' :: Infinite Double+betas' = betas epsilon++betasOddSpecialCase1 :: Assertion+betasOddSpecialCase1+  = assertEqualUpToEps "beta(1) = pi/4" epsilon+    (approximateValue $ Inf.head betasOdd)+    (pi / 4)++betasOddSpecialCase2 :: Assertion+betasOddSpecialCase2+  = assertEqualUpToEps "beta(3) = pi^3/32" epsilon+    (approximateValue $ betasOdd Inf.!! 1)+    (pi^3 / 32)++betasOddSpecialCase3 :: Assertion+betasOddSpecialCase3+  = assertEqualUpToEps "beta(5) = 5*pi^5/1536" epsilon+    (approximateValue $ betasOdd Inf.!! 2)+    ((5 * pi^5) / 1536)++betasOddProperty1 :: Positive Int -> Bool+betasOddProperty1 (Positive m)+  =  betaM < 1+  || betaM < betaM1+  where+    betaM  = approximateValue (betasOdd Inf.!! fromIntegral m)+    betaM1 = approximateValue (betasOdd Inf.!! (fromIntegral m + 1))++betasOddProperty2 :: Word -> Bool+betasOddProperty2 m+  = abs (betaM - betaM') < epsilon+  where+    betaM  = approximateValue (betasOdd Inf.!! m)+    betaM' = betas' Inf.!! ((2 * m) + 1)++betasSpecialCase1 :: Assertion+betasSpecialCase1+  = assertEqual "beta(0) = 1/2"+    (Inf.head betas')+    (1 / 2)++betasSpecialCase2 :: Assertion+betasSpecialCase2+  = assertEqualUpToEps "beta(2) = 0.9159655" epsilon+    (betas' Inf.!! 2)+    0.9159655941772190150546035149323841107++betasSpecialCase3 :: Assertion+betasSpecialCase3+  = assertEqualUpToEps "beta(4) = 0.9889445" epsilon+    (betas' Inf.!! 4)+    0.9889445517411053361084226332283778213++betasProperty1 :: Positive Int -> Bool+betasProperty1 (Positive m)+  =  betaM <= betaM1+  && betaM1 <= 1+  where+    betaM  = betas' Inf.!! fromIntegral m+    betaM1 = betas' Inf.!! (fromIntegral m + 1)++betasProperty2 :: NonNegative Int -> NonNegative Int -> Bool+betasProperty2 (NonNegative e1) (NonNegative e2)+  = maximum (Inf.take 35 $ Inf.drop 2 $ Inf.zipWith ((abs .) . (-)) (betas eps1) (betas eps2)) <= eps1 + eps2+  where+    eps1, eps2 :: Double+    eps1 = max ((1.0 / 2) ^ e1) ((1.0 / 2) ^ 53)+    eps2 = max ((1.0 / 2) ^ e2) ((1.0 / 2) ^ 53)+++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+    ]+  ]
+ test-suite/Math/NumberTheory/Zeta/RiemannTests.hs view
@@ -0,0 +1,119 @@+-- |+-- Module:      Math.NumberTheory.Zeta.RiemannTests+-- Copyright:   (c) 2016 Andrew Lelechenko+-- Licence:     MIT+-- Maintainer:  Andrew Lelechenko <andrew.lelechenko@gmail.com>+--+-- Tests for Math.NumberTheory.Zeta.Riemann+--++{-# OPTIONS_GHC -fno-warn-type-defaults #-}++module Math.NumberTheory.Zeta.RiemannTests+  ( testSuite+  ) where++import Data.ExactPi                (approximateValue)+import Data.List.Infinite (Infinite(..))+import qualified Data.List.Infinite as Inf++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 $ Inf.head zetasEven)+    (-1 / 2)++zetasEvenSpecialCase2 :: Assertion+zetasEvenSpecialCase2+  = assertEqualUpToEps "zeta(2) = pi^2/6" epsilon+    (approximateValue $ zetasEven Inf.!! 1)+    (pi * pi / 6)++zetasEvenSpecialCase3 :: Assertion+zetasEvenSpecialCase3+  = assertEqualUpToEps "zeta(4) = pi^4/90" epsilon+    (approximateValue $ zetasEven Inf.!! 2)+    (pi ^ 4 / 90)++zetasEvenProperty1 :: Positive Int -> Bool+zetasEvenProperty1 (Positive m)+  =  zetaM < 1+  || zetaM > zetaM1+  where+    zetaM  = approximateValue (zetasEven Inf.!! fromIntegral m)+    zetaM1 = approximateValue (zetasEven Inf.!! (fromIntegral m + 1))++zetasEvenProperty2 :: Positive Int -> Bool+zetasEvenProperty2 (Positive m)+  = abs (zetaM - zetaM') < epsilon+  where+    zetaM  = approximateValue (zetasEven Inf.!! fromIntegral m)+    zetaM' = zetas' Inf.!! (2 * fromIntegral m)++zetas' :: Infinite Double+zetas' = zetas epsilon++zetasSpecialCase1 :: Assertion+zetasSpecialCase1+  = assertEqual "zeta(1) = Infinity"+    (zetas' Inf.!! 1)+    (1 / 0)++zetasSpecialCase2 :: Assertion+zetasSpecialCase2+  = assertEqualUpToEps "zeta(3) = 1.2020569" epsilon+    (zetas' Inf.!! 3)+    1.2020569031595942853997381615114499908++zetasSpecialCase3 :: Assertion+zetasSpecialCase3+  = assertEqualUpToEps "zeta(5) = 1.0369277" epsilon+    (zetas' Inf.!! 5)+    1.0369277551433699263313654864570341681++zetasProperty1 :: Positive Int -> Bool+zetasProperty1 (Positive m)+  =  zetaM >= zetaM1+  && zetaM1 >= 1+  where+    zetaM  = zetas' Inf.!! fromIntegral m+    zetaM1 = zetas' Inf.!! (fromIntegral 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 (Inf.take 35 $ Inf.drop 2 $ Inf.zipWith ((abs .) . (-)) (zetas eps1) (zetas eps2)) < eps1 + eps2+  where+    eps1, eps2 :: Double+    eps1 = max ((1.0 / 2) ^ e1) ((1.0 / 2) ^ 53)+    eps2 = max ((1.0 / 2) ^ e2) ((1.0 / 2) ^ 53)++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+    ]+  ]
− test-suite/Math/NumberTheory/ZetaTests.hs 
@@ -1,116 +0,0 @@--- |--- Module:      Math.NumberTheory.ZetaTests--- Copyright:   (c) 2016 Andrew Lelechenko--- Licence:     MIT--- Maintainer:  Andrew Lelechenko <andrew.lelechenko@gmail.com>--- 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-    ]-  ]
test-suite/Test.hs view
@@ -1,88 +1,106 @@ import Test.Tasty+import Test.Tasty.Ingredients.Rerun -import qualified Math.NumberTheory.GCDTests as GCD-import qualified Math.NumberTheory.GCD.LowLevelTests as GCDLowLevel+import qualified Math.NumberTheory.EuclideanTests as Euclidean -import qualified Math.NumberTheory.Recurrencies.BilinearTests as RecurrenciesBilinear-import qualified Math.NumberTheory.Recurrencies.LinearTests as RecurrenciesLinear+import qualified Math.NumberTheory.Recurrences.PentagonalTests as RecurrencesPentagonal+import qualified Math.NumberTheory.Recurrences.BilinearTests as RecurrencesBilinear+import qualified Math.NumberTheory.Recurrences.LinearTests as RecurrencesLinear  import qualified Math.NumberTheory.Moduli.ChineseTests as ModuliChinese import qualified Math.NumberTheory.Moduli.ClassTests as ModuliClass+import qualified Math.NumberTheory.Moduli.CbrtTests as ModuliCbrt+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.SingletonTests as ModuliSingleton import qualified Math.NumberTheory.Moduli.SqrtTests as ModuliSqrt  import qualified Math.NumberTheory.MoebiusInversionTests as MoebiusInversion-import qualified Math.NumberTheory.MoebiusInversion.IntTests as MoebiusInversionInt -import qualified Math.NumberTheory.Powers.CubesTests as Cubes-import qualified Math.NumberTheory.Powers.FourthTests as Fourth-import qualified Math.NumberTheory.Powers.GeneralTests as General-import qualified Math.NumberTheory.Powers.SquaresTests as Squares+import qualified Math.NumberTheory.PrefactoredTests as Prefactored  import qualified Math.NumberTheory.PrimesTests as Primes import qualified Math.NumberTheory.Primes.CountingTests as Counting import qualified Math.NumberTheory.Primes.FactorisationTests as Factorisation-import qualified Math.NumberTheory.Primes.HeapTests as Heap+-- import qualified Math.NumberTheory.Primes.LinearAlgebraTests as LinearAlgebra+-- import qualified Math.NumberTheory.Primes.QuadraticSieveTests as QuadraticSieve+import qualified Math.NumberTheory.Primes.SequenceTests as Sequence 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.InverseTests as Inverse+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++import qualified Math.NumberTheory.DirichletCharactersTests as DirichletChar++import qualified Math.NumberTheory.RootsOfUnityTests as RootsOfUnity++import qualified Math.NumberTheory.DiophantineTests as Diophantine+ main :: IO ()-main = defaultMain tests+main = defaultMainWithRerun tests  tests :: TestTree tests = testGroup "All"-  [ testGroup "Powers"-    [ Cubes.testSuite-    , Fourth.testSuite-    , General.testSuite-    , Squares.testSuite-    ]-  , testGroup "GCD"-    [ GCD.testSuite-    , GCDLowLevel.testSuite-    ]-  , testGroup "Recurrencies"-    [ RecurrenciesLinear.testSuite-    , RecurrenciesBilinear.testSuite+  [ Euclidean.testSuite+  , testGroup "Recurrences"+    [ RecurrencesPentagonal.testSuite+    , RecurrencesLinear.testSuite+    , RecurrencesBilinear.testSuite     ]   , testGroup "Moduli"     [ ModuliChinese.testSuite     , ModuliClass.testSuite+    , ModuliCbrt.testSuite+    , ModuliDiscreteLogarithm.testSuite+    , ModuliEquations.testSuite     , ModuliJacobi.testSuite+    , ModuliPrimitiveRoot.testSuite+    , ModuliSingleton.testSuite     , ModuliSqrt.testSuite     ]-  , testGroup "MoebiusInversion"-    [ MoebiusInversion.testSuite-    , MoebiusInversionInt.testSuite-    ]+  , MoebiusInversion.testSuite+  , Prefactored.testSuite   , testGroup "Primes"     [ Primes.testSuite     , Counting.testSuite     , Factorisation.testSuite-    , Heap.testSuite+    -- , LinearAlgebra.testSuite+    -- , QuadraticSieve.testSuite+    , Sequence.testSuite     , Sieve.testSuite     , Testing.testSuite     ]-  , testGroup "Gaussian"-    [ Gaussian.testSuite-    ]+  , Eisenstein.testSuite+  , Gaussian.testSuite   , testGroup "ArithmeticFunctions"     [ ArithmeticFunctions.testSuite-    ]-  , testGroup "UniqueFactorisation"-    [ UniqueFactorisation.testSuite+    , Inverse.testSuite+    , Mertens.testSuite+    , SieveBlock.testSuite     ]+  , UniqueFactorisation.testSuite+  , Curves.testSuite+  , SmoothNumbers.testSuite+  , Diophantine.testSuite   , testGroup "Zeta"-    [ Zeta.testSuite-    ]-  , testGroup "Curves"-    [ Curves.testSuite+    [ Riemann.testSuite+    , Dirichlet.testSuite     ]+  , DirichletChar.testSuite+  , RootsOfUnity.testSuite   ]