From 8671d265dbd6e841e981ab9286f5ad905403f4ac Mon Sep 17 00:00:00 2001 From: Bhavik Mehta Date: Sun, 16 Sep 2018 18:09:37 +0100 Subject: [PATCH 01/65] Explicit import lists --- Math/NumberTheory/Moduli/PrimitiveRoot.hs | 21 ++++++++++----------- 1 file changed, 10 insertions(+), 11 deletions(-) diff --git a/Math/NumberTheory/Moduli/PrimitiveRoot.hs b/Math/NumberTheory/Moduli/PrimitiveRoot.hs index 67b82d684..3bcc110ba 100644 --- a/Math/NumberTheory/Moduli/PrimitiveRoot.hs +++ b/Math/NumberTheory/Moduli/PrimitiveRoot.hs @@ -34,20 +34,19 @@ module Math.NumberTheory.Moduli.PrimitiveRoot #if __GLASGOW_HASKELL__ < 803 import Data.Semigroup #endif +import Control.DeepSeq (NFData) +import Control.Monad (guard) +import GHC.Generics (Generic) +import Numeric.Natural (Natural) import Math.NumberTheory.ArithmeticFunctions (totient) import Math.NumberTheory.GCD as Coprimes -import Math.NumberTheory.Moduli.Class (getNatMod, getNatVal, KnownNat, Mod, MultMod, isMultElement) -import Math.NumberTheory.Powers.General (highestPower) -import Math.NumberTheory.Powers.Modular -import Math.NumberTheory.Prefactored -import Math.NumberTheory.UniqueFactorisation -import Math.NumberTheory.Utils.FromIntegral - -import Control.DeepSeq -import Control.Monad (guard) -import GHC.Generics -import Numeric.Natural +import Math.NumberTheory.Moduli.Class (getNatMod, getNatVal, KnownNat, Mod, MultMod, isMultElement) +import Math.NumberTheory.Powers.General (highestPower) +import Math.NumberTheory.Powers.Modular (powMod) +import Math.NumberTheory.Prefactored (Prefactored, fromFactors) +import Math.NumberTheory.UniqueFactorisation (Prime, UniqueFactorisation, isPrime, unPrime, factorise) +import Math.NumberTheory.Utils.FromIntegral (intToWord) -- | A multiplicative group of residues is called cyclic, -- if there is a primitive root @g@, From 7d18b110b86013a9dad74709ef8b33fd049e8a5e Mon Sep 17 00:00:00 2001 From: Bhavik Mehta Date: Sun, 16 Sep 2018 19:54:45 +0100 Subject: [PATCH 02/65] Generalise CRT and make canonical generators --- Math/NumberTheory/DirichletCharacters.hs | 54 ++++++++++++++++++++++++ Math/NumberTheory/Moduli/Chinese.hs | 3 +- arithmoi.cabal | 1 + 3 files changed, 57 insertions(+), 1 deletion(-) create mode 100644 Math/NumberTheory/DirichletCharacters.hs diff --git a/Math/NumberTheory/DirichletCharacters.hs b/Math/NumberTheory/DirichletCharacters.hs new file mode 100644 index 000000000..b23dcb61c --- /dev/null +++ b/Math/NumberTheory/DirichletCharacters.hs @@ -0,0 +1,54 @@ +-- | +-- Module: Math.NumberTheory.DirichletCharacters +-- Copyright: (c) 2018 Bhavik Mehta +-- Licence: MIT +-- Maintainer: Bhavik Mehta +-- Stability: Provisional +-- Portability: Non-portable (GHC extensions) +-- +-- Implementation and enumeration of Dirichlet characters. +-- + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE LambdaCase #-} + +{-# OPTIONS -fno-warn-unused-imports #-} + +module Math.NumberTheory.DirichletCharacters + ( DirichletCharacter + , generators + ) where + +import qualified Data.Map as M +import Data.Map (Map, (!)) +import GHC.TypeNats.Compat (Nat) +import Numeric.Natural (Natural) + +import Math.NumberTheory.Moduli (PrimitiveRoot, CyclicGroup(..), isPrimitiveRoot', chineseRemainder2) +import Math.NumberTheory.UniqueFactorisation (UniqueFactorisation, unPrime, Prime, factorise) +import Math.NumberTheory.Powers (powMod) + +data DirichletCharacter (n :: Nat) = Generated (Map Natural Natural) + deriving (Eq) + +canonGenHelp :: (Integral a, UniqueFactorisation a) => (Prime a, Word) -> [a] +canonGenHelp (p, k) + | p' == 2, k == 1 = [] + | p' == 2, k == 2 = [3] + | p' == 2 = [5, p'^k - 1] + | k == 1 = [modP] + | otherwise = [if powMod modP (p'-1) (p'*p') == 1 then modP + p' else modP] + where p' = unPrime p + modP = head $ filter (isPrimitiveRoot' (CGOddPrimePower p 1)) [2..p' - 1] + +generators :: (Integral a, UniqueFactorisation a) => a -> [a] +generators 1 = [1] +generators 2 = [1] -- special cases of trivial group +generators n = do + (p,k) <- factorise n + let factor = unPrime p ^ k + rest = n `div` factor + g <- canonGenHelp (p,k) + return $ chineseRemainder2 (g,factor) (1,rest) diff --git a/Math/NumberTheory/Moduli/Chinese.hs b/Math/NumberTheory/Moduli/Chinese.hs index da018e7a2..c9583c729 100644 --- a/Math/NumberTheory/Moduli/Chinese.hs +++ b/Math/NumberTheory/Moduli/Chinese.hs @@ -48,7 +48,8 @@ chineseRemainder remainders = foldM addRem 0 remainders -- > r ≡ r_k (mod m_k) -- -- if @m_1@ and @m_2@ are coprime. -chineseRemainder2 :: (Integer,Integer) -> (Integer,Integer) -> Integer +{-# SPECIALISE chineseRemainder2 :: (Integer,Integer) -> (Integer,Integer) -> Integer #-} +chineseRemainder2 :: Integral a => (a,a) -> (a,a) -> a chineseRemainder2 (r1, md1) (r2,md2) = case extendedGCD md1 md2 of (_,u,v) -> ((1 - u*md1)*r1 + (1 - v*md2)*r2) `mod` (md1*md2) diff --git a/arithmoi.cabal b/arithmoi.cabal index dff112281..065b165c2 100644 --- a/arithmoi.cabal +++ b/arithmoi.cabal @@ -56,6 +56,7 @@ library Math.NumberTheory.ArithmeticFunctions.Moebius Math.NumberTheory.ArithmeticFunctions.SieveBlock Math.NumberTheory.Curves.Montgomery + Math.NumberTheory.DirichletCharacters Math.NumberTheory.EisensteinIntegers Math.NumberTheory.Euclidean Math.NumberTheory.GaussianIntegers From 3f2d3072fa310ecffb49a5d86219e5cf428a00f5 Mon Sep 17 00:00:00 2001 From: Bhavik Mehta Date: Sun, 16 Sep 2018 20:58:51 +0100 Subject: [PATCH 03/65] Fix crt underflow problems --- Math/NumberTheory/DirichletCharacters.hs | 7 +++++-- Math/NumberTheory/Moduli/Chinese.hs | 3 +-- 2 files changed, 6 insertions(+), 4 deletions(-) diff --git a/Math/NumberTheory/DirichletCharacters.hs b/Math/NumberTheory/DirichletCharacters.hs index b23dcb61c..ac14782b3 100644 --- a/Math/NumberTheory/DirichletCharacters.hs +++ b/Math/NumberTheory/DirichletCharacters.hs @@ -43,7 +43,7 @@ canonGenHelp (p, k) where p' = unPrime p modP = head $ filter (isPrimitiveRoot' (CGOddPrimePower p 1)) [2..p' - 1] -generators :: (Integral a, UniqueFactorisation a) => a -> [a] +generators :: Natural -> [Natural] generators 1 = [1] generators 2 = [1] -- special cases of trivial group generators n = do @@ -51,4 +51,7 @@ generators n = do let factor = unPrime p ^ k rest = n `div` factor g <- canonGenHelp (p,k) - return $ chineseRemainder2 (g,factor) (1,rest) + return $ crt (g,factor) (1,rest) + +crt :: (Natural, Natural) -> (Natural,Natural) -> Natural +crt (r1,md1) (r2,md2) = fromInteger $ chineseRemainder2 (toInteger r1,toInteger md1) (toInteger r2,toInteger md2) diff --git a/Math/NumberTheory/Moduli/Chinese.hs b/Math/NumberTheory/Moduli/Chinese.hs index c9583c729..da018e7a2 100644 --- a/Math/NumberTheory/Moduli/Chinese.hs +++ b/Math/NumberTheory/Moduli/Chinese.hs @@ -48,8 +48,7 @@ chineseRemainder remainders = foldM addRem 0 remainders -- > r ≡ r_k (mod m_k) -- -- if @m_1@ and @m_2@ are coprime. -{-# SPECIALISE chineseRemainder2 :: (Integer,Integer) -> (Integer,Integer) -> Integer #-} -chineseRemainder2 :: Integral a => (a,a) -> (a,a) -> a +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) From 7bac8a43c13d70e88a7f0f655432f507887d3fd0 Mon Sep 17 00:00:00 2001 From: Bhavik Mehta Date: Sun, 16 Sep 2018 21:09:58 +0100 Subject: [PATCH 04/65] Initial testing --- arithmoi.cabal | 1 + .../NumberTheory/DirichletCharactersTests.hs | 41 +++++++++++++++++++ test-suite/Test.hs | 3 ++ 3 files changed, 45 insertions(+) create mode 100644 test-suite/Math/NumberTheory/DirichletCharactersTests.hs diff --git a/arithmoi.cabal b/arithmoi.cabal index 065b165c2..2e74c0ceb 100644 --- a/arithmoi.cabal +++ b/arithmoi.cabal @@ -143,6 +143,7 @@ test-suite spec Math.NumberTheory.ArithmeticFunctions.MertensTests Math.NumberTheory.ArithmeticFunctions.SieveBlockTests Math.NumberTheory.CurvesTests + Math.NumberTheory.DirichletCharactersTests Math.NumberTheory.EisensteinIntegersTests Math.NumberTheory.GaussianIntegersTests Math.NumberTheory.GCDTests diff --git a/test-suite/Math/NumberTheory/DirichletCharactersTests.hs b/test-suite/Math/NumberTheory/DirichletCharactersTests.hs new file mode 100644 index 000000000..b5950e6a5 --- /dev/null +++ b/test-suite/Math/NumberTheory/DirichletCharactersTests.hs @@ -0,0 +1,41 @@ +-- | +-- Module: Math.NumberTheory.Moduli.DiscreteLogarithm +-- Copyright: (c) 2018 Bhavik Mehta +-- License: MIT +-- Maintainer: Andrew Lelechenko +-- Stability: Provisional +-- Portability: Non-portable +-- +-- Tests for Math.NumberTheory.DirichletCharacters +-- + +{-# LANGUAGE ScopedTypeVariables #-} + +module Math.NumberTheory.DirichletCharactersTests where + +import Test.Tasty + +import Data.Proxy +import Numeric.Natural + +import Data.List (sort) +import GHC.TypeNats.Compat (SomeNat(..), someNatVal) + +import Math.NumberTheory.DirichletCharacters (generators) +import Math.NumberTheory.Moduli (Mod, getNatVal) +import Math.NumberTheory.TestUtils (testSmallAndQuick, Positive(..)) + +generatingTest :: Positive Natural -> Bool +generatingTest (Positive 1) = [1] == generators 1 +generatingTest (Positive n) = + case someNatVal n of + SomeNat (_ :: Proxy m) -> [a | a <- [1..n], gcd a n == 1] == generated + where generated = sort $ map (getNatVal . product) $ traverse helper [fromIntegral g :: Mod m | g <- generators n] + +helper :: (Eq a, Num a) => a -> [a] +helper m = 1: (takeWhile (/= 1) $ iterate (*m) m) + +testSuite :: TestTree +testSuite = testGroup "DirichletCharacters" + [ testSmallAndQuick "check generators work" generatingTest + ] diff --git a/test-suite/Test.hs b/test-suite/Test.hs index ca468fcb8..fd3e3c44a 100644 --- a/test-suite/Test.hs +++ b/test-suite/Test.hs @@ -45,6 +45,8 @@ 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 + main :: IO () main = defaultMain tests @@ -99,4 +101,5 @@ tests = testGroup "All" [ Riemann.testSuite , Dirichlet.testSuite ] + , DirichletChar.testSuite ] From cce290e4eebc872580b4c773e2a27058587de8fa Mon Sep 17 00:00:00 2001 From: Bhavik Mehta Date: Tue, 18 Sep 2018 20:45:46 +0100 Subject: [PATCH 05/65] Roots of unity --- Math/NumberTheory/DirichletCharacters.hs | 41 +++++++++++++++++++----- 1 file changed, 33 insertions(+), 8 deletions(-) diff --git a/Math/NumberTheory/DirichletCharacters.hs b/Math/NumberTheory/DirichletCharacters.hs index ac14782b3..e5e2cbdb1 100644 --- a/Math/NumberTheory/DirichletCharacters.hs +++ b/Math/NumberTheory/DirichletCharacters.hs @@ -10,28 +10,53 @@ -- {-# LANGUAGE DataKinds #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE LambdaCase #-} -{-# OPTIONS -fno-warn-unused-imports #-} +{-# OPTIONS -fno-warn-unused-imports -fno-warn-unused-top-binds #-} -module Math.NumberTheory.DirichletCharacters - ( DirichletCharacter - , generators - ) where +module Math.NumberTheory.DirichletCharacters where +#if __GLASGOW_HASKELL__ < 803 +import Data.Semigroup +#endif import qualified Data.Map as M import Data.Map (Map, (!)) import GHC.TypeNats.Compat (Nat) import Numeric.Natural (Natural) +import Data.Ratio +import Data.Complex -import Math.NumberTheory.Moduli (PrimitiveRoot, CyclicGroup(..), isPrimitiveRoot', chineseRemainder2) +import Math.NumberTheory.Moduli (PrimitiveRoot, CyclicGroup(..), isPrimitiveRoot', chineseRemainder2, KnownNat, MultMod) import Math.NumberTheory.UniqueFactorisation (UniqueFactorisation, unPrime, Prime, factorise) import Math.NumberTheory.Powers (powMod) -data DirichletCharacter (n :: Nat) = Generated (Map Natural Natural) - deriving (Eq) +-- data DirichletCharacter (n :: Nat) = Generated (Map Natural Natural) +-- deriving (Eq) +data DirichletCharacter (n :: Nat) = Generated [DirichletFactor] + +newtype RootOfUnity = RootOfUnity { getFraction :: Rational } + deriving (Eq, Show) + -- RootOfUnity q represents e^(2pi i * q) + -- I am happy with a custom Show instance if that's preferred + +toRootOfUnity :: Rational -> RootOfUnity +toRootOfUnity q = RootOfUnity ((n `rem` d) % d) + where n = numerator q + d = denominator q + -- effectively q `mod` 1 + +instance Semigroup RootOfUnity where + (RootOfUnity q1) <> (RootOfUnity q2) = toRootOfUnity (q1 + q2) + +instance Monoid RootOfUnity where + mappend = (<>) + mempty = RootOfUnity 0 + +fromRootOfUnity :: Floating a => RootOfUnity -> Complex a +fromRootOfUnity = cis . fromRational . getFraction canonGenHelp :: (Integral a, UniqueFactorisation a) => (Prime a, Word) -> [a] canonGenHelp (p, k) From 3858ec09ec1d330a6ab452cd20f5f31aa98426bd Mon Sep 17 00:00:00 2001 From: Bhavik Mehta Date: Thu, 20 Sep 2018 23:07:24 +0100 Subject: [PATCH 06/65] Dirichlet characters first draft --- Math/NumberTheory/DirichletCharacters.hs | 31 ++++++++++++++++--- Math/NumberTheory/Moduli/DiscreteLogarithm.hs | 1 + 2 files changed, 28 insertions(+), 4 deletions(-) diff --git a/Math/NumberTheory/DirichletCharacters.hs b/Math/NumberTheory/DirichletCharacters.hs index e5e2cbdb1..7cbc271fc 100644 --- a/Math/NumberTheory/DirichletCharacters.hs +++ b/Math/NumberTheory/DirichletCharacters.hs @@ -15,21 +15,19 @@ {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE LambdaCase #-} -{-# OPTIONS -fno-warn-unused-imports -fno-warn-unused-top-binds #-} +{-# OPTIONS -fno-warn-unused-top-binds #-} module Math.NumberTheory.DirichletCharacters where #if __GLASGOW_HASKELL__ < 803 import Data.Semigroup #endif -import qualified Data.Map as M -import Data.Map (Map, (!)) import GHC.TypeNats.Compat (Nat) import Numeric.Natural (Natural) import Data.Ratio import Data.Complex -import Math.NumberTheory.Moduli (PrimitiveRoot, CyclicGroup(..), isPrimitiveRoot', chineseRemainder2, KnownNat, MultMod) +import Math.NumberTheory.Moduli (CyclicGroup(..), isPrimitiveRoot', chineseRemainder2, KnownNat, MultMod, discreteLogarithmPP, getVal, multElement) import Math.NumberTheory.UniqueFactorisation (UniqueFactorisation, unPrime, Prime, factorise) import Math.NumberTheory.Powers (powMod) @@ -80,3 +78,28 @@ generators n = do crt :: (Natural, Natural) -> (Natural,Natural) -> Natural crt (r1,md1) (r2,md2) = fromInteger $ chineseRemainder2 (toInteger r1,toInteger md1) (toInteger r2,toInteger md2) + +lambda :: Integer -> Word -> Integer +lambda x e = ((powMod x (2^(e-1)) (2^(2*e-1)) - 1) `div` (2^(e+1))) `mod` (2^(e-2)) + +data DirichletFactor = OddPrime { getPrime :: Prime Natural + , getPower :: Word + , getGenerator :: Natural + , getValue :: Natural + } + | Four { getValue :: Natural } + | TwoPower { getPower :: Word + , getFirstValue :: Natural + , getSecondValue :: Natural + } + +evaluate :: KnownNat n => DirichletCharacter n -> MultMod n -> RootOfUnity +evaluate (Generated ds) m = foldMap (evalFactor m') ds + where m' = getVal $ multElement m + +evalFactor :: Integer -> DirichletFactor -> RootOfUnity +evalFactor m = + \case + OddPrime (unPrime -> p) k a b -> toRootOfUnity (toInteger (b * discreteLogarithmPP p k (fromIntegral a) (m `rem` p^k)) % (p^(k-1)*(p-1))) + Four b -> toRootOfUnity (((toInteger b) * (if (m `rem` 4) == 1 then 1 else 0)) % 2) + TwoPower k s b -> toRootOfUnity ((toInteger s) * (if (m `rem` 4) == 1 then 1 else 0) % 2) <> toRootOfUnity (toInteger b * lambda m k % (2^(k-2))) diff --git a/Math/NumberTheory/Moduli/DiscreteLogarithm.hs b/Math/NumberTheory/Moduli/DiscreteLogarithm.hs index 36bd6a391..dfd69d3c8 100644 --- a/Math/NumberTheory/Moduli/DiscreteLogarithm.hs +++ b/Math/NumberTheory/Moduli/DiscreteLogarithm.hs @@ -13,6 +13,7 @@ module Math.NumberTheory.Moduli.DiscreteLogarithm ( discreteLogarithm + , discreteLogarithmPP ) where import qualified Data.IntMap.Strict as M From 7fd007d4ab4d7ad2c602bda71dfdd72e2a987996 Mon Sep 17 00:00:00 2001 From: Bhavik Mehta Date: Thu, 20 Sep 2018 23:27:12 +0100 Subject: [PATCH 07/65] Minor corrections --- Math/NumberTheory/DirichletCharacters.hs | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/Math/NumberTheory/DirichletCharacters.hs b/Math/NumberTheory/DirichletCharacters.hs index 7cbc271fc..33575541c 100644 --- a/Math/NumberTheory/DirichletCharacters.hs +++ b/Math/NumberTheory/DirichletCharacters.hs @@ -15,8 +15,6 @@ {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE LambdaCase #-} -{-# OPTIONS -fno-warn-unused-top-binds #-} - module Math.NumberTheory.DirichletCharacters where #if __GLASGOW_HASKELL__ < 803 @@ -54,7 +52,7 @@ instance Monoid RootOfUnity where mempty = RootOfUnity 0 fromRootOfUnity :: Floating a => RootOfUnity -> Complex a -fromRootOfUnity = cis . fromRational . getFraction +fromRootOfUnity = cis . (2*pi*) . fromRational . getFraction canonGenHelp :: (Integral a, UniqueFactorisation a) => (Prime a, Word) -> [a] canonGenHelp (p, k) @@ -79,6 +77,7 @@ generators n = do crt :: (Natural, Natural) -> (Natural,Natural) -> Natural crt (r1,md1) (r2,md2) = fromInteger $ chineseRemainder2 (toInteger r1,toInteger md1) (toInteger r2,toInteger md2) +-- TODO: improve using bitshifts lambda :: Integer -> Word -> Integer lambda x e = ((powMod x (2^(e-1)) (2^(2*e-1)) - 1) `div` (2^(e+1))) `mod` (2^(e-2)) @@ -102,4 +101,8 @@ evalFactor m = \case OddPrime (unPrime -> p) k a b -> toRootOfUnity (toInteger (b * discreteLogarithmPP p k (fromIntegral a) (m `rem` p^k)) % (p^(k-1)*(p-1))) Four b -> toRootOfUnity (((toInteger b) * (if (m `rem` 4) == 1 then 1 else 0)) % 2) - TwoPower k s b -> toRootOfUnity ((toInteger s) * (if (m `rem` 4) == 1 then 1 else 0) % 2) <> toRootOfUnity (toInteger b * lambda m k % (2^(k-2))) + TwoPower k s b -> toRootOfUnity ((toInteger s) * (if (m `rem` 4) == 1 then 1 else 0) % 2) <> toRootOfUnity (toInteger b * lambda m'' k % (2^(k-2))) + where m' = m `rem` (2^k) + m'' = if m' `rem` 4 == 1 + then m' + else 2^k - m' From ee153cef0f2d36cb2a4047b8cf6f9db1c61261c8 Mon Sep 17 00:00:00 2001 From: Bhavik Mehta Date: Sun, 23 Sep 2018 18:18:22 +0100 Subject: [PATCH 08/65] Fix merging problems --- Math/NumberTheory/DirichletCharacters.hs | 4 ++-- Math/NumberTheory/Moduli/PrimitiveRoot.hs | 1 - 2 files changed, 2 insertions(+), 3 deletions(-) diff --git a/Math/NumberTheory/DirichletCharacters.hs b/Math/NumberTheory/DirichletCharacters.hs index 33575541c..7882c6cc1 100644 --- a/Math/NumberTheory/DirichletCharacters.hs +++ b/Math/NumberTheory/DirichletCharacters.hs @@ -81,9 +81,9 @@ crt (r1,md1) (r2,md2) = fromInteger $ chineseRemainder2 (toInteger r1,toInteger lambda :: Integer -> Word -> Integer lambda x e = ((powMod x (2^(e-1)) (2^(2*e-1)) - 1) `div` (2^(e+1))) `mod` (2^(e-2)) -data DirichletFactor = OddPrime { getPrime :: Prime Natural +data DirichletFactor = OddPrime { getPrime :: Prime Integer , getPower :: Word - , getGenerator :: Natural + , getGenerator :: Integer , getValue :: Natural } | Four { getValue :: Natural } diff --git a/Math/NumberTheory/Moduli/PrimitiveRoot.hs b/Math/NumberTheory/Moduli/PrimitiveRoot.hs index 4cd281629..18a757321 100644 --- a/Math/NumberTheory/Moduli/PrimitiveRoot.hs +++ b/Math/NumberTheory/Moduli/PrimitiveRoot.hs @@ -46,7 +46,6 @@ import Math.NumberTheory.Powers.General (highestPower) import Math.NumberTheory.Powers.Modular (powMod) import Math.NumberTheory.Moduli.Class (getNatMod, getNatVal, KnownNat, Mod, MultMod, isMultElement) import Math.NumberTheory.Prefactored (Prefactored, fromFactors) -import Math.NumberTheory.Utils.FromIntegral (intToWord) import Math.NumberTheory.UniqueFactorisation (Prime, UniqueFactorisation, isPrime, unPrime, factorise) -- | A multiplicative group of residues is called cyclic, From beb50894d8d45799058db31371390a0a1d7e52ef Mon Sep 17 00:00:00 2001 From: Bhavik Mehta Date: Sun, 30 Sep 2018 18:13:30 +0100 Subject: [PATCH 09/65] (WIP) More dirichlet characters functionality --- Math/NumberTheory/DirichletCharacters.hs | 140 +++++++++++++++++------ 1 file changed, 104 insertions(+), 36 deletions(-) diff --git a/Math/NumberTheory/DirichletCharacters.hs b/Math/NumberTheory/DirichletCharacters.hs index 7882c6cc1..f935c1ed0 100644 --- a/Math/NumberTheory/DirichletCharacters.hs +++ b/Math/NumberTheory/DirichletCharacters.hs @@ -14,24 +14,43 @@ {-# LANGUAGE KindSignatures #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} module Math.NumberTheory.DirichletCharacters where #if __GLASGOW_HASKELL__ < 803 import Data.Semigroup #endif -import GHC.TypeNats.Compat (Nat) -import Numeric.Natural (Natural) +import GHC.TypeNats.Compat +import Numeric.Natural (Natural) +import Data.Bits import Data.Ratio import Data.Complex +import Data.Proxy +import Data.List (mapAccumL) -import Math.NumberTheory.Moduli (CyclicGroup(..), isPrimitiveRoot', chineseRemainder2, KnownNat, MultMod, discreteLogarithmPP, getVal, multElement) -import Math.NumberTheory.UniqueFactorisation (UniqueFactorisation, unPrime, Prime, factorise) -import Math.NumberTheory.Powers (powMod) +import Math.NumberTheory.ArithmeticFunctions (totient) +import Math.NumberTheory.Moduli.Class (KnownNat, MultMod, getVal, multElement, Mod, isMultElement) +import Math.NumberTheory.Moduli.DiscreteLogarithm (discreteLogarithmPP) +import Math.NumberTheory.UniqueFactorisation (UniqueFactorisation, unPrime, Prime, factorise) +import Math.NumberTheory.Powers (powMod) +import Math.NumberTheory.Utils.FromIntegral + +import Math.NumberTheory.Moduli.PrimitiveRoot --- data DirichletCharacter (n :: Nat) = Generated (Map Natural Natural) --- deriving (Eq) data DirichletCharacter (n :: Nat) = Generated [DirichletFactor] + deriving Show + +data DirichletFactor = OddPrime { getPrime :: Prime Natural + , getPower :: Word + , getGenerator :: Natural + , getValue :: Natural + } + | TwoPower { getPower :: Word + , getFirstValue :: Natural + , getSecondValue :: Natural + } + deriving Show newtype RootOfUnity = RootOfUnity { getFraction :: Rational } deriving (Eq, Show) @@ -64,33 +83,19 @@ canonGenHelp (p, k) where p' = unPrime p modP = head $ filter (isPrimitiveRoot' (CGOddPrimePower p 1)) [2..p' - 1] -generators :: Natural -> [Natural] -generators 1 = [1] -generators 2 = [1] -- special cases of trivial group -generators n = do - (p,k) <- factorise n - let factor = unPrime p ^ k - rest = n `div` factor - g <- canonGenHelp (p,k) - return $ crt (g,factor) (1,rest) - -crt :: (Natural, Natural) -> (Natural,Natural) -> Natural -crt (r1,md1) (r2,md2) = fromInteger $ chineseRemainder2 (toInteger r1,toInteger md1) (toInteger r2,toInteger md2) +generator :: (Integral a, UniqueFactorisation a) => Prime a -> Word -> a +generator p k + | k == 1 = modP + | otherwise = if powMod modP (p'-1) (p'*p') == 1 then modP + p' else modP + where p' = unPrime p + modP = head $ filter (isPrimitiveRoot' (CGOddPrimePower p 1)) [2..p'-1] -- TODO: improve using bitshifts lambda :: Integer -> Word -> Integer lambda x e = ((powMod x (2^(e-1)) (2^(2*e-1)) - 1) `div` (2^(e+1))) `mod` (2^(e-2)) -data DirichletFactor = OddPrime { getPrime :: Prime Integer - , getPower :: Word - , getGenerator :: Integer - , getValue :: Natural - } - | Four { getValue :: Natural } - | TwoPower { getPower :: Word - , getFirstValue :: Natural - , getSecondValue :: Natural - } +generalEval :: KnownNat n => DirichletCharacter n -> Mod n -> Maybe RootOfUnity +generalEval chi = fmap (evaluate chi) . isMultElement evaluate :: KnownNat n => DirichletCharacter n -> MultMod n -> RootOfUnity evaluate (Generated ds) m = foldMap (evalFactor m') ds @@ -99,10 +104,73 @@ evaluate (Generated ds) m = foldMap (evalFactor m') ds evalFactor :: Integer -> DirichletFactor -> RootOfUnity evalFactor m = \case - OddPrime (unPrime -> p) k a b -> toRootOfUnity (toInteger (b * discreteLogarithmPP p k (fromIntegral a) (m `rem` p^k)) % (p^(k-1)*(p-1))) - Four b -> toRootOfUnity (((toInteger b) * (if (m `rem` 4) == 1 then 1 else 0)) % 2) - TwoPower k s b -> toRootOfUnity ((toInteger s) * (if (m `rem` 4) == 1 then 1 else 0) % 2) <> toRootOfUnity (toInteger b * lambda m'' k % (2^(k-2))) - where m' = m `rem` (2^k) - m'' = if m' `rem` 4 == 1 - then m' - else 2^k - m' + OddPrime (unPrime -> p) k a b -> toRootOfUnity (toInteger (b * discreteLogarithmPP p' k a' (m `rem` p'^k)) % (p'^(k-1)*(p'-1))) + where p' = toInteger p + a' = toInteger a + TwoPower k s b -> toRootOfUnity (toInteger s * (if testBit m 1 then 1 else 0) % 2) <> toRootOfUnity (toInteger b * lambda m'' k % (2^(k-2))) + where m' = m .&. kBits + m'' = if testBit m 1 + then bit (wordToInt k) - m' + else m' + kBits = bit (wordToInt k) - 1 + +-- data DirichletFactor = OddPrime { getPrime :: Prime Integer +-- , getPower :: Word +-- , getGenerator :: Integer +-- , getValue :: Natural +-- } +-- | TwoPower { getPower :: Word +-- , getFirstValue :: Natural +-- , getSecondValue :: Natural +-- } + +trivialChar :: KnownNat n => DirichletCharacter n +trivialChar = intToDChar 0 + +mulChars :: DirichletCharacter n -> DirichletCharacter n -> DirichletCharacter n +mulChars (Generated x) (Generated y) = Generated (zipWith combine x y) + where combine :: DirichletFactor -> DirichletFactor -> DirichletFactor + combine (OddPrime p k g n) (OddPrime _ _ _ m) = OddPrime p k g ((n + m) `mod` unPrime p ^ k) + combine (TwoPower k a n) (TwoPower _ b m) = TwoPower k ((a + b) `mod` 2) ((n + m) `mod` 2^(k-2)) + combine _ _ = error "Malformed DirichletCharacter" + +instance Semigroup (DirichletCharacter n) where + (<>) = mulChars + +instance KnownNat n => Monoid (DirichletCharacter n) where + mempty = trivialChar + +instance KnownNat n => Enum (DirichletCharacter n) where + toEnum = intToDChar + fromEnum = dCharToInt + -- TODO: we can write better succ and pred, by re-using the existing generators instead of recalculating them each time + +dCharToInt :: DirichletCharacter n -> Int +dCharToInt (Generated y) = foldr go 0 y + where go :: DirichletFactor -> Int -> Int + go = \case + OddPrime p k _ a -> \x -> x * (p'^(k-1)*(p'-1)) + (fromIntegral a) + where p' = fromIntegral (unPrime p) + TwoPower k a b -> \x -> (x * (2^(k-2)) + fromIntegral b) * 2 + (fromIntegral a) + +intToDChar :: forall n. KnownNat n => Int -> DirichletCharacter n +intToDChar m + | m < 0 = error "Enum DirichletCharacter: negative input" + | m >= maxi = error "Enum DirichletCharacter: input too large" + | otherwise = Generated (go (factorise n)) + where n = natVal (Proxy :: Proxy n) + maxi = fromIntegral $ totient n + m' = fromIntegral m + go :: [(Prime Natural, Word)] -> [DirichletFactor] + go [] = [] + go f@((p,k):xs) = case (unPrime p, k) of + (2,1) -> odds m' xs + (2,_) -> TwoPower k a2 b2: odds b1 xs + where (a1,a2) = quotRem (fromIntegral m) 2 + (b1,b2) = quotRem a1 (2^(k-2)) + _ -> odds m' f + odds :: Natural -> [(Prime Natural, Word)] -> [DirichletFactor] + odds t = snd . mapAccumL func t + where func a (p,k) = (q, OddPrime p k (generator p k) r) + where (q,r) = quotRem a (p'^(k-1)*(p'-1)) + p' = unPrime p From 3c4eeaee73303757e2e53e6511c9f07c73c666e9 Mon Sep 17 00:00:00 2001 From: Bhavik Mehta Date: Sun, 30 Sep 2018 18:25:23 +0100 Subject: [PATCH 10/65] Cosmetic changes --- .../ArithmeticFunctions/Moebius.hs | 2 +- Math/NumberTheory/DirichletCharacters.hs | 35 +++++-------------- 2 files changed, 9 insertions(+), 28 deletions(-) diff --git a/Math/NumberTheory/ArithmeticFunctions/Moebius.hs b/Math/NumberTheory/ArithmeticFunctions/Moebius.hs index 388d6fd57..0bf520e7e 100644 --- a/Math/NumberTheory/ArithmeticFunctions/Moebius.hs +++ b/Math/NumberTheory/ArithmeticFunctions/Moebius.hs @@ -46,7 +46,7 @@ import Math.NumberTheory.Logarithms -- | Represents three possible values of . data Moebius - = MoebiusN -- ^ −1 + = MoebiusN -- ^ -1 | MoebiusZ -- ^ 0 | MoebiusP -- ^ 1 deriving (Eq, Ord, Show) diff --git a/Math/NumberTheory/DirichletCharacters.hs b/Math/NumberTheory/DirichletCharacters.hs index f935c1ed0..1471daf5a 100644 --- a/Math/NumberTheory/DirichletCharacters.hs +++ b/Math/NumberTheory/DirichletCharacters.hs @@ -23,18 +23,18 @@ import Data.Semigroup #endif import GHC.TypeNats.Compat import Numeric.Natural (Natural) -import Data.Bits -import Data.Ratio -import Data.Complex -import Data.Proxy -import Data.List (mapAccumL) +import Data.Bits (testBit, (.&.), bit) +import Data.Ratio (Rational, (%), numerator, denominator) +import Data.Complex (Complex, cis) +import Data.Proxy (Proxy(..)) +import Data.List (mapAccumL) import Math.NumberTheory.ArithmeticFunctions (totient) import Math.NumberTheory.Moduli.Class (KnownNat, MultMod, getVal, multElement, Mod, isMultElement) import Math.NumberTheory.Moduli.DiscreteLogarithm (discreteLogarithmPP) import Math.NumberTheory.UniqueFactorisation (UniqueFactorisation, unPrime, Prime, factorise) import Math.NumberTheory.Powers (powMod) -import Math.NumberTheory.Utils.FromIntegral +import Math.NumberTheory.Utils.FromIntegral (wordToInt) import Math.NumberTheory.Moduli.PrimitiveRoot @@ -73,16 +73,6 @@ instance Monoid RootOfUnity where fromRootOfUnity :: Floating a => RootOfUnity -> Complex a fromRootOfUnity = cis . (2*pi*) . fromRational . getFraction -canonGenHelp :: (Integral a, UniqueFactorisation a) => (Prime a, Word) -> [a] -canonGenHelp (p, k) - | p' == 2, k == 1 = [] - | p' == 2, k == 2 = [3] - | p' == 2 = [5, p'^k - 1] - | k == 1 = [modP] - | otherwise = [if powMod modP (p'-1) (p'*p') == 1 then modP + p' else modP] - where p' = unPrime p - modP = head $ filter (isPrimitiveRoot' (CGOddPrimePower p 1)) [2..p' - 1] - generator :: (Integral a, UniqueFactorisation a) => Prime a -> Word -> a generator p k | k == 1 = modP @@ -114,16 +104,6 @@ evalFactor m = else m' kBits = bit (wordToInt k) - 1 --- data DirichletFactor = OddPrime { getPrime :: Prime Integer --- , getPower :: Word --- , getGenerator :: Integer --- , getValue :: Natural --- } --- | TwoPower { getPower :: Word --- , getFirstValue :: Natural --- , getSecondValue :: Natural --- } - trivialChar :: KnownNat n => DirichletCharacter n trivialChar = intToDChar 0 @@ -143,7 +123,7 @@ instance KnownNat n => Monoid (DirichletCharacter n) where instance KnownNat n => Enum (DirichletCharacter n) where toEnum = intToDChar fromEnum = dCharToInt - -- TODO: we can write better succ and pred, by re-using the existing generators instead of recalculating them each time + -- TODO: write better succ and pred, by re-using the existing generators instead of recalculating them each time dCharToInt :: DirichletCharacter n -> Int dCharToInt (Generated y) = foldr go 0 y @@ -152,6 +132,7 @@ dCharToInt (Generated y) = foldr go 0 y OddPrime p k _ a -> \x -> x * (p'^(k-1)*(p'-1)) + (fromIntegral a) where p' = fromIntegral (unPrime p) TwoPower k a b -> \x -> (x * (2^(k-2)) + fromIntegral b) * 2 + (fromIntegral a) + -- again use bitshifts to optimise intToDChar :: forall n. KnownNat n => Int -> DirichletCharacter n intToDChar m From c744d33f0581cb6bbc6bfdcd3736fae5d44caae2 Mon Sep 17 00:00:00 2001 From: Bhavik Mehta Date: Mon, 1 Oct 2018 22:39:00 +0100 Subject: [PATCH 11/65] Added Bounded instance and generalise conversions --- Math/NumberTheory/DirichletCharacters.hs | 36 +++++++++++++----------- 1 file changed, 19 insertions(+), 17 deletions(-) diff --git a/Math/NumberTheory/DirichletCharacters.hs b/Math/NumberTheory/DirichletCharacters.hs index 1471daf5a..f8dd1ae5d 100644 --- a/Math/NumberTheory/DirichletCharacters.hs +++ b/Math/NumberTheory/DirichletCharacters.hs @@ -39,7 +39,7 @@ import Math.NumberTheory.Utils.FromIntegral (wordToInt) import Math.NumberTheory.Moduli.PrimitiveRoot data DirichletCharacter (n :: Nat) = Generated [DirichletFactor] - deriving Show + deriving (Eq, Show) data DirichletFactor = OddPrime { getPrime :: Prime Natural , getPower :: Word @@ -50,12 +50,11 @@ data DirichletFactor = OddPrime { getPrime :: Prime Natural , getFirstValue :: Natural , getSecondValue :: Natural } - deriving Show + deriving (Eq, Show) newtype RootOfUnity = RootOfUnity { getFraction :: Rational } deriving (Eq, Show) -- RootOfUnity q represents e^(2pi i * q) - -- I am happy with a custom Show instance if that's preferred toRootOfUnity :: Rational -> RootOfUnity toRootOfUnity q = RootOfUnity ((n `rem` d) % d) @@ -94,10 +93,9 @@ evaluate (Generated ds) m = foldMap (evalFactor m') ds evalFactor :: Integer -> DirichletFactor -> RootOfUnity evalFactor m = \case - OddPrime (unPrime -> p) k a b -> toRootOfUnity (toInteger (b * discreteLogarithmPP p' k a' (m `rem` p'^k)) % (p'^(k-1)*(p'-1))) - where p' = toInteger p - a' = toInteger a - TwoPower k s b -> toRootOfUnity (toInteger s * (if testBit m 1 then 1 else 0) % 2) <> toRootOfUnity (toInteger b * lambda m'' k % (2^(k-2))) + OddPrime (toInteger . unPrime -> p) k (toInteger -> a) b -> + toRootOfUnity (toInteger (b * discreteLogarithmPP p k a (m `rem` p^k)) % (p^(k-1)*(p-1))) + TwoPower k s b -> toRootOfUnity (toInteger s * (if testBit m 1 then 1 else 0) % 2) <> toRootOfUnity (toInteger b * lambda m'' k % (2^(k-2))) where m' = m .&. kBits m'' = if testBit m 1 then bit (wordToInt k) - m' @@ -105,7 +103,7 @@ evalFactor m = kBits = bit (wordToInt k) - 1 trivialChar :: KnownNat n => DirichletCharacter n -trivialChar = intToDChar 0 +trivialChar = minBound mulChars :: DirichletCharacter n -> DirichletCharacter n -> DirichletCharacter n mulChars (Generated x) (Generated y) = Generated (zipWith combine x y) @@ -121,21 +119,25 @@ instance KnownNat n => Monoid (DirichletCharacter n) where mempty = trivialChar instance KnownNat n => Enum (DirichletCharacter n) where - toEnum = intToDChar - fromEnum = dCharToInt + toEnum = fromIndex + fromEnum = characterNumber -- TODO: write better succ and pred, by re-using the existing generators instead of recalculating them each time -dCharToInt :: DirichletCharacter n -> Int -dCharToInt (Generated y) = foldr go 0 y - where go :: DirichletFactor -> Int -> Int - go = \case +instance KnownNat n => Bounded (DirichletCharacter n) where + minBound = fromIndex (0 :: Int) + maxBound = fromIndex (totient n - 1) + where n = natVal (Proxy :: Proxy n) + +characterNumber :: Integral a => DirichletCharacter n -> a +characterNumber (Generated y) = foldr go 0 y + where go = \case OddPrime p k _ a -> \x -> x * (p'^(k-1)*(p'-1)) + (fromIntegral a) where p' = fromIntegral (unPrime p) TwoPower k a b -> \x -> (x * (2^(k-2)) + fromIntegral b) * 2 + (fromIntegral a) - -- again use bitshifts to optimise + -- TODO: again use bitshifts to optimise -intToDChar :: forall n. KnownNat n => Int -> DirichletCharacter n -intToDChar m +fromIndex :: forall a n. (KnownNat n, Integral a) => a -> DirichletCharacter n +fromIndex m | m < 0 = error "Enum DirichletCharacter: negative input" | m >= maxi = error "Enum DirichletCharacter: input too large" | otherwise = Generated (go (factorise n)) From fffd85fd4b6ab4ba1873694ab15cf184427a4c03 Mon Sep 17 00:00:00 2001 From: Bhavik Mehta Date: Mon, 1 Oct 2018 22:52:29 +0100 Subject: [PATCH 12/65] Renamed conversion functions --- Math/NumberTheory/DirichletCharacters.hs | 28 +++++++++++++++++++----- 1 file changed, 22 insertions(+), 6 deletions(-) diff --git a/Math/NumberTheory/DirichletCharacters.hs b/Math/NumberTheory/DirichletCharacters.hs index f8dd1ae5d..c94f14c23 100644 --- a/Math/NumberTheory/DirichletCharacters.hs +++ b/Math/NumberTheory/DirichletCharacters.hs @@ -16,7 +16,19 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} -module Math.NumberTheory.DirichletCharacters where +module Math.NumberTheory.DirichletCharacters + ( DirichletCharacter + , RootOfUnity + , toRootOfUnity + , fromRootOfUnity + , toComplex + , evaluate + , generalEval + , toFunction + , trivialChar + , fromIndex + , characterNumber + ) where #if __GLASGOW_HASKELL__ < 803 import Data.Semigroup @@ -52,7 +64,7 @@ data DirichletFactor = OddPrime { getPrime :: Prime Natural } deriving (Eq, Show) -newtype RootOfUnity = RootOfUnity { getFraction :: Rational } +newtype RootOfUnity = RootOfUnity { fromRootOfUnity :: Rational } deriving (Eq, Show) -- RootOfUnity q represents e^(2pi i * q) @@ -69,8 +81,8 @@ instance Monoid RootOfUnity where mappend = (<>) mempty = RootOfUnity 0 -fromRootOfUnity :: Floating a => RootOfUnity -> Complex a -fromRootOfUnity = cis . (2*pi*) . fromRational . getFraction +toComplex :: Floating a => RootOfUnity -> Complex a +toComplex = cis . (2*pi*) . fromRational . fromRootOfUnity generator :: (Integral a, UniqueFactorisation a) => Prime a -> Word -> a generator p k @@ -86,6 +98,9 @@ lambda x e = ((powMod x (2^(e-1)) (2^(2*e-1)) - 1) `div` (2^(e+1))) `mod` (2^(e- generalEval :: KnownNat n => DirichletCharacter n -> Mod n -> Maybe RootOfUnity generalEval chi = fmap (evaluate chi) . isMultElement +toFunction :: (Integral a, RealFloat b, KnownNat n) => DirichletCharacter n -> a -> Complex b +toFunction chi = maybe 0 toComplex . generalEval chi . fromIntegral + evaluate :: KnownNat n => DirichletCharacter n -> MultMod n -> RootOfUnity evaluate (Generated ds) m = foldMap (evalFactor m') ds where m' = getVal $ multElement m @@ -108,9 +123,10 @@ trivialChar = minBound mulChars :: DirichletCharacter n -> DirichletCharacter n -> DirichletCharacter n mulChars (Generated x) (Generated y) = Generated (zipWith combine x y) where combine :: DirichletFactor -> DirichletFactor -> DirichletFactor - combine (OddPrime p k g n) (OddPrime _ _ _ m) = OddPrime p k g ((n + m) `mod` unPrime p ^ k) + combine (OddPrime p k g n) (OddPrime _ _ _ m) = OddPrime p k g ((n + m) `mod` (p'^(k-1)*(p'-1))) + where p' = unPrime p combine (TwoPower k a n) (TwoPower _ b m) = TwoPower k ((a + b) `mod` 2) ((n + m) `mod` 2^(k-2)) - combine _ _ = error "Malformed DirichletCharacter" + combine _ _ = error "internal error: malformed DirichletCharacter" instance Semigroup (DirichletCharacter n) where (<>) = mulChars From 7821514f3b5012703fa1f5297d66a2ca63c9ca25 Mon Sep 17 00:00:00 2001 From: Bhavik Mehta Date: Mon, 1 Oct 2018 23:01:26 +0100 Subject: [PATCH 13/65] Better dirichlet character tests --- .../NumberTheory/DirichletCharactersTests.hs | 47 ++++++++++++++----- 1 file changed, 34 insertions(+), 13 deletions(-) diff --git a/test-suite/Math/NumberTheory/DirichletCharactersTests.hs b/test-suite/Math/NumberTheory/DirichletCharactersTests.hs index b5950e6a5..f30399065 100644 --- a/test-suite/Math/NumberTheory/DirichletCharactersTests.hs +++ b/test-suite/Math/NumberTheory/DirichletCharactersTests.hs @@ -16,26 +16,47 @@ module Math.NumberTheory.DirichletCharactersTests where import Test.Tasty import Data.Proxy +import Data.Ratio import Numeric.Natural +import Data.Semigroup +import Data.Complex -import Data.List (sort) import GHC.TypeNats.Compat (SomeNat(..), someNatVal) -import Math.NumberTheory.DirichletCharacters (generators) -import Math.NumberTheory.Moduli (Mod, getNatVal) +import Math.NumberTheory.ArithmeticFunctions (totient) +import Math.NumberTheory.DirichletCharacters +-- import Math.NumberTheory.Moduli (Mod, getNatVal) import Math.NumberTheory.TestUtils (testSmallAndQuick, Positive(..)) -generatingTest :: Positive Natural -> Bool -generatingTest (Positive 1) = [1] == generators 1 -generatingTest (Positive n) = - case someNatVal n of - SomeNat (_ :: Proxy m) -> [a | a <- [1..n], gcd a n == 1] == generated - where generated = sort $ map (getNatVal . product) $ traverse helper [fromIntegral g :: Mod m | g <- generators n] - -helper :: (Eq a, Num a) => a -> [a] -helper m = 1: (takeWhile (/= 1) $ iterate (*m) m) +rootOfUnityTest :: Integer -> Positive Integer -> Bool +rootOfUnityTest n (Positive d) = toComplex ((d `div` gcd n d) `stimes` toRootOfUnity (n % d)) == (1 :: Complex Double) + +-- | This tests property 6 from https://en.wikipedia.org/wiki/Dirichlet_character#Axiomatic_definition +dirCharOrder :: Positive Natural -> Natural -> Bool +dirCharOrder (Positive n) i = case someNatVal n of + SomeNat (Proxy :: Proxy n) -> (totient n) `stimes` chi == trivialChar + where chi = fromIndex (i `mod` (totient n)) :: DirichletCharacter n + +-- | Tests wikipedia's property 3 (note 1,2,5 are essentially enforced by the type system). +dirCharMultiplicative :: Positive Natural -> Natural -> Natural -> Natural -> Bool +dirCharMultiplicative (Positive n) i a b = case someNatVal n of + SomeNat (Proxy :: Proxy n) -> let chiAchiB = (<>) <$> chi' a' <*> chi' b' + chiAB = chi' (a'*b') + in chiAB == chiAchiB + where chi = fromIndex (i `mod` (totient n)) :: DirichletCharacter n + chi' = generalEval chi + a' = fromIntegral a + b' = fromIntegral b + +dirCharAtOne :: Positive Natural -> Natural -> Bool +dirCharAtOne (Positive n) i = case someNatVal n of + SomeNat (Proxy :: Proxy n) -> evaluate chi mempty == mempty + where chi = fromIndex (i `mod` (totient n)) :: DirichletCharacter n testSuite :: TestTree testSuite = testGroup "DirichletCharacters" - [ testSmallAndQuick "check generators work" generatingTest + [ testSmallAndQuick "RootOfUnity contains roots of unity" rootOfUnityTest + , testSmallAndQuick "Dirichlet characters have the right order" dirCharOrder + , testSmallAndQuick "Dirichlet characters are multiplicative" dirCharMultiplicative + , testSmallAndQuick "Dirichlet characters are 1 at 1" dirCharMultiplicative ] From 11d21d7307ae43bac3a44d53fe1d8837a3cd0771 Mon Sep 17 00:00:00 2001 From: Bhavik Mehta Date: Tue, 2 Oct 2018 14:08:55 +0100 Subject: [PATCH 14/65] More sensible Eq and renamed trivial --- Math/NumberTheory/DirichletCharacters.hs | 23 +++++++++++++++++------ 1 file changed, 17 insertions(+), 6 deletions(-) diff --git a/Math/NumberTheory/DirichletCharacters.hs b/Math/NumberTheory/DirichletCharacters.hs index c94f14c23..4441aa002 100644 --- a/Math/NumberTheory/DirichletCharacters.hs +++ b/Math/NumberTheory/DirichletCharacters.hs @@ -25,9 +25,10 @@ module Math.NumberTheory.DirichletCharacters , evaluate , generalEval , toFunction - , trivialChar + , principalChar , fromIndex , characterNumber + , isPrincipal ) where #if __GLASGOW_HASKELL__ < 803 @@ -51,7 +52,7 @@ import Math.NumberTheory.Utils.FromIntegral (wordToInt) import Math.NumberTheory.Moduli.PrimitiveRoot data DirichletCharacter (n :: Nat) = Generated [DirichletFactor] - deriving (Eq, Show) + deriving (Show) data DirichletFactor = OddPrime { getPrime :: Prime Natural , getPower :: Word @@ -62,7 +63,14 @@ data DirichletFactor = OddPrime { getPrime :: Prime Natural , getFirstValue :: Natural , getSecondValue :: Natural } - deriving (Eq, Show) + deriving (Show) + +instance Eq (DirichletCharacter n) where + Generated a == Generated b = go a b + where go [] [] = True + go (OddPrime _ _ _ x : xs) (OddPrime _ _ _ y : ys) = x == y && go xs ys + go (TwoPower _ x1 x2 : xs) (TwoPower _ y1 y2 : ys) = x1 == y1 && x2 == y2 && go xs ys + go _ _ = False newtype RootOfUnity = RootOfUnity { fromRootOfUnity :: Rational } deriving (Eq, Show) @@ -117,8 +125,8 @@ evalFactor m = else m' kBits = bit (wordToInt k) - 1 -trivialChar :: KnownNat n => DirichletCharacter n -trivialChar = minBound +principalChar :: KnownNat n => DirichletCharacter n +principalChar = minBound mulChars :: DirichletCharacter n -> DirichletCharacter n -> DirichletCharacter n mulChars (Generated x) (Generated y) = Generated (zipWith combine x y) @@ -132,7 +140,7 @@ instance Semigroup (DirichletCharacter n) where (<>) = mulChars instance KnownNat n => Monoid (DirichletCharacter n) where - mempty = trivialChar + mempty = principalChar instance KnownNat n => Enum (DirichletCharacter n) where toEnum = fromIndex @@ -173,3 +181,6 @@ fromIndex m where func a (p,k) = (q, OddPrime p k (generator p k) r) where (q,r) = quotRem a (p'^(k-1)*(p'-1)) p' = unPrime p + +isPrincipal :: KnownNat n => DirichletCharacter n -> Bool +isPrincipal chi = chi == principalChar From 542ef03d1b327a1590f60e3805ff9974f8e778a7 Mon Sep 17 00:00:00 2001 From: Bhavik Mehta Date: Tue, 2 Oct 2018 15:07:10 +0100 Subject: [PATCH 15/65] Handling of real dirichlet characters --- Math/NumberTheory/DirichletCharacters.hs | 44 ++++++++++++++++++++++-- 1 file changed, 41 insertions(+), 3 deletions(-) diff --git a/Math/NumberTheory/DirichletCharacters.hs b/Math/NumberTheory/DirichletCharacters.hs index 4441aa002..860b97f03 100644 --- a/Math/NumberTheory/DirichletCharacters.hs +++ b/Math/NumberTheory/DirichletCharacters.hs @@ -15,6 +15,7 @@ {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} module Math.NumberTheory.DirichletCharacters ( DirichletCharacter @@ -29,11 +30,15 @@ module Math.NumberTheory.DirichletCharacters , fromIndex , characterNumber , isPrincipal + , induced + , jacobiCharacter + , isRealCharacter + , getRealChar + , toRealFunction ) where -#if __GLASGOW_HASKELL__ < 803 import Data.Semigroup -#endif +import qualified GHC.TypeLits as TL import GHC.TypeNats.Compat import Numeric.Natural (Natural) import Data.Bits (testBit, (.&.), bit) @@ -44,6 +49,7 @@ import Data.List (mapAccumL) import Math.NumberTheory.ArithmeticFunctions (totient) import Math.NumberTheory.Moduli.Class (KnownNat, MultMod, getVal, multElement, Mod, isMultElement) +import Math.NumberTheory.Moduli.Jacobi (jacobi, JacobiSymbol(..)) import Math.NumberTheory.Moduli.DiscreteLogarithm (discreteLogarithmPP) import Math.NumberTheory.UniqueFactorisation (UniqueFactorisation, unPrime, Prime, factorise) import Math.NumberTheory.Powers (powMod) @@ -84,6 +90,8 @@ toRootOfUnity q = RootOfUnity ((n `rem` d) % d) instance Semigroup RootOfUnity where (RootOfUnity q1) <> (RootOfUnity q2) = toRootOfUnity (q1 + q2) + stimes k (RootOfUnity q) = toRootOfUnity (q * fromIntegral k) + -- ^ This Semigroup is in fact a group, so @stimes@ can be called with a negative first argument. instance Monoid RootOfUnity where mappend = (<>) @@ -109,7 +117,7 @@ generalEval chi = fmap (evaluate chi) . isMultElement toFunction :: (Integral a, RealFloat b, KnownNat n) => DirichletCharacter n -> a -> Complex b toFunction chi = maybe 0 toComplex . generalEval chi . fromIntegral -evaluate :: KnownNat n => DirichletCharacter n -> MultMod n -> RootOfUnity +evaluate :: DirichletCharacter n -> MultMod n -> RootOfUnity evaluate (Generated ds) m = foldMap (evalFactor m') ds where m' = getVal $ multElement m @@ -184,3 +192,33 @@ fromIndex m isPrincipal :: KnownNat n => DirichletCharacter n -> Bool isPrincipal chi = chi == principalChar + +induced :: (KnownNat d, KnownNat n, TL.Mod n d ~ 0) => DirichletCharacter d -> DirichletCharacter n +induced = error "TODO" + +jacobiCharacter :: forall n. (KnownNat n, TL.Mod n 2 ~ 1) => RealCharacter n +jacobiCharacter = RealChar (Generated (func <$> factorise n)) + where n = natVal (Proxy :: Proxy n) + func :: (Prime Natural, Word) -> DirichletFactor + func (p,k) = OddPrime p k g val -- we know p is odd since n is odd and p | n + where p' = unPrime p + g = generator p k + val = case k `stimes` jacobi g p' of + One -> 0 + MinusOne -> p'^(k-1)*((p'-1) `div` 2) -- p is odd so this is fine + Zero -> error "internal error in jacobiCharacter: please report this as a bug" + +newtype RealCharacter n = RealChar { getRealChar :: DirichletCharacter n } + +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 (unPrime -> p) k _ a) = a == 0 || a*2 == p^(k-1)*(p-1) + real (TwoPower k _ b) = b == 0 || b == 2^(k-3) + +toRealFunction :: KnownNat n => RealCharacter n -> Natural -> Int +toRealFunction (RealChar chi) m = case generalEval chi (fromIntegral m) of + Nothing -> 0 + Just t | t == mempty -> 1 + Just t | t == RootOfUnity (1 % 2) -> -1 + _ -> error "internal error in toRealFunction: please report this as a bug" From bdc937a79d3593c70a3e79fe402141687a6863c6 Mon Sep 17 00:00:00 2001 From: Bhavik Mehta Date: Tue, 2 Oct 2018 15:13:30 +0100 Subject: [PATCH 16/65] Added more dirichlet tests --- .../NumberTheory/DirichletCharactersTests.hs | 54 ++++++++++++------- 1 file changed, 35 insertions(+), 19 deletions(-) diff --git a/test-suite/Math/NumberTheory/DirichletCharactersTests.hs b/test-suite/Math/NumberTheory/DirichletCharactersTests.hs index f30399065..76f360a4e 100644 --- a/test-suite/Math/NumberTheory/DirichletCharactersTests.hs +++ b/test-suite/Math/NumberTheory/DirichletCharactersTests.hs @@ -10,6 +10,7 @@ -- {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Rank2Types #-} module Math.NumberTheory.DirichletCharactersTests where @@ -20,8 +21,10 @@ import Data.Ratio import Numeric.Natural import Data.Semigroup import Data.Complex +import Data.List (nub, genericLength, genericReplicate) +import Data.Maybe (mapMaybe) -import GHC.TypeNats.Compat (SomeNat(..), someNatVal) +import GHC.TypeNats.Compat (SomeNat(..), someNatVal, KnownNat) import Math.NumberTheory.ArithmeticFunctions (totient) import Math.NumberTheory.DirichletCharacters @@ -34,29 +37,42 @@ rootOfUnityTest n (Positive d) = toComplex ((d `div` gcd n d) `stimes` toRootOfU -- | This tests property 6 from https://en.wikipedia.org/wiki/Dirichlet_character#Axiomatic_definition dirCharOrder :: Positive Natural -> Natural -> Bool dirCharOrder (Positive n) i = case someNatVal n of - SomeNat (Proxy :: Proxy n) -> (totient n) `stimes` chi == trivialChar + SomeNat (Proxy :: Proxy n) -> (totient n) `stimes` chi == principalChar where chi = fromIndex (i `mod` (totient n)) :: DirichletCharacter n -- | Tests wikipedia's property 3 (note 1,2,5 are essentially enforced by the type system). -dirCharMultiplicative :: Positive Natural -> Natural -> Natural -> Natural -> Bool -dirCharMultiplicative (Positive n) i a b = case someNatVal n of - SomeNat (Proxy :: Proxy n) -> let chiAchiB = (<>) <$> chi' a' <*> chi' b' - chiAB = chi' (a'*b') - in chiAB == chiAchiB - where chi = fromIndex (i `mod` (totient n)) :: DirichletCharacter n - chi' = generalEval chi - a' = fromIntegral a - b' = fromIntegral b - -dirCharAtOne :: Positive Natural -> Natural -> Bool -dirCharAtOne (Positive n) i = case someNatVal n of - SomeNat (Proxy :: Proxy n) -> evaluate chi mempty == mempty - where chi = fromIndex (i `mod` (totient n)) :: DirichletCharacter n +testMultiplicative :: KnownNat n => DirichletCharacter n -> Natural -> Natural -> Bool +testMultiplicative chi a b = chiAB == chiAchiB + where chi' = generalEval chi + a' = fromIntegral a + b' = fromIntegral b + chiAB = chi' (a'*b') + chiAchiB = (<>) <$> chi' a' <*> chi' b' + +testAtOne :: KnownNat n => DirichletCharacter n -> Bool +testAtOne chi = evaluate 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 = fromIndex (i `mod` (totient n)) :: DirichletCharacter n + +countCharacters :: Positive Natural -> Bool +countCharacters (Positive n) = case someNatVal n of + SomeNat (Proxy :: Proxy n) -> + genericLength (nub [minBound :: DirichletCharacter n .. maxBound]) == totient n + +principalCase :: Positive Natural -> Bool +principalCase (Positive n) = case someNatVal n of + SomeNat (Proxy :: Proxy n) -> mapMaybe (generalEval chi) [minBound..maxBound] == genericReplicate (totient n) mempty + where chi = principalChar :: DirichletCharacter n testSuite :: TestTree testSuite = testGroup "DirichletCharacters" [ testSmallAndQuick "RootOfUnity contains roots of unity" rootOfUnityTest - , testSmallAndQuick "Dirichlet characters have the right order" dirCharOrder - , testSmallAndQuick "Dirichlet characters are multiplicative" dirCharMultiplicative - , testSmallAndQuick "Dirichlet characters are 1 at 1" dirCharMultiplicative + , testSmallAndQuick "Dirichlet characters divide the right order" 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 ] From 6bc0631c674dd1ce336729b8c23e7d5199f65bc3 Mon Sep 17 00:00:00 2001 From: Bhavik Mehta Date: Tue, 2 Oct 2018 16:19:40 +0100 Subject: [PATCH 17/65] Orthogonality relations and real tests --- Math/NumberTheory/DirichletCharacters.hs | 10 +++--- .../NumberTheory/DirichletCharactersTests.hs | 36 ++++++++++++++++--- 2 files changed, 37 insertions(+), 9 deletions(-) diff --git a/Math/NumberTheory/DirichletCharacters.hs b/Math/NumberTheory/DirichletCharacters.hs index 860b97f03..b7fd62f51 100644 --- a/Math/NumberTheory/DirichletCharacters.hs +++ b/Math/NumberTheory/DirichletCharacters.hs @@ -10,8 +10,6 @@ -- {-# LANGUAGE DataKinds #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -30,7 +28,6 @@ module Math.NumberTheory.DirichletCharacters , fromIndex , characterNumber , isPrincipal - , induced , jacobiCharacter , isRealCharacter , getRealChar @@ -193,8 +190,8 @@ fromIndex m isPrincipal :: KnownNat n => DirichletCharacter n -> Bool isPrincipal chi = chi == principalChar -induced :: (KnownNat d, KnownNat n, TL.Mod n d ~ 0) => DirichletCharacter d -> DirichletCharacter n -induced = error "TODO" +-- induced :: (KnownNat d, KnownNat n, TL.Mod n d ~ 0) => DirichletCharacter d -> DirichletCharacter n +-- induced = error "TODO" jacobiCharacter :: forall n. (KnownNat n, TL.Mod n 2 ~ 1) => RealCharacter n jacobiCharacter = RealChar (Generated (func <$> factorise n)) @@ -216,6 +213,9 @@ isRealCharacter t@(Generated xs) = if all real xs then Just (RealChar t) else No real (OddPrime (unPrime -> p) k _ a) = a == 0 || a*2 == p^(k-1)*(p-1) real (TwoPower k _ b) = b == 0 || b == 2^(k-3) +-- TODO: it should be possible to calculate this without evaluate/generalEval +-- and thus avoid using discrete log calculations: consider the order of m +-- inside each of the factor groups? toRealFunction :: KnownNat n => RealCharacter n -> Natural -> Int toRealFunction (RealChar chi) m = case generalEval chi (fromIntegral m) of Nothing -> 0 diff --git a/test-suite/Math/NumberTheory/DirichletCharactersTests.hs b/test-suite/Math/NumberTheory/DirichletCharactersTests.hs index 76f360a4e..c1009887c 100644 --- a/test-suite/Math/NumberTheory/DirichletCharactersTests.hs +++ b/test-suite/Math/NumberTheory/DirichletCharactersTests.hs @@ -21,14 +21,14 @@ import Data.Ratio import Numeric.Natural import Data.Semigroup import Data.Complex -import Data.List (nub, genericLength, genericReplicate) -import Data.Maybe (mapMaybe) +import Data.List (nub, genericLength, genericReplicate, isSubsequenceOf) +import Data.Maybe (mapMaybe, isJust) -import GHC.TypeNats.Compat (SomeNat(..), someNatVal, KnownNat) +import GHC.TypeNats.Compat (SomeNat(..), someNatVal, KnownNat, natVal) import Math.NumberTheory.ArithmeticFunctions (totient) import Math.NumberTheory.DirichletCharacters --- import Math.NumberTheory.Moduli (Mod, getNatVal) +import Math.NumberTheory.Moduli.Class (SomeMod(..), modulo) import Math.NumberTheory.TestUtils (testSmallAndQuick, Positive(..)) rootOfUnityTest :: Integer -> Positive Integer -> Bool @@ -49,6 +49,7 @@ testMultiplicative chi a b = chiAB == chiAchiB chiAB = chi' (a'*b') chiAchiB = (<>) <$> chi' a' <*> chi' b' +-- | Test property 4 from wikipedia testAtOne :: KnownNat n => DirichletCharacter n -> Bool testAtOne chi = evaluate chi mempty == mempty @@ -57,16 +58,40 @@ dirCharProperty test (Positive n) i = case someNatVal n of SomeNat (Proxy :: Proxy n) -> test chi where chi = fromIndex (i `mod` (totient n)) :: DirichletCharacter n +-- | There should be phi(n) characters countCharacters :: Positive Natural -> Bool countCharacters (Positive n) = case someNatVal n of SomeNat (Proxy :: Proxy n) -> genericLength (nub [minBound :: DirichletCharacter n .. maxBound]) == totient n +-- | The principal character should be 1 at all phi(n) places principalCase :: Positive Natural -> Bool principalCase (Positive n) = case someNatVal n of SomeNat (Proxy :: Proxy n) -> mapMaybe (generalEval chi) [minBound..maxBound] == genericReplicate (totient n) mempty where chi = principalChar :: DirichletCharacter n +-- | 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-14 + where n = natVal (Proxy :: Proxy n) + total = sum [toFunction chi a | a <- [0..n-1]] + 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 + where total = sum [maybe 0 toComplex (generalEval chi a') | chi <- [minBound .. maxBound]] + correct = if a' == 1 + then fromIntegral $ totient n + else 0 + InfMod {} -> False + +realityCheck :: forall n. KnownNat n => DirichletCharacter n -> Bool +realityCheck chi = isJust (isRealCharacter chi) == isReal' + where isReal' = nub (mapMaybe (generalEval chi) [minBound..maxBound]) `isSubsequenceOf` [mempty, toRootOfUnity (1 % 2)] + testSuite :: TestTree testSuite = testGroup "DirichletCharacters" [ testSmallAndQuick "RootOfUnity contains roots of unity" rootOfUnityTest @@ -75,4 +100,7 @@ testSuite = testGroup "DirichletCharacters" , 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 valid" (dirCharProperty realityCheck) ] From d65bc7679c69ba4aba0fd2436b4e14023551aaab Mon Sep 17 00:00:00 2001 From: Bhavik Mehta Date: Tue, 2 Oct 2018 17:54:14 +0100 Subject: [PATCH 18/65] No need for TypeLits.Mod --- Math/NumberTheory/DirichletCharacters.hs | 10 ++++------ 1 file changed, 4 insertions(+), 6 deletions(-) diff --git a/Math/NumberTheory/DirichletCharacters.hs b/Math/NumberTheory/DirichletCharacters.hs index b7fd62f51..faa07b1eb 100644 --- a/Math/NumberTheory/DirichletCharacters.hs +++ b/Math/NumberTheory/DirichletCharacters.hs @@ -35,7 +35,6 @@ module Math.NumberTheory.DirichletCharacters ) where import Data.Semigroup -import qualified GHC.TypeLits as TL import GHC.TypeNats.Compat import Numeric.Natural (Natural) import Data.Bits (testBit, (.&.), bit) @@ -190,11 +189,10 @@ fromIndex m isPrincipal :: KnownNat n => DirichletCharacter n -> Bool isPrincipal chi = chi == principalChar --- induced :: (KnownNat d, KnownNat n, TL.Mod n d ~ 0) => DirichletCharacter d -> DirichletCharacter n --- induced = error "TODO" - -jacobiCharacter :: forall n. (KnownNat n, TL.Mod n 2 ~ 1) => RealCharacter n -jacobiCharacter = RealChar (Generated (func <$> factorise n)) +jacobiCharacter :: forall n. KnownNat n => Maybe (RealCharacter n) +jacobiCharacter = if odd n + then Just (RealChar (Generated (func <$> factorise n))) + else Nothing where n = natVal (Proxy :: Proxy n) func :: (Prime Natural, Word) -> DirichletFactor func (p,k) = OddPrime p k g val -- we know p is odd since n is odd and p | n From ef6de1b6b7ad221d57d89c122eef59a2ad88c163 Mon Sep 17 00:00:00 2001 From: Bhavik Mehta Date: Wed, 3 Oct 2018 14:41:34 +0100 Subject: [PATCH 19/65] Induce dirichlet characters to higher moduli --- Math/NumberTheory/DirichletCharacters.hs | 29 +++++++++++++++++++ .../NumberTheory/DirichletCharactersTests.hs | 22 +++++++++++--- 2 files changed, 47 insertions(+), 4 deletions(-) diff --git a/Math/NumberTheory/DirichletCharacters.hs b/Math/NumberTheory/DirichletCharacters.hs index faa07b1eb..a1065d6fc 100644 --- a/Math/NumberTheory/DirichletCharacters.hs +++ b/Math/NumberTheory/DirichletCharacters.hs @@ -32,6 +32,7 @@ module Math.NumberTheory.DirichletCharacters , isRealCharacter , getRealChar , toRealFunction + , induced ) where import Data.Semigroup @@ -189,6 +190,34 @@ fromIndex m isPrincipal :: KnownNat n => DirichletCharacter n -> Bool isPrincipal chi = chi == principalChar +induced :: forall d n. (KnownNat d, KnownNat n) => DirichletCharacter d -> Maybe (DirichletCharacter n) +induced (Generated start) = if n `rem` d == 0 + then Just (Generated (combine n' start)) + else Nothing + where n = natVal (Proxy :: Proxy n) + d = natVal (Proxy :: Proxy d) + n' = factorise n + combine :: [(Prime Natural, Word)] -> [DirichletFactor] -> [DirichletFactor] + combine [] _ = [] + combine t [] = plain t + combine ((p1,k1):xs) (y:ys) + | unPrime p1 == 2, TwoPower k2 a b <- y = TwoPower k1 a (b*2^(k1-k2)): combine xs ys + | OddPrime p2 1 _g a <- y, p1 == p2 = OddPrime p2 k1 (generator p2 k1) (a*unPrime p1^(k1-1)): combine xs ys + -- generator p2 k1 will be g or g + p2, and we already know g is a primroot mod p + -- so should be able to save work instead of running generator + | OddPrime p2 k2 g a <- y, p1 == p2 = OddPrime p2 k1 g (a*unPrime p1^(k1-k2)): combine xs ys + | unPrime p1 == 2, k1 >= 2 = TwoPower k1 0 0: combine xs (y:ys) + | unPrime p1 == 2 = combine xs (y:ys) + | otherwise = OddPrime p1 k1 (generator p1 k1) 0: combine xs (y:ys) + plain :: [(Prime Natural, Word)] -> [DirichletFactor] + plain [] = [] + plain f@((p,k):xs) = case (unPrime p, k) of + (2,1) -> map rest xs + (2,_) -> TwoPower k 0 0: map rest xs + _ -> map rest f + rest :: (Prime Natural, Word) -> DirichletFactor + rest (p,k) = OddPrime p k (generator p k) 0 + jacobiCharacter :: forall n. KnownNat n => Maybe (RealCharacter n) jacobiCharacter = if odd n then Just (RealChar (Generated (func <$> factorise n))) diff --git a/test-suite/Math/NumberTheory/DirichletCharactersTests.hs b/test-suite/Math/NumberTheory/DirichletCharactersTests.hs index c1009887c..a8efc214a 100644 --- a/test-suite/Math/NumberTheory/DirichletCharactersTests.hs +++ b/test-suite/Math/NumberTheory/DirichletCharactersTests.hs @@ -67,12 +67,13 @@ countCharacters (Positive n) = case someNatVal n of -- | The principal character should be 1 at all phi(n) places principalCase :: Positive Natural -> Bool principalCase (Positive n) = case someNatVal n of - SomeNat (Proxy :: Proxy n) -> mapMaybe (generalEval chi) [minBound..maxBound] == genericReplicate (totient n) mempty - where chi = principalChar :: DirichletCharacter n + SomeNat (Proxy :: Proxy n) -> + mapMaybe (generalEval chi) [minBound..maxBound] == genericReplicate (totient n) mempty + where chi = principalChar :: DirichletCharacter n -- | 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-14 +orthogonality1 chi = magnitude (total - correct) < (1e-13 :: Double) where n = natVal (Proxy :: Proxy n) total = sum [toFunction chi a | a <- [0..n-1]] correct = if isPrincipal chi @@ -81,17 +82,29 @@ orthogonality1 chi = magnitude (total - correct) < 1e-14 orthogonality2 :: Positive Natural -> Integer -> Bool orthogonality2 (Positive n) a = case a `modulo` n of - SomeMod a' -> magnitude (total - correct) < 1e-13 + SomeMod a' -> magnitude (total - correct) < (1e-13 :: Double) where total = sum [maybe 0 toComplex (generalEval chi a') | chi <- [minBound .. maxBound]] correct = if a' == 1 then fromIntegral $ totient n else 0 InfMod {} -> False +-- | Manually confirm isRealCharacter is correct (in both directions) realityCheck :: forall n. KnownNat n => DirichletCharacter n -> Bool realityCheck chi = isJust (isRealCharacter chi) == isReal' where isReal' = nub (mapMaybe (generalEval chi) [minBound..maxBound]) `isSubsequenceOf` [mempty, toRootOfUnity (1 % 2)] +-- | Induced characters agree with the original character. +inducedCheck :: forall d. KnownNat d => DirichletCharacter d -> Positive Natural -> Bool +inducedCheck chi (Positive k) = + case someNatVal (d*k) of + SomeNat (Proxy :: Proxy n) -> + case chi2 of + Just chi2' -> and [generalEval chi2' (fromIntegral j) == generalEval chi (fromIntegral j) | j <- [0..d*k-1], gcd j (d*k) == 1] + _ -> False + where chi2 = induced chi :: Maybe (DirichletCharacter n) + where d = natVal (Proxy :: Proxy d) + testSuite :: TestTree testSuite = testGroup "DirichletCharacters" [ testSmallAndQuick "RootOfUnity contains roots of unity" rootOfUnityTest @@ -103,4 +116,5 @@ testSuite = testGroup "DirichletCharacters" , testSmallAndQuick "Orthogonality relation 1" (dirCharProperty orthogonality1) , testSmallAndQuick "Orthogonality relation 2" orthogonality2 , testSmallAndQuick "Real character checking is valid" (dirCharProperty realityCheck) + , testSmallAndQuick "Induced character is correct" (dirCharProperty inducedCheck) ] From 3b5a225ce6eb9c0117c3ce06917aaff96f0dff66 Mon Sep 17 00:00:00 2001 From: Bhavik Mehta Date: Mon, 31 Dec 2018 05:51:16 +0000 Subject: [PATCH 20/65] Improved haddock for dirichlet characters --- Math/NumberTheory/DirichletCharacters.hs | 42 +++++++++++++++++++----- 1 file changed, 33 insertions(+), 9 deletions(-) diff --git a/Math/NumberTheory/DirichletCharacters.hs b/Math/NumberTheory/DirichletCharacters.hs index a1065d6fc..d8bcfe540 100644 --- a/Math/NumberTheory/DirichletCharacters.hs +++ b/Math/NumberTheory/DirichletCharacters.hs @@ -16,23 +16,30 @@ {-# LANGUAGE TypeFamilies #-} module Math.NumberTheory.DirichletCharacters - ( DirichletCharacter - , RootOfUnity + ( + -- * Roots of unity + RootOfUnity + -- ** Conversions , toRootOfUnity , fromRootOfUnity , toComplex + -- * Dirichlet characters + , DirichletCharacter , evaluate , generalEval , toFunction - , principalChar , fromIndex , characterNumber + -- ** Special Dirichlet characters + , principalChar , isPrincipal , jacobiCharacter + , induced + -- ** Real Dirichlet characters + , RealCharacter , isRealCharacter , getRealChar , toRealFunction - , induced ) where import Data.Semigroup @@ -75,25 +82,42 @@ instance Eq (DirichletCharacter n) where go (TwoPower _ x1 x2 : xs) (TwoPower _ y1 y2 : ys) = x1 == y1 && x2 == y2 && go xs ys go _ _ = False -newtype RootOfUnity = RootOfUnity { fromRootOfUnity :: Rational } - deriving (Eq, Show) - -- RootOfUnity q represents e^(2pi i * q) - +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 = "e^0" + | d == 1 = "e^(πi)" + | 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 * fromIntegral k) - -- ^ This Semigroup is in fact a group, so @stimes@ can be called with a negative first argument. instance Monoid RootOfUnity where mappend = (<>) 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 [cyclotomic](http://hackage.haskell.org/package/cyclotomic-0.5.1) +-- 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 = cis . (2*pi*) . fromRational . fromRootOfUnity From 6eb94ec5657652cda9635ecdb5a764e09391231b Mon Sep 17 00:00:00 2001 From: Bhavik Mehta Date: Mon, 31 Dec 2018 19:54:05 +0000 Subject: [PATCH 21/65] Some better haddocks --- Math/NumberTheory/DirichletCharacters.hs | 57 ++++++++++++++++++------ 1 file changed, 43 insertions(+), 14 deletions(-) diff --git a/Math/NumberTheory/DirichletCharacters.hs b/Math/NumberTheory/DirichletCharacters.hs index d8bcfe540..8d811df87 100644 --- a/Math/NumberTheory/DirichletCharacters.hs +++ b/Math/NumberTheory/DirichletCharacters.hs @@ -64,14 +64,14 @@ import Math.NumberTheory.Moduli.PrimitiveRoot data DirichletCharacter (n :: Nat) = Generated [DirichletFactor] deriving (Show) -data DirichletFactor = OddPrime { getPrime :: Prime Natural - , getPower :: Word - , getGenerator :: Natural - , getValue :: Natural +data DirichletFactor = OddPrime { _getPrime :: Prime Natural + , _getPower :: Word + , _getGenerator :: Natural + , _getValue :: Natural } - | TwoPower { getPower :: Word - , getFirstValue :: Natural - , getSecondValue :: Natural + | TwoPower { _getPower :: Word + , _getFirstValue :: Natural + , _getSecondValue :: Natural } deriving (Show) @@ -82,6 +82,8 @@ instance Eq (DirichletCharacter n) where go (TwoPower _ x1 x2 : xs) (TwoPower _ y1 y2 : ys) = x1 == y1 && x2 == y2 && go xs ys go _ _ = False +-- | A representation of : 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. @@ -114,13 +116,16 @@ instance Monoid RootOfUnity where mappend = (<>) 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 [cyclotomic](http://hackage.haskell.org/package/cyclotomic-0.5.1) --- 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. +-- | 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 = cis . (2*pi*) . fromRational . fromRootOfUnity +-- | For primes, the canonical primitive root is the smallest such. For prime powers \(p^k\), +-- either the smallest primitive root \(g\) mod \(p\) works, or \(g+p\) works. generator :: (Integral a, UniqueFactorisation a) => Prime a -> Word -> a generator p k | k == 1 = modP @@ -128,7 +133,8 @@ generator p k where p' = unPrime p modP = head $ filter (isPrimitiveRoot' (CGOddPrimePower p 1)) [2..p'-1] --- TODO: improve using bitshifts +-- | Implement the function \(\lambda\) from page 5 of +-- https://www2.eecs.berkeley.edu/Pubs/TechRpts/1984/CSD-84-186.pdf lambda :: Integer -> Word -> Integer lambda x e = ((powMod x (2^(e-1)) (2^(2*e-1)) - 1) `div` (2^(e+1))) `mod` (2^(e-2)) @@ -154,6 +160,8 @@ evalFactor m = else m' kBits = bit (wordToInt k) - 1 +-- | 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 @@ -171,6 +179,8 @@ instance Semigroup (DirichletCharacter n) where instance KnownNat n => Monoid (DirichletCharacter n) where mempty = principalChar +-- | We define `succ` and `pred` with more efficient implementations than +-- `toEnum . (+1) . fromEnum`. instance KnownNat n => Enum (DirichletCharacter n) where toEnum = fromIndex fromEnum = characterNumber @@ -211,10 +221,22 @@ fromIndex m where (q,r) = quotRem a (p'^(k-1)*(p'-1)) p' = unPrime p +-- | 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 :: KnownNat n => DirichletCharacter n -> Bool isPrincipal chi = chi == principalChar -induced :: forall d n. (KnownNat d, KnownNat n) => DirichletCharacter d -> Maybe (DirichletCharacter n) +-- | Induce a Dirichlet character to a higher modulus. If \(d \mid n\), then \(a \bmod{n}\) can be +-- reduced to \(a \bmod{d}\). Thus, a multiplicative function on \(\mathbb{Z}/d\mathbb{Z}\) +-- induces a multiplicative function on \(\mathbb{Z}/n\mathbb{Z}\). +-- +-- >>> :set -XTypeApplications +-- >>> chi = fromIndex 5 :: DirichletCharacter 45 +-- >>> chi2 = induced @135 chi +-- >>> :t chi2 +-- 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 n' start)) else Nothing @@ -242,6 +264,8 @@ induced (Generated start) = if n `rem` d == 0 rest :: (Prime Natural, Word) -> DirichletFactor rest (p,k) = OddPrime p k (generator p k) 0 +-- | The gives a real Dirichlet +-- character for odd moduli. jacobiCharacter :: forall n. KnownNat n => Maybe (RealCharacter n) jacobiCharacter = if odd n then Just (RealChar (Generated (func <$> factorise n))) @@ -256,8 +280,12 @@ jacobiCharacter = if odd n MinusOne -> p'^(k-1)*((p'-1) `div` 2) -- p is odd so this is fine Zero -> error "internal error in jacobiCharacter: please report this as a bug" -newtype RealCharacter n = RealChar { getRealChar :: DirichletCharacter n } +-- | A Dirichlet character is real if it is real-valued. +newtype RealCharacter n = RealChar { -- | Extract the character itself from a `RealCharacter`. + getRealChar :: DirichletCharacter n + } +-- | 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 @@ -267,6 +295,7 @@ isRealCharacter t@(Generated xs) = if all real xs then Just (RealChar t) else No -- TODO: it should be possible to calculate this without evaluate/generalEval -- 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 -> Natural -> Int toRealFunction (RealChar chi) m = case generalEval chi (fromIntegral m) of Nothing -> 0 From bacecd96322d228048f9fce020956f5c0842fd7d Mon Sep 17 00:00:00 2001 From: Bhavik Mehta Date: Mon, 31 Dec 2018 20:38:05 +0000 Subject: [PATCH 22/65] More sensible Eq and Enum instances for DChars --- Math/NumberTheory/DirichletCharacters.hs | 63 +++++++++++++++++++----- 1 file changed, 51 insertions(+), 12 deletions(-) diff --git a/Math/NumberTheory/DirichletCharacters.hs b/Math/NumberTheory/DirichletCharacters.hs index 8d811df87..3d3248bae 100644 --- a/Math/NumberTheory/DirichletCharacters.hs +++ b/Math/NumberTheory/DirichletCharacters.hs @@ -28,7 +28,7 @@ module Math.NumberTheory.DirichletCharacters , evaluate , generalEval , toFunction - , fromIndex + , indexToChar , characterNumber -- ** Special Dirichlet characters , principalChar @@ -76,11 +76,12 @@ data DirichletFactor = OddPrime { _getPrime :: Prime Natural deriving (Show) instance Eq (DirichletCharacter n) where - Generated a == Generated b = go a b - where go [] [] = True - go (OddPrime _ _ _ x : xs) (OddPrime _ _ _ y : ys) = x == y && go xs ys - go (TwoPower _ x1 x2 : xs) (TwoPower _ y1 y2 : ys) = x1 == y1 && x2 == y2 && go xs ys - go _ _ = False + 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 + _ == _ = False -- | A representation of : complex -- numbers \(z\) for which there is \(n\) such that \(z^n=1\). @@ -182,13 +183,14 @@ instance KnownNat n => Monoid (DirichletCharacter n) where -- | We define `succ` and `pred` with more efficient implementations than -- `toEnum . (+1) . fromEnum`. instance KnownNat n => Enum (DirichletCharacter n) where - toEnum = fromIndex + toEnum = indexToChar fromEnum = characterNumber - -- TODO: write better succ and pred, by re-using the existing generators instead of recalculating them each time + succ = nextChar + pred = prevChar instance KnownNat n => Bounded (DirichletCharacter n) where - minBound = fromIndex (0 :: Int) - maxBound = fromIndex (totient n - 1) + minBound = indexToChar (0 :: Int) + maxBound = indexToChar (totient n - 1) where n = natVal (Proxy :: Proxy n) characterNumber :: Integral a => DirichletCharacter n -> a @@ -199,8 +201,8 @@ characterNumber (Generated y) = foldr go 0 y TwoPower k a b -> \x -> (x * (2^(k-2)) + fromIntegral b) * 2 + (fromIntegral a) -- TODO: again use bitshifts to optimise -fromIndex :: forall a n. (KnownNat n, Integral a) => a -> DirichletCharacter n -fromIndex m +indexToChar :: forall a n. (KnownNat n, Integral a) => a -> DirichletCharacter n +indexToChar m | m < 0 = error "Enum DirichletCharacter: negative input" | m >= maxi = error "Enum DirichletCharacter: input too large" | otherwise = Generated (go (factorise n)) @@ -221,6 +223,43 @@ fromIndex m where (q,r) = quotRem a (p'^(k-1)*(p'-1)) p' = unPrime p +nextChar :: DirichletCharacter n -> DirichletCharacter n +nextChar (Generated t) = Generated (map rollOver l ++ r') + where saturated :: DirichletFactor -> Bool + saturated (TwoPower k a b) = a == 1 && b + 1 == bit (wordToInt $ k-2) + saturated (OddPrime p k _ a) = a + 1 == p'^(k-1)*(p'-1) + where p' = unPrime p + (l,r) = span saturated t + rollOver :: DirichletFactor -> DirichletFactor + rollOver (TwoPower k _ _) = TwoPower k 0 0 + rollOver (OddPrime p k g _) = OddPrime p k g 0 + addOne :: DirichletFactor -> DirichletFactor + addOne (TwoPower k 0 b) = TwoPower k 1 b + addOne (TwoPower k _ b) = TwoPower k 0 (b+1) + addOne (OddPrime p k g a) = OddPrime p k g (a+1) + r' = case r of + [] -> error "DirichletCharacter: succ of largest character" + (x:rs) -> addOne x: rs + +prevChar :: DirichletCharacter n -> DirichletCharacter n +prevChar (Generated t) = Generated (map rollBack l ++ r') + where empty :: DirichletFactor -> Bool + empty (TwoPower _ 0 0) = True + empty (OddPrime _ _ _ 0) = True + empty _ = False + (l,r) = span empty t + rollBack :: DirichletFactor -> DirichletFactor + rollBack (TwoPower k _ _) = TwoPower k 1 (bit (wordToInt $ k-2) - 1) + rollBack (OddPrime p k g _) = OddPrime p k g (p'^(k-1)*(p'-1) - 1) + where p' = unPrime p + subOne :: DirichletFactor -> DirichletFactor + subOne (TwoPower k 1 b) = TwoPower k 0 b + subOne (TwoPower k _ b) = TwoPower k 1 (b-1) + subOne (OddPrime p k g a) = OddPrime p k g (a-1) + r' = case r of + [] -> error "DirichletCharacter: pred of smallest character" + (x:rs) -> subOne x: rs + -- | 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 :: KnownNat n => DirichletCharacter n -> Bool From 3ff5c40b13d2dd1e51ec1390f66ec5fed323e0f3 Mon Sep 17 00:00:00 2001 From: Bhavik Mehta Date: Mon, 31 Dec 2018 20:39:02 +0000 Subject: [PATCH 23/65] Bitshifts instead of powers and cosmetic changes --- Math/NumberTheory/DirichletCharacters.hs | 51 +++++++++++-------- .../NumberTheory/DirichletCharactersTests.hs | 11 ++-- 2 files changed, 34 insertions(+), 28 deletions(-) diff --git a/Math/NumberTheory/DirichletCharacters.hs b/Math/NumberTheory/DirichletCharacters.hs index 3d3248bae..0d26ac78e 100644 --- a/Math/NumberTheory/DirichletCharacters.hs +++ b/Math/NumberTheory/DirichletCharacters.hs @@ -42,26 +42,26 @@ module Math.NumberTheory.DirichletCharacters , toRealFunction ) where -import Data.Semigroup -import GHC.TypeNats.Compat -import Numeric.Natural (Natural) -import Data.Bits (testBit, (.&.), bit) -import Data.Ratio (Rational, (%), numerator, denominator) +import Data.Bits (Bits(..)) import Data.Complex (Complex, cis) -import Data.Proxy (Proxy(..)) import Data.List (mapAccumL) +import Data.Proxy (Proxy(..)) +import Data.Ratio (Rational, (%), numerator, denominator) +import Data.Semigroup (Semigroup(..)) +import GHC.TypeNats.Compat (Nat, natVal) +import Numeric.Natural (Natural) import Math.NumberTheory.ArithmeticFunctions (totient) -import Math.NumberTheory.Moduli.Class (KnownNat, MultMod, getVal, multElement, Mod, isMultElement) +import Math.NumberTheory.Moduli.Class (KnownNat, MultMod(..), getVal, Mod, isMultElement) import Math.NumberTheory.Moduli.Jacobi (jacobi, JacobiSymbol(..)) import Math.NumberTheory.Moduli.DiscreteLogarithm (discreteLogarithmPP) import Math.NumberTheory.UniqueFactorisation (UniqueFactorisation, unPrime, Prime, factorise) import Math.NumberTheory.Powers (powMod) import Math.NumberTheory.Utils.FromIntegral (wordToInt) -import Math.NumberTheory.Moduli.PrimitiveRoot +import Math.NumberTheory.Moduli.PrimitiveRoot (isPrimitiveRoot', CyclicGroup(..)) -data DirichletCharacter (n :: Nat) = Generated [DirichletFactor] +newtype DirichletCharacter (n :: Nat) = Generated [DirichletFactor] deriving (Show) data DirichletFactor = OddPrime { _getPrime :: Prime Natural @@ -137,7 +137,9 @@ generator p k -- | Implement the function \(\lambda\) from page 5 of -- https://www2.eecs.berkeley.edu/Pubs/TechRpts/1984/CSD-84-186.pdf lambda :: Integer -> Word -> Integer -lambda x e = ((powMod x (2^(e-1)) (2^(2*e-1)) - 1) `div` (2^(e+1))) `mod` (2^(e-2)) +lambda x e = ((powMod x (2*modulus) largeMod - 1) `shiftR` wordToInt (e+1)) .&. (modulus - 1) + where modulus = bit (wordToInt $ e-2) + largeMod = bit (wordToInt $ 2*e - 1) generalEval :: KnownNat n => DirichletCharacter n -> Mod n -> Maybe RootOfUnity generalEval chi = fmap (evaluate chi) . isMultElement @@ -153,8 +155,9 @@ evalFactor :: Integer -> DirichletFactor -> RootOfUnity evalFactor m = \case OddPrime (toInteger . unPrime -> p) k (toInteger -> a) b -> - toRootOfUnity (toInteger (b * discreteLogarithmPP p k a (m `rem` p^k)) % (p^(k-1)*(p-1))) - TwoPower k s b -> toRootOfUnity (toInteger s * (if testBit m 1 then 1 else 0) % 2) <> toRootOfUnity (toInteger b * lambda m'' k % (2^(k-2))) + toRootOfUnity $ toInteger (b * discreteLogarithmPP p k a (m `rem` p^k)) % (p^(k-1)*(p-1)) + TwoPower k s b -> toRootOfUnity (toInteger s * (if testBit m 1 then 1 else 0) % 2) + <> toRootOfUnity (toInteger b * lambda m'' k % bit (wordToInt $ k-2)) where m' = m .&. kBits m'' = if testBit m 1 then bit (wordToInt k) - m' @@ -169,9 +172,11 @@ 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 (OddPrime p k g n) (OddPrime _ _ _ m) = OddPrime p k g ((n + m) `mod` (p'^(k-1)*(p'-1))) + combine (OddPrime p k g n) (OddPrime _ _ _ m) = + OddPrime p k g ((n + m) `mod` (p'^(k-1)*(p'-1))) where p' = unPrime p - combine (TwoPower k a n) (TwoPower _ b m) = TwoPower k ((a + b) `mod` 2) ((n + m) `mod` 2^(k-2)) + combine (TwoPower k a n) (TwoPower _ b m) = + TwoPower k ((a + b) `mod` 2) ((n + m) .&. (bit (wordToInt k - 2) - 1)) combine _ _ = error "internal error: malformed DirichletCharacter" instance Semigroup (DirichletCharacter n) where @@ -193,13 +198,14 @@ instance KnownNat n => Bounded (DirichletCharacter n) where maxBound = indexToChar (totient n - 1) where n = natVal (Proxy :: Proxy n) -characterNumber :: Integral a => DirichletCharacter n -> a +characterNumber :: (Integral a, Bits a) => DirichletCharacter n -> a characterNumber (Generated y) = foldr go 0 y where go = \case - OddPrime p k _ a -> \x -> x * (p'^(k-1)*(p'-1)) + (fromIntegral a) + OddPrime p k _ a -> + \x -> x * (p'^(k-1)*(p'-1)) + fromIntegral a where p' = fromIntegral (unPrime p) - TwoPower k a b -> \x -> (x * (2^(k-2)) + fromIntegral b) * 2 + (fromIntegral a) - -- TODO: again use bitshifts to optimise + TwoPower k a b -> + \x -> (x `shiftL` wordToInt (k-2) + fromIntegral b) * 2 + fromIntegral a indexToChar :: forall a n. (KnownNat n, Integral a) => a -> DirichletCharacter n indexToChar m @@ -287,10 +293,12 @@ induced (Generated start) = if n `rem` d == 0 combine t [] = plain t combine ((p1,k1):xs) (y:ys) | unPrime p1 == 2, TwoPower k2 a b <- y = TwoPower k1 a (b*2^(k1-k2)): combine xs ys - | OddPrime p2 1 _g a <- y, p1 == p2 = OddPrime p2 k1 (generator p2 k1) (a*unPrime p1^(k1-1)): combine xs ys - -- generator p2 k1 will be g or g + p2, and we already know g is a primroot mod p + | OddPrime p2 1 _g a <- y, p1 == p2 = + OddPrime p2 k1 (generator p2 k1) (a*unPrime p1^(k1-1)): combine xs ys + -- TODO: generator p2 k1 will be g or g + p2, and we already know g is a primroot mod p -- so should be able to save work instead of running generator - | OddPrime p2 k2 g a <- y, p1 == p2 = OddPrime p2 k1 g (a*unPrime p1^(k1-k2)): combine xs ys + | OddPrime p2 k2 g a <- y, p1 == p2 = + OddPrime p2 k1 g (a*unPrime p1^(k1-k2)): combine xs ys | unPrime p1 == 2, k1 >= 2 = TwoPower k1 0 0: combine xs (y:ys) | unPrime p1 == 2 = combine xs (y:ys) | otherwise = OddPrime p1 k1 (generator p1 k1) 0: combine xs (y:ys) @@ -310,7 +318,6 @@ jacobiCharacter = if odd n then Just (RealChar (Generated (func <$> factorise n))) else Nothing where n = natVal (Proxy :: Proxy n) - func :: (Prime Natural, Word) -> DirichletFactor func (p,k) = OddPrime p k g val -- we know p is odd since n is odd and p | n where p' = unPrime p g = generator p k diff --git a/test-suite/Math/NumberTheory/DirichletCharactersTests.hs b/test-suite/Math/NumberTheory/DirichletCharactersTests.hs index a8efc214a..deb4ffb59 100644 --- a/test-suite/Math/NumberTheory/DirichletCharactersTests.hs +++ b/test-suite/Math/NumberTheory/DirichletCharactersTests.hs @@ -35,10 +35,9 @@ rootOfUnityTest :: Integer -> Positive Integer -> Bool rootOfUnityTest n (Positive d) = toComplex ((d `div` gcd n d) `stimes` toRootOfUnity (n % d)) == (1 :: Complex Double) -- | This tests property 6 from https://en.wikipedia.org/wiki/Dirichlet_character#Axiomatic_definition -dirCharOrder :: Positive Natural -> Natural -> Bool -dirCharOrder (Positive n) i = case someNatVal n of - SomeNat (Proxy :: Proxy n) -> (totient n) `stimes` chi == principalChar - where chi = fromIndex (i `mod` (totient n)) :: DirichletCharacter n +dirCharOrder :: forall n. KnownNat n => DirichletCharacter n -> Bool +dirCharOrder chi = isPrincipal (totient n `stimes` chi) + where n = natVal (Proxy :: Proxy n) -- | Tests wikipedia's property 3 (note 1,2,5 are essentially enforced by the type system). testMultiplicative :: KnownNat n => DirichletCharacter n -> Natural -> Natural -> Bool @@ -56,7 +55,7 @@ testAtOne chi = evaluate 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 = fromIndex (i `mod` (totient n)) :: DirichletCharacter n + where chi = indexToChar (i `mod` totient n) :: DirichletCharacter n -- | There should be phi(n) characters countCharacters :: Positive Natural -> Bool @@ -108,7 +107,7 @@ inducedCheck chi (Positive k) = testSuite :: TestTree testSuite = testGroup "DirichletCharacters" [ testSmallAndQuick "RootOfUnity contains roots of unity" rootOfUnityTest - , testSmallAndQuick "Dirichlet characters divide the right order" dirCharOrder + , 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 From a37c42e08f29851498551e79906f1c7d0d3c4b46 Mon Sep 17 00:00:00 2001 From: Bhavik Mehta Date: Wed, 2 Jan 2019 01:23:28 +0000 Subject: [PATCH 24/65] More internal documentation and haddocks --- Math/NumberTheory/DirichletCharacters.hs | 72 ++++++++++++++++++------ 1 file changed, 55 insertions(+), 17 deletions(-) diff --git a/Math/NumberTheory/DirichletCharacters.hs b/Math/NumberTheory/DirichletCharacters.hs index 0d26ac78e..c2ab738c8 100644 --- a/Math/NumberTheory/DirichletCharacters.hs +++ b/Math/NumberTheory/DirichletCharacters.hs @@ -13,7 +13,7 @@ {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE KindSignatures #-} module Math.NumberTheory.DirichletCharacters ( @@ -40,6 +40,8 @@ module Math.NumberTheory.DirichletCharacters , isRealCharacter , getRealChar , toRealFunction + -- * Debugging + , validChar ) where import Data.Bits (Bits(..)) @@ -61,19 +63,39 @@ import Math.NumberTheory.Utils.FromIntegral (wordToInt) import Math.NumberTheory.Moduli.PrimitiveRoot (isPrimitiveRoot', CyclicGroup(..)) +-- | 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 `evaluate`. +-- 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 `generalEval`. +-- +-- 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] - deriving (Show) +-- | 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 :: Natural } - | TwoPower { _getPower :: Word - , _getFirstValue :: Natural - , _getSecondValue :: Natural - } - deriving (Show) + | TwoPower { _getPower :: Word + , _getFirstValue :: Natural + , _getSecondValue :: Natural + } instance Eq (DirichletCharacter n) where Generated a == Generated b = a == b @@ -125,7 +147,7 @@ instance Monoid RootOfUnity where toComplex :: Floating a => RootOfUnity -> Complex a toComplex = cis . (2*pi*) . fromRational . fromRootOfUnity --- | For primes, the canonical primitive root is the smallest such. For prime powers \(p^k\), +-- | For primes, define the canonical primitive root as the smallest such. For prime powers \(p^k\), -- either the smallest primitive root \(g\) mod \(p\) works, or \(g+p\) works. generator :: (Integral a, UniqueFactorisation a) => Prime a -> Word -> a generator p k @@ -141,16 +163,13 @@ lambda x e = ((powMod x (2*modulus) largeMod - 1) `shiftR` wordToInt (e+1)) .&. where modulus = bit (wordToInt $ e-2) largeMod = bit (wordToInt $ 2*e - 1) -generalEval :: KnownNat n => DirichletCharacter n -> Mod n -> Maybe RootOfUnity -generalEval chi = fmap (evaluate chi) . isMultElement - -toFunction :: (Integral a, RealFloat b, KnownNat n) => DirichletCharacter n -> a -> Complex b -toFunction chi = maybe 0 toComplex . generalEval chi . fromIntegral - +-- | For elements of the multiplicative group \((\mathbb{Z}/n\mathbb{Z})^*\), a Dirichlet +-- character evaluates to a root of unity. evaluate :: DirichletCharacter n -> MultMod n -> RootOfUnity evaluate (Generated ds) m = foldMap (evalFactor m') ds where m' = getVal $ multElement m +-- | Evaluate each factor of the Dirichlet character. evalFactor :: Integer -> DirichletFactor -> RootOfUnity evalFactor m = \case @@ -164,8 +183,17 @@ evalFactor m = else m' kBits = bit (wordToInt k) - 1 --- | Give the principal character for this modulus: a principal character mod n is 1 for a coprime --- to n, and 0 otherwise. +-- | A character can evaluate to a root of unity or zero: represented by @Nothing@. +generalEval :: KnownNat n => DirichletCharacter n -> Mod n -> Maybe RootOfUnity +generalEval chi = fmap (evaluate chi) . isMultElement + +-- | Convert a Dirichlet character to a complex-valued function. As in `toComplex`, the result is +-- inexact due to floating-point inaccuracies. See `toComplex` for more. +toFunction :: (Integral a, RealFloat b, KnownNat n) => DirichletCharacter n -> a -> Complex b +toFunction chi = maybe 0 toComplex . generalEval chi . fromIntegral + +-- | 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 @@ -179,6 +207,7 @@ mulChars (Generated x) (Generated y) = Generated (zipWith combine x y) TwoPower k ((a + b) `mod` 2) ((n + m) .&. (bit (wordToInt k - 2) - 1)) combine _ _ = error "internal error: malformed DirichletCharacter" +-- TODO: this semigroup is also a group, allow `stimes` to work for non-positives too instance Semigroup (DirichletCharacter n) where (<>) = mulChars @@ -186,7 +215,7 @@ instance KnownNat n => Monoid (DirichletCharacter n) where mempty = principalChar -- | We define `succ` and `pred` with more efficient implementations than --- `toEnum . (+1) . fromEnum`. +-- @`toEnum` . (+1) . `fromEnum`@. instance KnownNat n => Enum (DirichletCharacter n) where toEnum = indexToChar fromEnum = characterNumber @@ -198,6 +227,8 @@ instance KnownNat n => Bounded (DirichletCharacter n) where maxBound = indexToChar (totient n - 1) where n = natVal (Proxy :: Proxy n) +-- | We have a (non-canonical) enumeration of dirichlet characters, with inverse given by +-- `indexToChar`. characterNumber :: (Integral a, Bits a) => DirichletCharacter n -> a characterNumber (Generated y) = foldr go 0 y where go = \case @@ -207,6 +238,8 @@ characterNumber (Generated y) = foldr go 0 y TwoPower k a b -> \x -> (x `shiftL` wordToInt (k-2) + fromIntegral b) * 2 + fromIntegral a +-- | Give the dirichlet character from its number. The index must be between 0 and \(\phi(n)\). +-- Inverse of `characterNumber`. indexToChar :: forall a n. (KnownNat n, Integral a) => a -> DirichletCharacter n indexToChar m | m < 0 = error "Enum DirichletCharacter: negative input" @@ -348,3 +381,8 @@ toRealFunction (RealChar chi) m = case generalEval chi (fromIntegral m) of Just t | t == mempty -> 1 Just t | t == RootOfUnity (1 % 2) -> -1 _ -> error "internal error in toRealFunction: please report this as a bug" + +-- TODO: write this function +-- | Test if the internal DirichletCharacter structure is valid. +validChar :: forall n. KnownNat n => DirichletCharacter n -> Bool +validChar = error "todo: validChar" From cca57285e0c2ce34c9171ec9a6e9b2038bb3f873 Mon Sep 17 00:00:00 2001 From: Bhavik Mehta Date: Fri, 4 Jan 2019 10:56:26 +0000 Subject: [PATCH 25/65] valid character checker --- Math/NumberTheory/DirichletCharacters.hs | 18 ++++++++++++++++-- 1 file changed, 16 insertions(+), 2 deletions(-) diff --git a/Math/NumberTheory/DirichletCharacters.hs b/Math/NumberTheory/DirichletCharacters.hs index c2ab738c8..4b8483211 100644 --- a/Math/NumberTheory/DirichletCharacters.hs +++ b/Math/NumberTheory/DirichletCharacters.hs @@ -59,6 +59,7 @@ import Math.NumberTheory.Moduli.Jacobi (jacobi, JacobiSymbol(..)) import Math.NumberTheory.Moduli.DiscreteLogarithm (discreteLogarithmPP) import Math.NumberTheory.UniqueFactorisation (UniqueFactorisation, unPrime, Prime, factorise) import Math.NumberTheory.Powers (powMod) +import Math.NumberTheory.Primes (primes) import Math.NumberTheory.Utils.FromIntegral (wordToInt) import Math.NumberTheory.Moduli.PrimitiveRoot (isPrimitiveRoot', CyclicGroup(..)) @@ -358,6 +359,9 @@ jacobiCharacter = if odd n One -> 0 MinusOne -> p'^(k-1)*((p'-1) `div` 2) -- p is odd so this is fine Zero -> error "internal error in jacobiCharacter: please report this as a bug" + -- We should not reach this branch, since g should be a prim root mod p, + -- in particular it absolutely should not divide p, so the jacobi symbol + -- should not be 0, and any power of it should not be 0. -- | A Dirichlet character is real if it is real-valued. newtype RealCharacter n = RealChar { -- | Extract the character itself from a `RealCharacter`. @@ -381,8 +385,18 @@ toRealFunction (RealChar chi) m = case generalEval chi (fromIntegral m) of Just t | t == mempty -> 1 Just 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 --- TODO: write this function -- | Test if the internal DirichletCharacter structure is valid. validChar :: forall n. KnownNat n => DirichletCharacter n -> Bool -validChar = error "todo: validChar" +validChar (Generated xs) = correctDecomposition && all correctPrimitiveRoot xs + where correctDecomposition = removeTwo (factorise n) == map getPP xs + getPP (TwoPower k _ _) = (two, k) + getPP (OddPrime p k _ _) = (p, k) + removeTwo ((unPrime -> 2,1):ys) = ys + removeTwo ys = ys + correctPrimitiveRoot TwoPower{} = True + correctPrimitiveRoot (OddPrime p k g _) = g == generator p k + n = natVal (Proxy :: Proxy n) + two = head primes -- lazy way to get Prime 2 From 5a8506247e49f65a09f400dd04ac184332264317 Mon Sep 17 00:00:00 2001 From: Bhavik Mehta Date: Fri, 4 Jan 2019 19:10:54 +0000 Subject: [PATCH 26/65] Avoid lots of recalculations for Enum instances --- Math/NumberTheory/DirichletCharacters.hs | 146 ++++++++++++----------- 1 file changed, 78 insertions(+), 68 deletions(-) diff --git a/Math/NumberTheory/DirichletCharacters.hs b/Math/NumberTheory/DirichletCharacters.hs index 4b8483211..2344e29c4 100644 --- a/Math/NumberTheory/DirichletCharacters.hs +++ b/Math/NumberTheory/DirichletCharacters.hs @@ -29,6 +29,7 @@ module Math.NumberTheory.DirichletCharacters , generalEval , toFunction , indexToChar + , indicesToChars , characterNumber -- ** Special Dirichlet characters , principalChar @@ -46,7 +47,8 @@ module Math.NumberTheory.DirichletCharacters import Data.Bits (Bits(..)) import Data.Complex (Complex, cis) -import Data.List (mapAccumL) +import Data.Functor.Identity (Identity(..)) +import Data.List (mapAccumL, foldl') import Data.Proxy (Proxy(..)) import Data.Ratio (Rational, (%), numerator, denominator) import Data.Semigroup (Semigroup(..)) @@ -220,8 +222,13 @@ instance KnownNat n => Monoid (DirichletCharacter n) where instance KnownNat n => Enum (DirichletCharacter n) where toEnum = indexToChar fromEnum = characterNumber - succ = nextChar - pred = prevChar + succ x = makeChar x (characterNumber x + 1 :: Integer) + pred x = makeChar x (characterNumber x - 1 :: Integer) + + 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 :: Int) @@ -231,74 +238,75 @@ instance KnownNat n => Bounded (DirichletCharacter n) where -- | We have a (non-canonical) enumeration of dirichlet characters, with inverse given by -- `indexToChar`. characterNumber :: (Integral a, Bits a) => DirichletCharacter n -> a -characterNumber (Generated y) = foldr go 0 y - where go = \case - OddPrime p k _ a -> - \x -> x * (p'^(k-1)*(p'-1)) + fromIntegral a - where p' = fromIntegral (unPrime p) - TwoPower k a b -> - \x -> (x `shiftL` wordToInt (k-2) + fromIntegral b) * 2 + fromIntegral a - --- | Give the dirichlet character from its number. The index must be between 0 and \(\phi(n)\). +characterNumber (Generated y) = foldl' go 0 y + where go x (OddPrime p k _ a) = x * (p'^(k-1)*(p'-1)) + fromIntegral a + where p' = fromIntegral (unPrime p) + go x (TwoPower k a b) = (x `shiftL` wordToInt (k-2) + fromIntegral b) * 2 + fromIntegral a + +-- | Give the dirichlet character from its number. -- Inverse of `characterNumber`. -indexToChar :: forall a n. (KnownNat n, Integral a) => a -> DirichletCharacter n -indexToChar m - | m < 0 = error "Enum DirichletCharacter: negative input" - | m >= maxi = error "Enum DirichletCharacter: input too large" - | otherwise = Generated (go (factorise n)) +indexToChar :: forall n a. (KnownNat n, Integral a) => a -> 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, such as +-- factorising the modulus. +indicesToChars :: forall n a f. (KnownNat n, Integral a, Functor f) => f a -> f (DirichletCharacter n) +indicesToChars = fmap (Generated . unroll t . (`mod` totient n) . fromIntegral) where n = natVal (Proxy :: Proxy n) - maxi = fromIntegral $ totient n - m' = fromIntegral m - go :: [(Prime Natural, Word)] -> [DirichletFactor] - go [] = [] - go f@((p,k):xs) = case (unPrime p, k) of - (2,1) -> odds m' xs - (2,_) -> TwoPower k a2 b2: odds b1 xs - where (a1,a2) = quotRem (fromIntegral m) 2 - (b1,b2) = quotRem a1 (2^(k-2)) - _ -> odds m' f - odds :: Natural -> [(Prime Natural, Word)] -> [DirichletFactor] - odds t = snd . mapAccumL func t - where func a (p,k) = (q, OddPrime p k (generator p k) r) - where (q,r) = quotRem a (p'^(k-1)*(p'-1)) - p' = unPrime p - -nextChar :: DirichletCharacter n -> DirichletCharacter n -nextChar (Generated t) = Generated (map rollOver l ++ r') - where saturated :: DirichletFactor -> Bool - saturated (TwoPower k a b) = a == 1 && b + 1 == bit (wordToInt $ k-2) - saturated (OddPrime p k _ a) = a + 1 == p'^(k-1)*(p'-1) + t = mkTemplate n + +makeChar :: forall n a. (KnownNat n, 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 :: forall n a f. (KnownNat n, Integral a, Functor f) => DirichletCharacter n -> f a -> f (DirichletCharacter n) +bulkMakeChars x = fmap (Generated . unroll t . (`mod` totient n) . fromIntegral) + where t = templateFromCharacter x + n = natVal (Proxy :: Proxy n) + +-- 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 + } + | TwoTemplate { _getPower' :: Word + , _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 + +templateFromCharacter :: DirichletCharacter n -> [Template] +templateFromCharacter (Generated t) = map go t + where go (OddPrime p k g _) = OddTemplate p k g (p'^(k-1)*(p'-1)) where p' = unPrime p - (l,r) = span saturated t - rollOver :: DirichletFactor -> DirichletFactor - rollOver (TwoPower k _ _) = TwoPower k 0 0 - rollOver (OddPrime p k g _) = OddPrime p k g 0 - addOne :: DirichletFactor -> DirichletFactor - addOne (TwoPower k 0 b) = TwoPower k 1 b - addOne (TwoPower k _ b) = TwoPower k 0 (b+1) - addOne (OddPrime p k g a) = OddPrime p k g (a+1) - r' = case r of - [] -> error "DirichletCharacter: succ of largest character" - (x:rs) -> addOne x: rs - -prevChar :: DirichletCharacter n -> DirichletCharacter n -prevChar (Generated t) = Generated (map rollBack l ++ r') - where empty :: DirichletFactor -> Bool - empty (TwoPower _ 0 0) = True - empty (OddPrime _ _ _ 0) = True - empty _ = False - (l,r) = span empty t - rollBack :: DirichletFactor -> DirichletFactor - rollBack (TwoPower k _ _) = TwoPower k 1 (bit (wordToInt $ k-2) - 1) - rollBack (OddPrime p k g _) = OddPrime p k g (p'^(k-1)*(p'-1) - 1) + go (TwoPower k _ _) = TwoTemplate k (bit (wordToInt $ k-2)) + +-- TODO: Template is effectively a CyclicFactor of a generalised CyclicGroup... +-- see issue #154 + +mkTemplate :: Natural -> [Template] +mkTemplate = go . factorise + where go :: [(Prime Natural, Word)] -> [Template] + go ((unPrime -> 2, 1):xs) = map odds xs + go ((unPrime -> 2, k):xs) = TwoTemplate k (bit (wordToInt $ k-2)): map odds xs + go xs = map odds xs + odds :: (Prime Natural, Word) -> Template + odds (p, k) = OddTemplate p k (generator p k) (p'^(k-1)*(p'-1)) where p' = unPrime p - subOne :: DirichletFactor -> DirichletFactor - subOne (TwoPower k 1 b) = TwoPower k 0 b - subOne (TwoPower k _ b) = TwoPower k 1 (b-1) - subOne (OddPrime p k g a) = OddPrime p k g (a-1) - r' = case r of - [] -> error "DirichletCharacter: pred of smallest character" - (x:rs) -> subOne x: rs + +-- the validity of the producted dirichletfactor list 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) = OddPrime p k g <$> quotRem a n + func a (TwoTemplate k n) = TwoPower k a2 <$> quotRem a1 n + where (a1,a2) = quotRem a 2 -- | 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. @@ -356,8 +364,10 @@ jacobiCharacter = if odd n where p' = unPrime p g = generator p k val = case k `stimes` jacobi g p' of + -- TODO: is there a nice formula for the jacobi symbol of primitive roots? + -- if so, is there also a nice way of getting the character number? One -> 0 - MinusOne -> p'^(k-1)*((p'-1) `div` 2) -- p is odd so this is fine + MinusOne -> p'^(k-1)*((p'-1) `div` 2) Zero -> error "internal error in jacobiCharacter: please report this as a bug" -- We should not reach this branch, since g should be a prim root mod p, -- in particular it absolutely should not divide p, so the jacobi symbol From 3e4deb0dc7247f91cdec01b98a07a79977f35e6b Mon Sep 17 00:00:00 2001 From: Bhavik Mehta Date: Sun, 6 Jan 2019 01:58:18 +0000 Subject: [PATCH 27/65] Better jacobi (+tests), avoided some recalcuations --- Math/NumberTheory/DirichletCharacters.hs | 71 +++++++++---------- .../NumberTheory/DirichletCharactersTests.hs | 60 ++++++++++------ 2 files changed, 71 insertions(+), 60 deletions(-) diff --git a/Math/NumberTheory/DirichletCharacters.hs b/Math/NumberTheory/DirichletCharacters.hs index 2344e29c4..58f063334 100644 --- a/Math/NumberTheory/DirichletCharacters.hs +++ b/Math/NumberTheory/DirichletCharacters.hs @@ -34,13 +34,13 @@ module Math.NumberTheory.DirichletCharacters -- ** Special Dirichlet characters , principalChar , isPrincipal - , jacobiCharacter , induced -- ** Real Dirichlet characters , RealCharacter , isRealCharacter , getRealChar , toRealFunction + , jacobiCharacter -- * Debugging , validChar ) where @@ -51,13 +51,12 @@ import Data.Functor.Identity (Identity(..)) import Data.List (mapAccumL, foldl') import Data.Proxy (Proxy(..)) import Data.Ratio (Rational, (%), numerator, denominator) -import Data.Semigroup (Semigroup(..)) +import Data.Semigroup (Semigroup(..), Product(..)) import GHC.TypeNats.Compat (Nat, natVal) import Numeric.Natural (Natural) import Math.NumberTheory.ArithmeticFunctions (totient) import Math.NumberTheory.Moduli.Class (KnownNat, MultMod(..), getVal, Mod, isMultElement) -import Math.NumberTheory.Moduli.Jacobi (jacobi, JacobiSymbol(..)) import Math.NumberTheory.Moduli.DiscreteLogarithm (discreteLogarithmPP) import Math.NumberTheory.UniqueFactorisation (UniqueFactorisation, unPrime, Prime, factorise) import Math.NumberTheory.Powers (powMod) @@ -252,19 +251,18 @@ indexToChar = runIdentity . indicesToChars . Identity -- `indexToChar` for multiple characters, as it prevents some internal recalculations, such as -- factorising the modulus. indicesToChars :: forall n a f. (KnownNat n, Integral a, Functor f) => f a -> f (DirichletCharacter n) -indicesToChars = fmap (Generated . unroll t . (`mod` totient n) . fromIntegral) +indicesToChars = fmap (Generated . unroll t . (`mod` m) . fromIntegral) where n = natVal (Proxy :: Proxy n) - t = mkTemplate n + (Product m, t) = mkTemplate n -makeChar :: forall n a. (KnownNat n, Integral a) => DirichletCharacter n -> a -> DirichletCharacter n +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 :: forall n a f. (KnownNat n, Integral a, Functor f) => DirichletCharacter n -> f a -> f (DirichletCharacter n) -bulkMakeChars x = fmap (Generated . unroll t . (`mod` totient n) . fromIntegral) - where t = templateFromCharacter x - n = natVal (Proxy :: Proxy n) +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 @@ -281,26 +279,30 @@ data Template = OddTemplate { _getPrime' :: Prime Natural -- morally getModulus should be a prefactored but seems to be -- pointless here -templateFromCharacter :: DirichletCharacter n -> [Template] -templateFromCharacter (Generated t) = map go t - where go (OddPrime p k g _) = OddTemplate p k g (p'^(k-1)*(p'-1)) +templateFromCharacter :: DirichletCharacter n -> (Product Natural, [Template]) +templateFromCharacter (Generated t) = mapM go t + where go (OddPrime p k g _) = (Product m, OddTemplate p k g m) where p' = unPrime p - go (TwoPower k _ _) = TwoTemplate k (bit (wordToInt $ k-2)) + m = p'^(k-1)*(p'-1) + go (TwoPower k _ _) = (Product (2*m), TwoTemplate k m) + where m = bit $ wordToInt $ k-2 --- TODO: Template is effectively a CyclicFactor of a generalised CyclicGroup... +-- TODO (idea): Template is effectively a CyclicFactor of a generalised CyclicGroup... -- see issue #154 -mkTemplate :: Natural -> [Template] +mkTemplate :: Natural -> (Product Natural, [Template]) mkTemplate = go . factorise - where go :: [(Prime Natural, Word)] -> [Template] - go ((unPrime -> 2, 1):xs) = map odds xs - go ((unPrime -> 2, k):xs) = TwoTemplate k (bit (wordToInt $ k-2)): map odds xs - go xs = map odds xs - odds :: (Prime Natural, Word) -> Template - odds (p, k) = OddTemplate p k (generator p k) (p'^(k-1)*(p'-1)) + where go :: [(Prime Natural, Word)] -> (Product Natural, [Template]) + go ((unPrime -> 2, 1):xs) = foldMap odds xs + go ((unPrime -> 2, k):xs) = (Product (2*m), [TwoTemplate k m]) <> foldMap odds xs + where m = bit $ wordToInt $ k-2 + go xs = foldMap 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 producted dirichletfactor list requires the template to be valid +-- the validity of the producted 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) @@ -310,8 +312,8 @@ unroll t m = snd (mapAccumL func m t) -- | 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 :: KnownNat n => DirichletCharacter n -> Bool -isPrincipal chi = chi == principalChar +isPrincipal :: DirichletCharacter n -> Bool +isPrincipal chi = characterNumber chi == (0 :: Int) -- | Induce a Dirichlet character to a higher modulus. If \(d \mid n\), then \(a \bmod{n}\) can be -- reduced to \(a \bmod{d}\). Thus, a multiplicative function on \(\mathbb{Z}/d\mathbb{Z}\) @@ -357,21 +359,14 @@ induced (Generated start) = if n `rem` d == 0 -- character for odd moduli. jacobiCharacter :: forall n. KnownNat n => Maybe (RealCharacter n) jacobiCharacter = if odd n - then Just (RealChar (Generated (func <$> factorise n))) + then Just $ RealChar $ Generated $ map go $ snd $ mkTemplate n else Nothing where n = natVal (Proxy :: Proxy n) - func (p,k) = OddPrime p k g val -- we know p is odd since n is odd and p | n - where p' = unPrime p - g = generator p k - val = case k `stimes` jacobi g p' of - -- TODO: is there a nice formula for the jacobi symbol of primitive roots? - -- if so, is there also a nice way of getting the character number? - One -> 0 - MinusOne -> p'^(k-1)*((p'-1) `div` 2) - Zero -> error "internal error in jacobiCharacter: please report this as a bug" - -- We should not reach this branch, since g should be a prim root mod p, - -- in particular it absolutely should not divide p, so the jacobi symbol - -- should not be 0, and any power of it should not be 0. + go :: Template -> DirichletFactor + go TwoTemplate{} = error "internal error in jacobiCharacter: please report this as a bug" + -- every factor of n should be odd + go (OddTemplate p k g m) = OddPrime p k g $ (m * fromIntegral k `div` 2) `mod` m + -- jacobi symbol of a primitive root mod p over p is always -1 -- | A Dirichlet character is real if it is real-valued. newtype RealCharacter n = RealChar { -- | Extract the character itself from a `RealCharacter`. diff --git a/test-suite/Math/NumberTheory/DirichletCharactersTests.hs b/test-suite/Math/NumberTheory/DirichletCharactersTests.hs index deb4ffb59..6f0565b06 100644 --- a/test-suite/Math/NumberTheory/DirichletCharactersTests.hs +++ b/test-suite/Math/NumberTheory/DirichletCharactersTests.hs @@ -11,6 +11,9 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE Rank2Types #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ViewPatterns #-} module Math.NumberTheory.DirichletCharactersTests where @@ -28,6 +31,7 @@ import GHC.TypeNats.Compat (SomeNat(..), someNatVal, KnownNat, natVal) import Math.NumberTheory.ArithmeticFunctions (totient) import Math.NumberTheory.DirichletCharacters +import Math.NumberTheory.Moduli.Jacobi import Math.NumberTheory.Moduli.Class (SomeMod(..), modulo) import Math.NumberTheory.TestUtils (testSmallAndQuick, Positive(..)) @@ -41,34 +45,35 @@ dirCharOrder chi = isPrincipal (totient n `stimes` chi) -- | 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 a b = chiAB == chiAchiB +testMultiplicative chi (fromIntegral -> a) (fromIntegral -> b) = chiAB == chiAchiB where chi' = generalEval chi - a' = fromIntegral a - b' = fromIntegral b - chiAB = chi' (a'*b') - chiAchiB = (<>) <$> chi' a' <*> chi' b' + chiAB = chi' (a*b) + chiAchiB = (<>) <$> chi' a <*> chi' b -- | Test property 4 from wikipedia testAtOne :: KnownNat n => DirichletCharacter n -> Bool testAtOne chi = evaluate 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 (i `mod` totient n) :: DirichletCharacter n +dirCharProperty test (Positive n) i = + case someNatVal n of + SomeNat (Proxy :: Proxy n) -> test chi + where chi = indexToChar (i `mod` totient n) :: DirichletCharacter n -- | There should be phi(n) characters countCharacters :: Positive Natural -> Bool -countCharacters (Positive n) = case someNatVal n of - SomeNat (Proxy :: Proxy n) -> - genericLength (nub [minBound :: DirichletCharacter n .. maxBound]) == totient n +countCharacters (Positive n) = + case someNatVal n of + SomeNat (Proxy :: Proxy n) -> + genericLength (nub [minBound :: DirichletCharacter n .. maxBound]) == totient n -- | The principal character should be 1 at all phi(n) places principalCase :: Positive Natural -> Bool -principalCase (Positive n) = case someNatVal n of - SomeNat (Proxy :: Proxy n) -> - mapMaybe (generalEval chi) [minBound..maxBound] == genericReplicate (totient n) mempty - where chi = principalChar :: DirichletCharacter n +principalCase (Positive n) = + case someNatVal n of + SomeNat (Proxy :: Proxy n) -> + mapMaybe (generalEval chi) [minBound..maxBound] == genericReplicate (totient n) mempty + where chi = principalChar :: DirichletCharacter n -- | Test the orthogonality relations https://en.wikipedia.org/wiki/Dirichlet_character#Character_orthogonality orthogonality1 :: forall n. KnownNat n => DirichletCharacter n -> Bool @@ -80,13 +85,14 @@ orthogonality1 chi = magnitude (total - correct) < (1e-13 :: Double) 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 [maybe 0 toComplex (generalEval chi a') | chi <- [minBound .. maxBound]] - correct = if a' == 1 - then fromIntegral $ totient n - else 0 - InfMod {} -> False +orthogonality2 (Positive n) a = + case a `modulo` n of + SomeMod a' -> magnitude (total - correct) < (1e-13 :: Double) + where total = sum [maybe 0 toComplex (generalEval chi a') | chi <- [minBound .. maxBound]] + correct = if a' == 1 + then fromIntegral $ totient n + else 0 + InfMod {} -> False -- | Manually confirm isRealCharacter is correct (in both directions) realityCheck :: forall n. KnownNat n => DirichletCharacter n -> Bool @@ -104,6 +110,15 @@ inducedCheck chi (Positive k) = where chi2 = induced chi :: Maybe (DirichletCharacter n) where d = natVal (Proxy :: Proxy d) +-- | 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) == symbolToIntegral (jacobi j (2*n+1)) | j <- [0..2*n]] + _ -> False + testSuite :: TestTree testSuite = testGroup "DirichletCharacters" [ testSmallAndQuick "RootOfUnity contains roots of unity" rootOfUnityTest @@ -115,5 +130,6 @@ testSuite = testGroup "DirichletCharacters" , testSmallAndQuick "Orthogonality relation 1" (dirCharProperty orthogonality1) , testSmallAndQuick "Orthogonality relation 2" orthogonality2 , testSmallAndQuick "Real character checking is valid" (dirCharProperty realityCheck) + , testSmallAndQuick "Jacobi character matches symbol" jacobiCheck , testSmallAndQuick "Induced character is correct" (dirCharProperty inducedCheck) ] From 08a8f9df9add02534b89bdccd9e8033b95782832 Mon Sep 17 00:00:00 2001 From: Bhavik Mehta Date: Sun, 6 Jan 2019 03:54:56 +0000 Subject: [PATCH 28/65] simpler representation of characters --- Math/NumberTheory/DirichletCharacters.hs | 76 ++++++++++--------- Math/NumberTheory/Moduli/Jacobi.hs | 11 +++ .../NumberTheory/DirichletCharactersTests.hs | 13 ++-- 3 files changed, 58 insertions(+), 42 deletions(-) diff --git a/Math/NumberTheory/DirichletCharacters.hs b/Math/NumberTheory/DirichletCharacters.hs index 58f063334..445391b6f 100644 --- a/Math/NumberTheory/DirichletCharacters.hs +++ b/Math/NumberTheory/DirichletCharacters.hs @@ -50,7 +50,7 @@ import Data.Complex (Complex, cis) import Data.Functor.Identity (Identity(..)) import Data.List (mapAccumL, foldl') import Data.Proxy (Proxy(..)) -import Data.Ratio (Rational, (%), numerator, denominator) +import Data.Ratio (Rational, Ratio, (%), numerator, denominator) import Data.Semigroup (Semigroup(..), Product(..)) import GHC.TypeNats.Compat (Nat, natVal) import Numeric.Natural (Natural) @@ -92,11 +92,11 @@ newtype DirichletCharacter (n :: Nat) = Generated [DirichletFactor] data DirichletFactor = OddPrime { _getPrime :: Prime Natural , _getPower :: Word , _getGenerator :: Natural - , _getValue :: Natural + , _getValue :: RootOfUnity } | TwoPower { _getPower :: Word - , _getFirstValue :: Natural - , _getSecondValue :: Natural + , _getFirstValue :: RootOfUnity + , _getSecondValue :: RootOfUnity } instance Eq (DirichletCharacter n) where @@ -125,10 +125,10 @@ instance Show RootOfUnity where d = denominator (2*q) -- | Given a rational \(q\), produce the root of unity \(e^{2 \pi i q}\). -toRootOfUnity :: Rational -> RootOfUnity +toRootOfUnity :: Integral a => Ratio a -> RootOfUnity toRootOfUnity q = RootOfUnity ((n `rem` d) % d) - where n = numerator q - d = denominator q + where n = toInteger $ numerator q + d = toInteger $ denominator q -- effectively q `mod` 1 -- This smart constructor ensures that the rational is always in the range 0 <= q < 1. @@ -176,9 +176,9 @@ evalFactor :: Integer -> DirichletFactor -> RootOfUnity evalFactor m = \case OddPrime (toInteger . unPrime -> p) k (toInteger -> a) b -> - toRootOfUnity $ toInteger (b * discreteLogarithmPP p k a (m `rem` p^k)) % (p^(k-1)*(p-1)) - TwoPower k s b -> toRootOfUnity (toInteger s * (if testBit m 1 then 1 else 0) % 2) - <> toRootOfUnity (toInteger b * lambda m'' k % bit (wordToInt $ k-2)) + discreteLogarithmPP p k a (m `rem` p^k) `stimes` b + TwoPower k s b -> (if testBit m 1 then s else mempty) + <> lambda m'' k `stimes` b where m' = m .&. kBits m'' = if testBit m 1 then bit (wordToInt k) - m' @@ -203,10 +203,9 @@ mulChars :: DirichletCharacter n -> DirichletCharacter n -> DirichletCharacter n mulChars (Generated x) (Generated y) = Generated (zipWith combine x y) where combine :: DirichletFactor -> DirichletFactor -> DirichletFactor combine (OddPrime p k g n) (OddPrime _ _ _ m) = - OddPrime p k g ((n + m) `mod` (p'^(k-1)*(p'-1))) - where p' = unPrime p + OddPrime p k g (n <> m) combine (TwoPower k a n) (TwoPower _ b m) = - TwoPower k ((a + b) `mod` 2) ((n + m) .&. (bit (wordToInt k - 2) - 1)) + TwoPower k (a <> b) (n <> m) combine _ _ = error "internal error: malformed DirichletCharacter" -- TODO: this semigroup is also a group, allow `stimes` to work for non-positives too @@ -215,14 +214,15 @@ instance Semigroup (DirichletCharacter n) where instance KnownNat n => Monoid (DirichletCharacter n) where mempty = principalChar + mappend = (<>) -- | We define `succ` and `pred` with more efficient implementations than -- @`toEnum` . (+1) . `fromEnum`@. instance KnownNat n => Enum (DirichletCharacter n) where toEnum = indexToChar - fromEnum = characterNumber - succ x = makeChar x (characterNumber x + 1 :: Integer) - pred x = makeChar x (characterNumber x - 1 :: Integer) + fromEnum = fromIntegral . 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..] @@ -234,13 +234,15 @@ instance KnownNat n => Bounded (DirichletCharacter n) where maxBound = indexToChar (totient n - 1) where n = natVal (Proxy :: Proxy n) --- | We have a (non-canonical) enumeration of dirichlet characters, with inverse given by --- `indexToChar`. -characterNumber :: (Integral a, Bits a) => DirichletCharacter n -> a +-- | 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 * (p'^(k-1)*(p'-1)) + fromIntegral a + where go x (OddPrime p k _ a) = x * m + numerator (fromRootOfUnity a * (m % 1)) where p' = fromIntegral (unPrime p) - go x (TwoPower k a b) = (x `shiftL` wordToInt (k-2) + fromIntegral b) * 2 + fromIntegral a + m = p'^(k-1)*(p'-1) + go x (TwoPower k a b) = x' * 2 + numerator (fromRootOfUnity a * (2 % 1)) + where m = bit $ wordToInt $ k-2 :: Integer + x' = x `shiftL` wordToInt (k-2) + numerator (fromRootOfUnity b * fromIntegral m) -- | Give the dirichlet character from its number. -- Inverse of `characterNumber`. @@ -306,14 +308,17 @@ mkTemplate = go . factorise 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) = OddPrime p k g <$> quotRem a n - func a (TwoTemplate k n) = TwoPower k a2 <$> quotRem a1 n + func a (OddTemplate p k g n) = (a1, OddPrime p k g (toRootOfUnity $ a2 % n)) + where (a1,a2) = quotRem a n + func a (TwoTemplate k n) = (b1, TwoPower k (toRootOfUnity $ a2 % 2) (toRootOfUnity $ b2 % n)) where (a1,a2) = quotRem a 2 + (b1,b2) = quotRem a1 n + -- TODO: consider tidying -- | 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 :: Int) +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, a multiplicative function on \(\mathbb{Z}/d\mathbb{Z}\) @@ -336,24 +341,25 @@ induced (Generated start) = if n `rem` d == 0 combine [] _ = [] combine t [] = plain t combine ((p1,k1):xs) (y:ys) - | unPrime p1 == 2, TwoPower k2 a b <- y = TwoPower k1 a (b*2^(k1-k2)): combine xs ys + -- TODO: consider tidying + | unPrime p1 == 2, TwoPower _ a b <- y = TwoPower k1 a b: combine xs ys | OddPrime p2 1 _g a <- y, p1 == p2 = - OddPrime p2 k1 (generator p2 k1) (a*unPrime p1^(k1-1)): combine xs ys + OddPrime p2 k1 (generator p2 k1) a: combine xs ys -- TODO: generator p2 k1 will be g or g + p2, and we already know g is a primroot mod p -- so should be able to save work instead of running generator - | OddPrime p2 k2 g a <- y, p1 == p2 = - OddPrime p2 k1 g (a*unPrime p1^(k1-k2)): combine xs ys - | unPrime p1 == 2, k1 >= 2 = TwoPower k1 0 0: combine xs (y:ys) + | OddPrime p2 _ g a <- y, p1 == p2 = + OddPrime p2 k1 g a: combine xs ys + | unPrime p1 == 2, k1 >= 2 = TwoPower k1 mempty mempty: combine xs (y:ys) | unPrime p1 == 2 = combine xs (y:ys) - | otherwise = OddPrime p1 k1 (generator p1 k1) 0: combine xs (y:ys) + | otherwise = OddPrime p1 k1 (generator p1 k1) mempty: combine xs (y:ys) plain :: [(Prime Natural, Word)] -> [DirichletFactor] plain [] = [] plain f@((p,k):xs) = case (unPrime p, k) of (2,1) -> map rest xs - (2,_) -> TwoPower k 0 0: map rest xs + (2,_) -> TwoPower k mempty mempty: map rest xs _ -> map rest f rest :: (Prime Natural, Word) -> DirichletFactor - rest (p,k) = OddPrime p k (generator p k) 0 + rest (p,k) = OddPrime p k (generator p k) mempty -- | The gives a real Dirichlet -- character for odd moduli. @@ -365,7 +371,7 @@ jacobiCharacter = if odd n go :: Template -> DirichletFactor go TwoTemplate{} = error "internal error in jacobiCharacter: please report this as a bug" -- every factor of n should be odd - go (OddTemplate p k g m) = OddPrime p k g $ (m * fromIntegral k `div` 2) `mod` m + go (OddTemplate p k g _) = OddPrime p k g $ toRootOfUnity (k % 2) -- jacobi symbol of a primitive root mod p over p is always -1 -- | A Dirichlet character is real if it is real-valued. @@ -377,8 +383,8 @@ newtype RealCharacter n = RealChar { -- | Extract the character itself from a `R 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 (unPrime -> p) k _ a) = a == 0 || a*2 == p^(k-1)*(p-1) - real (TwoPower k _ b) = b == 0 || b == 2^(k-3) + real (OddPrime _ _ _ a) = a <> a == mempty + real (TwoPower _ _ b) = b <> b == mempty -- TODO: it should be possible to calculate this without evaluate/generalEval -- and thus avoid using discrete log calculations: consider the order of m diff --git a/Math/NumberTheory/Moduli/Jacobi.hs b/Math/NumberTheory/Moduli/Jacobi.hs index e9f9d64fc..76900beeb 100644 --- a/Math/NumberTheory/Moduli/Jacobi.hs +++ b/Math/NumberTheory/Moduli/Jacobi.hs @@ -18,6 +18,7 @@ module Math.NumberTheory.Moduli.Jacobi ( JacobiSymbol(..) , jacobi + , symbolToIntegral ) where import Data.Bits @@ -49,6 +50,16 @@ negJS = \case Zero -> Zero One -> MinusOne +{-# SPECIALISE symbolToIntegral :: JacobiSymbol -> Integer, + JacobiSymbol -> Int + #-} +-- | Convenience function to convert out of a Jacobi symbol +symbolToIntegral :: (Integral a) => JacobiSymbol -> a +symbolToIntegral = \case + Zero -> 0 + One -> 1 + MinusOne -> -1 + -- | of two arguments. -- The lower argument (\"denominator\") must be odd and positive, -- this condition is checked. diff --git a/test-suite/Math/NumberTheory/DirichletCharactersTests.hs b/test-suite/Math/NumberTheory/DirichletCharactersTests.hs index 6f0565b06..44116dca6 100644 --- a/test-suite/Math/NumberTheory/DirichletCharactersTests.hs +++ b/test-suite/Math/NumberTheory/DirichletCharactersTests.hs @@ -12,7 +12,6 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeApplications #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE ViewPatterns #-} module Math.NumberTheory.DirichletCharactersTests where @@ -41,7 +40,7 @@ rootOfUnityTest n (Positive d) = toComplex ((d `div` gcd n d) `stimes` toRootOfU -- | 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 (Proxy :: Proxy n) + 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 @@ -58,7 +57,7 @@ dirCharProperty :: (forall n. KnownNat n => DirichletCharacter n -> a) -> Positi dirCharProperty test (Positive n) i = case someNatVal n of SomeNat (Proxy :: Proxy n) -> test chi - where chi = indexToChar (i `mod` totient n) :: DirichletCharacter n + where chi = indexToChar @n (i `mod` totient n) -- | There should be phi(n) characters countCharacters :: Positive Natural -> Bool @@ -73,12 +72,12 @@ principalCase (Positive n) = case someNatVal n of SomeNat (Proxy :: Proxy n) -> mapMaybe (generalEval chi) [minBound..maxBound] == genericReplicate (totient n) mempty - where chi = principalChar :: DirichletCharacter n + where chi = principalChar @n -- | 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 (Proxy :: Proxy n) + where n = natVal @n Proxy total = sum [toFunction chi a | a <- [0..n-1]] correct = if isPrincipal chi then fromIntegral $ totient n @@ -107,8 +106,8 @@ inducedCheck chi (Positive k) = case chi2 of Just chi2' -> and [generalEval chi2' (fromIntegral j) == generalEval chi (fromIntegral j) | j <- [0..d*k-1], gcd j (d*k) == 1] _ -> False - where chi2 = induced chi :: Maybe (DirichletCharacter n) - where d = natVal (Proxy :: Proxy d) + where chi2 = induced @n chi + where d = natVal @d Proxy -- | The jacobi character agrees with the jacobi symbol jacobiCheck :: Positive Natural -> Bool From c03ff0595489b33ba9fa17a61b210e6fefd5c3d0 Mon Sep 17 00:00:00 2001 From: Bhavik Mehta Date: Sun, 6 Jan 2019 17:09:24 +0000 Subject: [PATCH 29/65] Shuffle internals so we don't export discreteLogPP --- Math/NumberTheory/DirichletCharacters.hs | 37 ++++--- Math/NumberTheory/Moduli/DiscreteLogarithm.hs | 92 +--------------- .../Moduli/DiscreteLogarithm/Internal.hs | 100 ++++++++++++++++++ arithmoi.cabal | 1 + 4 files changed, 124 insertions(+), 106 deletions(-) create mode 100644 Math/NumberTheory/Moduli/DiscreteLogarithm/Internal.hs diff --git a/Math/NumberTheory/DirichletCharacters.hs b/Math/NumberTheory/DirichletCharacters.hs index 445391b6f..1cd72023c 100644 --- a/Math/NumberTheory/DirichletCharacters.hs +++ b/Math/NumberTheory/DirichletCharacters.hs @@ -45,25 +45,24 @@ module Math.NumberTheory.DirichletCharacters , validChar ) where -import Data.Bits (Bits(..)) -import Data.Complex (Complex, cis) -import Data.Functor.Identity (Identity(..)) -import Data.List (mapAccumL, foldl') -import Data.Proxy (Proxy(..)) -import Data.Ratio (Rational, Ratio, (%), numerator, denominator) -import Data.Semigroup (Semigroup(..), Product(..)) -import GHC.TypeNats.Compat (Nat, natVal) -import Numeric.Natural (Natural) - -import Math.NumberTheory.ArithmeticFunctions (totient) -import Math.NumberTheory.Moduli.Class (KnownNat, MultMod(..), getVal, Mod, isMultElement) -import Math.NumberTheory.Moduli.DiscreteLogarithm (discreteLogarithmPP) -import Math.NumberTheory.UniqueFactorisation (UniqueFactorisation, unPrime, Prime, factorise) -import Math.NumberTheory.Powers (powMod) -import Math.NumberTheory.Primes (primes) -import Math.NumberTheory.Utils.FromIntegral (wordToInt) - -import Math.NumberTheory.Moduli.PrimitiveRoot (isPrimitiveRoot', CyclicGroup(..)) +import Data.Bits (Bits(..)) +import Data.Complex (Complex, cis) +import Data.Functor.Identity (Identity(..)) +import Data.List (mapAccumL, foldl') +import Data.Proxy (Proxy(..)) +import Data.Ratio (Rational, Ratio, (%), numerator, denominator) +import Data.Semigroup (Semigroup(..), Product(..)) +import GHC.TypeNats.Compat (Nat, natVal) +import Numeric.Natural (Natural) + +import Math.NumberTheory.ArithmeticFunctions (totient) +import Math.NumberTheory.Moduli.Class (KnownNat, MultMod(..), getVal, Mod, isMultElement) +import Math.NumberTheory.Moduli.DiscreteLogarithm.Internal (discreteLogarithmPP) +import Math.NumberTheory.Moduli.PrimitiveRoot (isPrimitiveRoot', CyclicGroup(..)) +import Math.NumberTheory.Powers (powMod) +import Math.NumberTheory.Primes (primes) +import Math.NumberTheory.UniqueFactorisation (UniqueFactorisation, unPrime, Prime, factorise) +import Math.NumberTheory.Utils.FromIntegral (wordToInt) -- | 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 diff --git a/Math/NumberTheory/Moduli/DiscreteLogarithm.hs b/Math/NumberTheory/Moduli/DiscreteLogarithm.hs index a85787625..ed27b8a95 100644 --- a/Math/NumberTheory/Moduli/DiscreteLogarithm.hs +++ b/Math/NumberTheory/Moduli/DiscreteLogarithm.hs @@ -5,28 +5,18 @@ -- Maintainer: Andrew Lelechenko -- -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} module Math.NumberTheory.Moduli.DiscreteLogarithm ( discreteLogarithm - , discreteLogarithmPP ) where -import qualified Data.IntMap.Strict as M -import Data.Maybe (maybeToList) -import Data.Proxy -import Numeric.Natural (Natural) -import GHC.Integer.GMP.Internals (recipModInteger, powModInteger) -import GHC.TypeNats.Compat +import Numeric.Natural (Natural) -import Math.NumberTheory.Moduli.Chinese (chineseRemainder2) -import Math.NumberTheory.Moduli.Class (KnownNat, MultMod(..), Mod, getVal) -import Math.NumberTheory.Moduli.Equations (solveLinear) -import Math.NumberTheory.Moduli.PrimitiveRoot (PrimitiveRoot(..), CyclicGroup(..)) -import Math.NumberTheory.Powers.Squares (integerSquareRoot) -import Math.NumberTheory.UniqueFactorisation (unPrime) +import Math.NumberTheory.Moduli.Class (KnownNat, MultMod(..), Mod, getVal) +import Math.NumberTheory.Moduli.DiscreteLogarithm.Internal (discreteLogarithmPP) +import Math.NumberTheory.Moduli.PrimitiveRoot (PrimitiveRoot(..), CyclicGroup(..)) +import Math.NumberTheory.UniqueFactorisation (unPrime) -- | Computes the discrete logarithm. Currently uses a combination of the baby-step -- giant-step method and Pollard's rho algorithm, with Bach reduction. @@ -52,75 +42,3 @@ discreteLogarithm' cg a b = CGDoubleOddPrimePower (toInteger . unPrime -> p) k -> discreteLogarithmPP p k (getVal a `rem` p^k) (getVal b `rem` p^k) -- we have the isomorphism t -> t `rem` p^k from (Z/2p^kZ)* -> (Z/p^kZ)* - --- Implementation of Bach reduction (https://www2.eecs.berkeley.edu/Pubs/TechRpts/1984/CSD-84-186.pdf) -{-# INLINE discreteLogarithmPP #-} -discreteLogarithmPP :: Integer -> Word -> Integer -> Integer -> Natural -discreteLogarithmPP p 1 a b = discreteLogarithmPrime p a b -discreteLogarithmPP p k a b = fromInteger result - where - baseSol = toInteger $ discreteLogarithmPrime p (a `rem` p) (b `rem` p) - thetaA = theta p pkMinusOne a - thetaB = theta p pkMinusOne b - pkMinusOne = p^(k-1) - c = (recipModInteger thetaA pkMinusOne * thetaB) `rem` pkMinusOne - result = chineseRemainder2 (baseSol, p-1) (c, pkMinusOne) - --- compute the homomorphism theta given in https://math.stackexchange.com/a/1864495/418148 -{-# INLINE theta #-} -theta :: Integer -> Integer -> Integer -> Integer -theta p pkMinusOne a = (numerator `quot` pk) `rem` pkMinusOne - where - pk = pkMinusOne * p - p2kMinusOne = pkMinusOne * pk - numerator = (powModInteger a (pk - pkMinusOne) p2kMinusOne - 1) `rem` p2kMinusOne - --- TODO: Use Pollig-Hellman to reduce the problem further into groups of prime order. --- While Bach reduction simplifies the problem into groups of the form (Z/pZ)*, these --- have non-prime order, and the Pollig-Hellman algorithm can reduce the problem into --- smaller groups of prime order. --- In addition, the gcd check before solveLinear is applied in Pollard below will be --- made redundant, since n would be prime. -discreteLogarithmPrime :: Integer -> Integer -> Integer -> Natural -discreteLogarithmPrime p a b - | p < 100000000 = fromIntegral $ discreteLogarithmPrimeBSGS (fromInteger p) (fromInteger a) (fromInteger b) - | otherwise = discreteLogarithmPrimePollard p a b - -discreteLogarithmPrimeBSGS :: Int -> Int -> Int -> Int -discreteLogarithmPrimeBSGS p a b = head [i*m + j | (v,i) <- zip giants [0..m-1], j <- maybeToList (M.lookup v table)] - where - m = integerSquareRoot (p - 2) + 1 -- simple way of ceiling (sqrt (p-1)) - babies = iterate (.* a) 1 - table = M.fromList (zip babies [0..m-1]) - aInv = recipModInteger (toInteger a) (toInteger p) - bigGiant = fromInteger $ powModInteger aInv (toInteger m) (toInteger p) - giants = iterate (.* bigGiant) b - x .* y = x * y `rem` p - --- TODO: Use more advanced walks, in order to reduce divisions, cf --- https://maths-people.anu.edu.au/~brent/pd/rpb231.pdf --- This will slightly improve the expected time to collision, and can reduce the --- number of divisions performed. -discreteLogarithmPrimePollard :: Integer -> Integer -> Integer -> Natural -discreteLogarithmPrimePollard p a b = - case concatMap runPollard [(x,y) | x <- [0..n], y <- [0..n]] of - (t:_) -> fromInteger t - [] -> error ("discreteLogarithm: pollard's rho failed, please report this as a bug. inputs " ++ show [p,a,b]) - where - n = p-1 -- order of the cyclic group - halfN = n `quot` 2 - mul2 m = if m < halfN then m * 2 else m * 2 - n - sqrtN = integerSquareRoot n - step (xi,!ai,!bi) = case xi `rem` 3 of - 0 -> (xi*xi `rem` p, mul2 ai, mul2 bi) - 1 -> ( a*xi `rem` p, ai+1, bi) - _ -> ( b*xi `rem` p, ai, bi+1) - initialise (x,y) = (powModInteger a x n * powModInteger b y n `rem` n, x, y) - begin t = go (step t) (step (step t)) - check t = powModInteger a t p == b - go tort@(xi,ai,bi) hare@(x2i,a2i,b2i) - | xi == x2i, gcd (bi - b2i) n < sqrtN = case someNatVal (fromInteger n) of - SomeNat (Proxy :: Proxy n) -> map getVal $ solveLinear (fromInteger (bi - b2i) :: Mod n) (fromInteger (ai - a2i)) - | xi == x2i = [] - | otherwise = go (step tort) (step (step hare)) - runPollard = filter check . begin . initialise diff --git a/Math/NumberTheory/Moduli/DiscreteLogarithm/Internal.hs b/Math/NumberTheory/Moduli/DiscreteLogarithm/Internal.hs new file mode 100644 index 000000000..b0fde3160 --- /dev/null +++ b/Math/NumberTheory/Moduli/DiscreteLogarithm/Internal.hs @@ -0,0 +1,100 @@ +-- | +-- Module: Math.NumberTheory.Moduli.DiscreteLogarithm.Internal +-- Copyright: (c) 2018 Bhavik Mehta +-- License: MIT +-- Maintainer: Bhavik Mehta +-- +-- Internal functions dealing with discrete logarithms. End-users should not import this module. + +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE BangPatterns #-} + +{-# OPTIONS_HADDOCK hide #-} + +module Math.NumberTheory.Moduli.DiscreteLogarithm.Internal + ( discreteLogarithmPP + ) where + +import qualified Data.IntMap.Strict as M +import Data.Maybe (maybeToList) +import Data.Proxy (Proxy(..)) +import Numeric.Natural (Natural) +import GHC.Integer.GMP.Internals (recipModInteger, powModInteger) +import GHC.TypeNats.Compat (SomeNat(..), someNatVal) + +import Math.NumberTheory.Moduli.Chinese (chineseRemainder2) +import Math.NumberTheory.Moduli.Class (Mod, getVal) +import Math.NumberTheory.Moduli.Equations (solveLinear) +import Math.NumberTheory.Powers.Squares (integerSquareRoot) + +-- Implementation of Bach reduction (https://www2.eecs.berkeley.edu/Pubs/TechRpts/1984/CSD-84-186.pdf) +{-# INLINE discreteLogarithmPP #-} +discreteLogarithmPP :: Integer -> Word -> Integer -> Integer -> Natural +discreteLogarithmPP p 1 a b = discreteLogarithmPrime p a b +discreteLogarithmPP p k a b = fromInteger result + where + baseSol = toInteger $ discreteLogarithmPrime p (a `rem` p) (b `rem` p) + thetaA = theta p pkMinusOne a + thetaB = theta p pkMinusOne b + pkMinusOne = p^(k-1) + c = (recipModInteger thetaA pkMinusOne * thetaB) `rem` pkMinusOne + result = chineseRemainder2 (baseSol, p-1) (c, pkMinusOne) + +-- compute the homomorphism theta given in https://math.stackexchange.com/a/1864495/418148 +{-# INLINE theta #-} +theta :: Integer -> Integer -> Integer -> Integer +theta p pkMinusOne a = (numerator `quot` pk) `rem` pkMinusOne + where + pk = pkMinusOne * p + p2kMinusOne = pkMinusOne * pk + numerator = (powModInteger a (pk - pkMinusOne) p2kMinusOne - 1) `rem` p2kMinusOne + +-- TODO: Use Pollig-Hellman to reduce the problem further into groups of prime order. +-- While Bach reduction simplifies the problem into groups of the form (Z/pZ)*, these +-- have non-prime order, and the Pollig-Hellman algorithm can reduce the problem into +-- smaller groups of prime order. +-- In addition, the gcd check before solveLinear is applied in Pollard below will be +-- made redundant, since n would be prime. +discreteLogarithmPrime :: Integer -> Integer -> Integer -> Natural +discreteLogarithmPrime p a b + | p < 100000000 = fromIntegral $ discreteLogarithmPrimeBSGS (fromInteger p) (fromInteger a) (fromInteger b) + | otherwise = discreteLogarithmPrimePollard p a b + +discreteLogarithmPrimeBSGS :: Int -> Int -> Int -> Int +discreteLogarithmPrimeBSGS p a b = head [i*m + j | (v,i) <- zip giants [0..m-1], j <- maybeToList (M.lookup v table)] + where + m = integerSquareRoot (p - 2) + 1 -- simple way of ceiling (sqrt (p-1)) + babies = iterate (.* a) 1 + table = M.fromList (zip babies [0..m-1]) + aInv = recipModInteger (toInteger a) (toInteger p) + bigGiant = fromInteger $ powModInteger aInv (toInteger m) (toInteger p) + giants = iterate (.* bigGiant) b + x .* y = x * y `rem` p + +-- TODO: Use more advanced walks, in order to reduce divisions, cf +-- https://maths-people.anu.edu.au/~brent/pd/rpb231.pdf +-- This will slightly improve the expected time to collision, and can reduce the +-- number of divisions performed. +discreteLogarithmPrimePollard :: Integer -> Integer -> Integer -> Natural +discreteLogarithmPrimePollard p a b = + case concatMap runPollard [(x,y) | x <- [0..n], y <- [0..n]] of + (t:_) -> fromInteger t + [] -> error ("discreteLogarithm: pollard's rho failed, please report this as a bug. inputs " ++ show [p,a,b]) + where + n = p-1 -- order of the cyclic group + halfN = n `quot` 2 + mul2 m = if m < halfN then m * 2 else m * 2 - n + sqrtN = integerSquareRoot n + step (xi,!ai,!bi) = case xi `rem` 3 of + 0 -> (xi*xi `rem` p, mul2 ai, mul2 bi) + 1 -> ( a*xi `rem` p, ai+1, bi) + _ -> ( b*xi `rem` p, ai, bi+1) + initialise (x,y) = (powModInteger a x n * powModInteger b y n `rem` n, x, y) + begin t = go (step t) (step (step t)) + check t = powModInteger a t p == b + go tort@(xi,ai,bi) hare@(x2i,a2i,b2i) + | xi == x2i, gcd (bi - b2i) n < sqrtN = case someNatVal (fromInteger n) of + SomeNat (Proxy :: Proxy n) -> map getVal $ solveLinear (fromInteger (bi - b2i) :: Mod n) (fromInteger (ai - a2i)) + | xi == x2i = [] + | otherwise = go (step tort) (step (step hare)) + runPollard = filter check . begin . initialise diff --git a/arithmoi.cabal b/arithmoi.cabal index 79651c497..6c0f626a1 100644 --- a/arithmoi.cabal +++ b/arithmoi.cabal @@ -63,6 +63,7 @@ library Math.NumberTheory.Moduli.Chinese Math.NumberTheory.Moduli.Class Math.NumberTheory.Moduli.DiscreteLogarithm + Math.NumberTheory.Moduli.DiscreteLogarithm.Internal Math.NumberTheory.Moduli.Equations Math.NumberTheory.Moduli.Jacobi Math.NumberTheory.Moduli.PrimitiveRoot From 94c407c0e5fc551a9a637d4a32e61c5f2b9e9790 Mon Sep 17 00:00:00 2001 From: Bhavik Mehta Date: Sun, 6 Jan 2019 17:38:54 +0000 Subject: [PATCH 30/65] Added allChars, and switched twoPowers to Int --- Math/NumberTheory/DirichletCharacters.hs | 54 +++++++++++++----------- 1 file changed, 30 insertions(+), 24 deletions(-) diff --git a/Math/NumberTheory/DirichletCharacters.hs b/Math/NumberTheory/DirichletCharacters.hs index 1cd72023c..d60681234 100644 --- a/Math/NumberTheory/DirichletCharacters.hs +++ b/Math/NumberTheory/DirichletCharacters.hs @@ -31,6 +31,7 @@ module Math.NumberTheory.DirichletCharacters , indexToChar , indicesToChars , characterNumber + , allChars -- ** Special Dirichlet characters , principalChar , isPrincipal @@ -93,7 +94,8 @@ data DirichletFactor = OddPrime { _getPrime :: Prime Natural , _getGenerator :: Natural , _getValue :: RootOfUnity } - | TwoPower { _getPower :: Word + | TwoPower { _getPower2 :: Int -- this ought to be Word, but many applications + -- needed to use wordToInt, so Int is cleaner , _getFirstValue :: RootOfUnity , _getSecondValue :: RootOfUnity } @@ -133,7 +135,7 @@ toRootOfUnity q = RootOfUnity ((n `rem` d) % d) -- | 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) + RootOfUnity q1 <> RootOfUnity q2 = toRootOfUnity (q1 + q2) stimes k (RootOfUnity q) = toRootOfUnity (q * fromIntegral k) instance Monoid RootOfUnity where @@ -159,10 +161,10 @@ generator p k -- | Implement the function \(\lambda\) from page 5 of -- https://www2.eecs.berkeley.edu/Pubs/TechRpts/1984/CSD-84-186.pdf -lambda :: Integer -> Word -> Integer -lambda x e = ((powMod x (2*modulus) largeMod - 1) `shiftR` wordToInt (e+1)) .&. (modulus - 1) - where modulus = bit (wordToInt $ e-2) - largeMod = bit (wordToInt $ 2*e - 1) +lambda :: Integer -> Int -> Integer +lambda x e = ((powMod x (2*modulus) largeMod - 1) `shiftR` (e+1)) .&. (modulus - 1) + where modulus = bit (e-2) + largeMod = bit (2*e - 1) -- | For elements of the multiplicative group \((\mathbb{Z}/n\mathbb{Z})^*\), a Dirichlet -- character evaluates to a root of unity. @@ -180,9 +182,9 @@ evalFactor m = <> lambda m'' k `stimes` b where m' = m .&. kBits m'' = if testBit m 1 - then bit (wordToInt k) - m' + then bit k - m' else m' - kBits = bit (wordToInt k) - 1 + kBits = bit k - 1 -- | A character can evaluate to a root of unity or zero: represented by @Nothing@. generalEval :: KnownNat n => DirichletCharacter n -> Mod n -> Maybe RootOfUnity @@ -240,8 +242,8 @@ characterNumber (Generated y) = foldl' go 0 y where p' = fromIntegral (unPrime p) m = p'^(k-1)*(p'-1) go x (TwoPower k a b) = x' * 2 + numerator (fromRootOfUnity a * (2 % 1)) - where m = bit $ wordToInt $ k-2 :: Integer - x' = x `shiftL` wordToInt (k-2) + numerator (fromRootOfUnity b * fromIntegral m) + where m = bit (k-2) :: Integer + x' = x `shiftL` (k-2) + numerator (fromRootOfUnity b * fromIntegral m) -- | Give the dirichlet character from its number. -- Inverse of `characterNumber`. @@ -249,13 +251,17 @@ indexToChar :: forall n a. (KnownNat n, Integral a) => a -> 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, such as --- factorising the modulus. +-- `indexToChar` for multiple characters, as it prevents some internal recalculations. indicesToChars :: forall n a f. (KnownNat n, Integral a, Functor f) => f a -> f (DirichletCharacter n) indicesToChars = fmap (Generated . unroll t . (`mod` m) . fromIntegral) 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) + makeChar :: (Integral a) => DirichletCharacter n -> a -> DirichletCharacter n makeChar x = runIdentity . bulkMakeChars x . Identity @@ -273,7 +279,7 @@ data Template = OddTemplate { _getPrime' :: Prime Natural , _getGenerator' :: !Natural , _getModulus' :: !Natural } - | TwoTemplate { _getPower' :: Word + | TwoTemplate { _getPower2' :: Int , _getModulus' :: !Natural } -- the modulus is derivable from the other values, but calculation -- may be expensive, so we pre-calculate it @@ -286,7 +292,7 @@ templateFromCharacter (Generated t) = mapM go t where p' = unPrime p m = p'^(k-1)*(p'-1) go (TwoPower k _ _) = (Product (2*m), TwoTemplate k m) - where m = bit $ wordToInt $ k-2 + where m = bit (k-2) -- TODO (idea): Template is effectively a CyclicFactor of a generalised CyclicGroup... -- see issue #154 @@ -294,12 +300,12 @@ templateFromCharacter (Generated t) = mapM go t mkTemplate :: Natural -> (Product Natural, [Template]) mkTemplate = go . factorise where go :: [(Prime Natural, Word)] -> (Product Natural, [Template]) - go ((unPrime -> 2, 1):xs) = foldMap odds xs - go ((unPrime -> 2, k):xs) = (Product (2*m), [TwoTemplate k m]) <> foldMap odds xs - where m = bit $ wordToInt $ k-2 - go xs = foldMap odds xs - odds :: (Prime Natural, Word) -> (Product Natural, [Template]) - odds (p, k) = (Product m, [OddTemplate p k (generator p k) m]) + go ((unPrime -> 2, 1):xs) = mapM odds xs + go ((unPrime -> 2, wordToInt -> k):xs) = (Product (2*m), [TwoTemplate k m]) <> mapM odds xs + where m = bit (k-2) + go xs = mapM 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) @@ -341,21 +347,21 @@ induced (Generated start) = if n `rem` d == 0 combine t [] = plain t combine ((p1,k1):xs) (y:ys) -- TODO: consider tidying - | unPrime p1 == 2, TwoPower _ a b <- y = TwoPower k1 a b: combine xs ys + | unPrime p1 == 2, TwoPower _ a b <- y = TwoPower (wordToInt k1) a b: combine xs ys | OddPrime p2 1 _g a <- y, p1 == p2 = OddPrime p2 k1 (generator p2 k1) a: combine xs ys -- TODO: generator p2 k1 will be g or g + p2, and we already know g is a primroot mod p -- so should be able to save work instead of running generator | OddPrime p2 _ g a <- y, p1 == p2 = OddPrime p2 k1 g a: combine xs ys - | unPrime p1 == 2, k1 >= 2 = TwoPower k1 mempty mempty: combine xs (y:ys) + | unPrime p1 == 2, k1 >= 2 = TwoPower (wordToInt k1) mempty mempty: combine xs (y:ys) | unPrime p1 == 2 = combine xs (y:ys) | otherwise = OddPrime p1 k1 (generator p1 k1) mempty: combine xs (y:ys) plain :: [(Prime Natural, Word)] -> [DirichletFactor] plain [] = [] plain f@((p,k):xs) = case (unPrime p, k) of (2,1) -> map rest xs - (2,_) -> TwoPower k mempty mempty: map rest xs + (2,_) -> TwoPower (wordToInt k) mempty mempty: map rest xs _ -> map rest f rest :: (Prime Natural, Word) -> DirichletFactor rest (p,k) = OddPrime p k (generator p k) mempty @@ -402,7 +408,7 @@ toRealFunction (RealChar chi) m = case generalEval chi (fromIntegral m) of validChar :: forall n. KnownNat n => DirichletCharacter n -> Bool validChar (Generated xs) = correctDecomposition && all correctPrimitiveRoot xs where correctDecomposition = removeTwo (factorise n) == map getPP xs - getPP (TwoPower k _ _) = (two, k) + getPP (TwoPower k _ _) = (two, fromIntegral k) getPP (OddPrime p k _ _) = (p, k) removeTwo ((unPrime -> 2,1):ys) = ys removeTwo ys = ys From 5a5aeb625c0b63875d15663adf7bbcfc2393a996 Mon Sep 17 00:00:00 2001 From: Bhavik Mehta Date: Sun, 6 Jan 2019 17:53:20 +0000 Subject: [PATCH 31/65] Dirichlet characters are a group --- Math/NumberTheory/DirichletCharacters.hs | 36 ++++++++++++++++++++---- 1 file changed, 30 insertions(+), 6 deletions(-) diff --git a/Math/NumberTheory/DirichletCharacters.hs b/Math/NumberTheory/DirichletCharacters.hs index d60681234..bc5ce4c6d 100644 --- a/Math/NumberTheory/DirichletCharacters.hs +++ b/Math/NumberTheory/DirichletCharacters.hs @@ -36,6 +36,7 @@ module Math.NumberTheory.DirichletCharacters , principalChar , isPrincipal , induced + , isPrimitive -- ** Real Dirichlet characters , RealCharacter , isRealCharacter @@ -209,14 +210,21 @@ mulChars (Generated x) (Generated y) = Generated (zipWith combine x y) TwoPower k (a <> b) (n <> m) combine _ _ = error "internal error: malformed DirichletCharacter" --- TODO: this semigroup is also a group, allow `stimes` to work for non-positives too +-- | 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 mappend = (<>) +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) + -- | We define `succ` and `pred` with more efficient implementations than -- @`toEnum` . (+1) . `fromEnum`@. instance KnownNat n => Enum (DirichletCharacter n) where @@ -287,7 +295,7 @@ data Template = OddTemplate { _getPrime' :: Prime Natural -- pointless here templateFromCharacter :: DirichletCharacter n -> (Product Natural, [Template]) -templateFromCharacter (Generated t) = mapM go t +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) @@ -300,10 +308,10 @@ templateFromCharacter (Generated t) = mapM go t mkTemplate :: Natural -> (Product Natural, [Template]) mkTemplate = go . factorise where go :: [(Prime Natural, Word)] -> (Product Natural, [Template]) - go ((unPrime -> 2, 1):xs) = mapM odds xs - go ((unPrime -> 2, wordToInt -> k):xs) = (Product (2*m), [TwoTemplate k m]) <> mapM odds xs + go ((unPrime -> 2, 1):xs) = traverse odds xs + go ((unPrime -> 2, wordToInt -> k):xs) = (Product (2*m), [TwoTemplate k m]) <> traverse odds xs where m = bit (k-2) - go xs = mapM odds xs + 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 @@ -406,7 +414,7 @@ toRealFunction (RealChar chi) m = case generalEval chi (fromIntegral m) of -- | Test if the internal DirichletCharacter structure is valid. validChar :: forall n. KnownNat n => DirichletCharacter n -> Bool -validChar (Generated xs) = correctDecomposition && all correctPrimitiveRoot xs +validChar (Generated xs) = correctDecomposition && all correctPrimitiveRoot xs && all validValued xs where correctDecomposition = removeTwo (factorise n) == map getPP xs getPP (TwoPower k _ _) = (two, fromIntegral k) getPP (OddPrime p k _ _) = (p, k) @@ -414,5 +422,21 @@ validChar (Generated xs) = correctDecomposition && all correctPrimitiveRoot xs removeTwo ys = ys correctPrimitiveRoot TwoPower{} = True correctPrimitiveRoot (OddPrime p k g _) = g == generator p k + validValued (TwoPower k a b) = a <> a == mempty && (k-2) `stimes` b == mempty + validValued (OddPrime _ k _ a) = k `stimes` a == mempty n = natVal (Proxy :: Proxy n) two = head primes -- lazy way to get Prime 2 + +-- | Get the order of the character, and the maximal possible order of a character of this modulus. +-- The second term is the maximal order, and is carmichael(n) and is easily calculated from the +-- factor group breakdown we have. +orderChar :: DirichletCharacter n -> (Integer, Natural) +orderChar (Generated xs) = foldl' combine (1,1) $ map orderFactor xs + where orderFactor (TwoPower k (RootOfUnity a) (RootOfUnity b)) = (denominator a `lcm` denominator b, bit (k-1)) + orderFactor (OddPrime (unPrime -> p) k _ (RootOfUnity a)) = (denominator a, p^(k-1)*(p-1)) + combine (o1,n1) (o2,n2) = (lcm o1 o2, lcm n1 n2) + +-- | Test if a Dirichlet character is . +isPrimitive :: DirichletCharacter n -> Bool +isPrimitive chi = toInteger maxOrder == order + where (order, maxOrder) = orderChar chi From ef45de936bcd0135253a0560c234702fec7bcf41 Mon Sep 17 00:00:00 2001 From: Bhavik Mehta Date: Mon, 7 Jan 2019 15:43:17 +0000 Subject: [PATCH 32/65] Allow evaluating a dirichlet character everywhere at once --- Math/NumberTheory/DirichletCharacters.hs | 72 +++++++++++++++++-- .../NumberTheory/DirichletCharactersTests.hs | 6 ++ 2 files changed, 74 insertions(+), 4 deletions(-) diff --git a/Math/NumberTheory/DirichletCharacters.hs b/Math/NumberTheory/DirichletCharacters.hs index bc5ce4c6d..175bff882 100644 --- a/Math/NumberTheory/DirichletCharacters.hs +++ b/Math/NumberTheory/DirichletCharacters.hs @@ -25,13 +25,16 @@ module Math.NumberTheory.DirichletCharacters , toComplex -- * Dirichlet characters , DirichletCharacter - , evaluate - , generalEval - , toFunction + -- ** Construction , indexToChar , indicesToChars , characterNumber , allChars + -- ** Evaluation + , evaluate + , generalEval + , toFunction + , allEval -- ** Special Dirichlet characters , principalChar , isPrincipal @@ -49,11 +52,15 @@ module Math.NumberTheory.DirichletCharacters import Data.Bits (Bits(..)) import Data.Complex (Complex, cis) +import Data.Foldable (for_) import Data.Functor.Identity (Identity(..)) import Data.List (mapAccumL, foldl') import Data.Proxy (Proxy(..)) import Data.Ratio (Rational, Ratio, (%), numerator, denominator) import Data.Semigroup (Semigroup(..), Product(..)) +import qualified Data.Vector as V +import qualified Data.Vector.Mutable as MV +import Data.Vector (Vector, (!)) import GHC.TypeNats.Compat (Nat, natVal) import Numeric.Natural (Natural) @@ -192,7 +199,7 @@ generalEval :: KnownNat n => DirichletCharacter n -> Mod n -> Maybe RootOfUnity generalEval chi = fmap (evaluate chi) . isMultElement -- | Convert a Dirichlet character to a complex-valued function. As in `toComplex`, the result is --- inexact due to floating-point inaccuracies. See `toComplex` for more. +-- inexact due to floating-point inaccuracies. See `toComplex`. toFunction :: (Integral a, RealFloat b, KnownNat n) => DirichletCharacter n -> a -> Complex b toFunction chi = maybe 0 toComplex . generalEval chi . fromIntegral @@ -440,3 +447,60 @@ orderChar (Generated xs) = foldl' combine (1,1) $ map orderFactor xs isPrimitive :: DirichletCharacter n -> Bool isPrimitive chi = toInteger maxOrder == order where (order, maxOrder) = orderChar chi + +-- | Similar to Maybe, but with more appropriate Semigroup and Monoid instances. +data OrZero a = Zero | NonZero !a + +instance Semigroup a => Semigroup (OrZero a) where + Zero <> _ = Zero + _ <> Zero = Zero + NonZero a <> NonZero b = NonZero (a <> b) + +instance Monoid a => Monoid (OrZero a) where + mempty = NonZero mempty + mappend = (<>) + +instance Show a => Show (OrZero a) where + show Zero = "0" + show (NonZero x) = show x + +asNumber :: Num a => (b -> a) -> OrZero b -> a +asNumber _ Zero = 0 +asNumber 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, `allEval` will be better than `generalEval`, since +-- computations can be shared. +allEval :: forall n. KnownNat n => DirichletCharacter n -> Vector (OrZero RootOfUnity) +allEval (Generated xs) = V.generate (fromIntegral 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 (OddPrime p k (fromIntegral -> g) a) = (modulus, w) + where + p' = unPrime p + modulus = fromIntegral (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 + +-- somewhere between unfoldr and iterate +iterateMaybe :: (a -> Maybe a) -> a -> [a] +iterateMaybe f = go where go x = x: maybe [] go (f x) diff --git a/test-suite/Math/NumberTheory/DirichletCharactersTests.hs b/test-suite/Math/NumberTheory/DirichletCharactersTests.hs index 44116dca6..5b88a9aad 100644 --- a/test-suite/Math/NumberTheory/DirichletCharactersTests.hs +++ b/test-suite/Math/NumberTheory/DirichletCharactersTests.hs @@ -118,6 +118,12 @@ jacobiCheck (Positive n) = Just chi -> and [toRealFunction chi (fromIntegral j) == symbolToIntegral (jacobi j (2*n+1)) | j <- [0..2*n]] _ -> False +-- | Primitive checker is correct (in both directions) +primitiveCheck :: forall n. KnownNat n => DirichletCharacter n -> Bool +primitiveCheck = (==) <$> isPrimitive <*> isPrimitive' + where isPrimitive' chi = error "TODO: this" + n = natVal @n Proxy + testSuite :: TestTree testSuite = testGroup "DirichletCharacters" [ testSmallAndQuick "RootOfUnity contains roots of unity" rootOfUnityTest From fd6d2bf1132f5abbb2a88237c81cf8d295fa07c2 Mon Sep 17 00:00:00 2001 From: Bhavik Mehta Date: Tue, 8 Jan 2019 17:43:52 +0000 Subject: [PATCH 33/65] OrZero elsewhere and complete allEval --- Math/NumberTheory/DirichletCharacters.hs | 29 +++++++++++++++---- .../NumberTheory/DirichletCharactersTests.hs | 15 ++++++---- 2 files changed, 32 insertions(+), 12 deletions(-) diff --git a/Math/NumberTheory/DirichletCharacters.hs b/Math/NumberTheory/DirichletCharacters.hs index 175bff882..f833b6d01 100644 --- a/Math/NumberTheory/DirichletCharacters.hs +++ b/Math/NumberTheory/DirichletCharacters.hs @@ -195,13 +195,15 @@ evalFactor m = kBits = bit k - 1 -- | A character can evaluate to a root of unity or zero: represented by @Nothing@. -generalEval :: KnownNat n => DirichletCharacter n -> Mod n -> Maybe RootOfUnity -generalEval chi = fmap (evaluate chi) . isMultElement +generalEval :: KnownNat n => DirichletCharacter n -> Mod n -> OrZero RootOfUnity +generalEval chi t = case isMultElement t of + Nothing -> Zero + Just x -> NonZero $ evaluate chi x -- | Convert a Dirichlet character to a complex-valued function. As in `toComplex`, the result is -- inexact due to floating-point inaccuracies. See `toComplex`. toFunction :: (Integral a, RealFloat b, KnownNat n) => DirichletCharacter n -> a -> Complex b -toFunction chi = maybe 0 toComplex . generalEval chi . fromIntegral +toFunction chi = asNumber toComplex . generalEval chi . fromIntegral -- | Give the principal character for this modulus: a principal character mod \(n\) is 1 for -- \(a\) coprime to \(n\), and 0 otherwise. @@ -412,9 +414,9 @@ isRealCharacter t@(Generated xs) = if all real xs then Just (RealChar t) else No -- | Evaluate a real Dirichlet character, which can only take values \(-1,0,1\). toRealFunction :: KnownNat n => RealCharacter n -> Natural -> Int toRealFunction (RealChar chi) m = case generalEval chi (fromIntegral m) of - Nothing -> 0 - Just t | t == mempty -> 1 - Just t | t == RootOfUnity (1 % 2) -> -1 + 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 @@ -500,6 +502,21 @@ allEval (Generated xs) = V.generate (fromIntegral n) func 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' = m .&. kBits + m'' = if testBit m 1 + then bit k - m' + else m' + kBits = bit k - 1 -- somewhere between unfoldr and iterate iterateMaybe :: (a -> Maybe a) -> a -> [a] diff --git a/test-suite/Math/NumberTheory/DirichletCharactersTests.hs b/test-suite/Math/NumberTheory/DirichletCharactersTests.hs index 5b88a9aad..296f5d03e 100644 --- a/test-suite/Math/NumberTheory/DirichletCharactersTests.hs +++ b/test-suite/Math/NumberTheory/DirichletCharactersTests.hs @@ -23,7 +23,7 @@ import Data.Ratio import Numeric.Natural import Data.Semigroup import Data.Complex -import Data.List (nub, genericLength, genericReplicate, isSubsequenceOf) +import Data.List (genericLength, genericReplicate) import Data.Maybe (mapMaybe, isJust) import GHC.TypeNats.Compat (SomeNat(..), someNatVal, KnownNat, natVal) @@ -59,12 +59,12 @@ dirCharProperty test (Positive n) i = SomeNat (Proxy :: Proxy n) -> test chi where chi = indexToChar @n (i `mod` totient n) --- | There should be phi(n) characters +-- | There should be totient(n) characters countCharacters :: Positive Natural -> Bool countCharacters (Positive n) = case someNatVal n of SomeNat (Proxy :: Proxy n) -> - genericLength (nub [minBound :: DirichletCharacter n .. maxBound]) == totient n + genericLength (allChars @n) == totient n -- | The principal character should be 1 at all phi(n) places principalCase :: Positive Natural -> Bool @@ -87,16 +87,18 @@ 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 [maybe 0 toComplex (generalEval chi a') | chi <- [minBound .. maxBound]] + where total = sum [maybe 0 toComplex (generalEval 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 :: forall n. KnownNat n => DirichletCharacter n -> Bool +realityCheck :: KnownNat n => DirichletCharacter n -> Bool realityCheck chi = isJust (isRealCharacter chi) == isReal' - where isReal' = nub (mapMaybe (generalEval chi) [minBound..maxBound]) `isSubsequenceOf` [mempty, toRootOfUnity (1 % 2)] + where isReal' = and [real (generalEval chi t) | t <- [minBound..maxBound]] + real Nothing = True + real (Just t) = t <> t == mempty -- | Induced characters agree with the original character. inducedCheck :: forall d. KnownNat d => DirichletCharacter d -> Positive Natural -> Bool @@ -137,4 +139,5 @@ testSuite = testGroup "DirichletCharacters" , testSmallAndQuick "Real character checking is valid" (dirCharProperty realityCheck) , testSmallAndQuick "Jacobi character matches symbol" jacobiCheck , testSmallAndQuick "Induced character is correct" (dirCharProperty inducedCheck) + -- , testSmallAndQuick "Primitive character checking is valid" (dirCharProperty primitiveCheck) ] From 42f7b0d65b0b0ec584609cf2c69abc1eb6349964 Mon Sep 17 00:00:00 2001 From: Bhavik Mehta Date: Wed, 9 Jan 2019 18:51:55 +0000 Subject: [PATCH 34/65] Remove bad primitive character and more haddocks --- Math/NumberTheory/DirichletCharacters.hs | 45 ++++++++++---- .../NumberTheory/DirichletCharactersTests.hs | 59 +++++++++++-------- 2 files changed, 70 insertions(+), 34 deletions(-) diff --git a/Math/NumberTheory/DirichletCharacters.hs b/Math/NumberTheory/DirichletCharacters.hs index f833b6d01..77e4e4fc5 100644 --- a/Math/NumberTheory/DirichletCharacters.hs +++ b/Math/NumberTheory/DirichletCharacters.hs @@ -23,6 +23,9 @@ module Math.NumberTheory.DirichletCharacters , toRootOfUnity , fromRootOfUnity , toComplex + -- * An absorbing semigroup + , OrZero(..) + , asNumber -- * Dirichlet characters , DirichletCharacter -- ** Construction @@ -50,6 +53,7 @@ module Math.NumberTheory.DirichletCharacters , validChar ) where +import Control.Applicative (Applicative(..)) import Data.Bits (Bits(..)) import Data.Complex (Complex, cis) import Data.Foldable (for_) @@ -439,24 +443,44 @@ validChar (Generated xs) = correctDecomposition && all correctPrimitiveRoot xs & -- | Get the order of the character, and the maximal possible order of a character of this modulus. -- The second term is the maximal order, and is carmichael(n) and is easily calculated from the -- factor group breakdown we have. -orderChar :: DirichletCharacter n -> (Integer, Natural) -orderChar (Generated xs) = foldl' combine (1,1) $ map orderFactor xs - where orderFactor (TwoPower k (RootOfUnity a) (RootOfUnity b)) = (denominator a `lcm` denominator b, bit (k-1)) - orderFactor (OddPrime (unPrime -> p) k _ (RootOfUnity a)) = (denominator a, p^(k-1)*(p-1)) - combine (o1,n1) (o2,n2) = (lcm o1 o2, lcm n1 n2) +-- orderChar :: DirichletCharacter n -> (Integer, Natural) +-- orderChar (Generated xs) = foldl' combine (1,1) $ map orderFactor xs +-- where orderFactor (TwoPower k (RootOfUnity a) (RootOfUnity b)) = (denominator a `lcm` denominator b, bit (k-1)) +-- orderFactor (OddPrime (unPrime -> p) k _ (RootOfUnity a)) = (denominator a, p^(k-1)*(p-1)) +-- combine (o1,n1) (o2,n2) = (lcm o1 o2, lcm n1 n2) -- | Test if a Dirichlet character is . isPrimitive :: DirichletCharacter n -> Bool -isPrimitive chi = toInteger maxOrder == order - where (order, maxOrder) = orderChar chi +isPrimitive = undefined +-- TODO: this isn't correct. figure out a correct version and write it +-- isPrimitive chi = toInteger maxOrder == order +-- where (order, maxOrder) = orderChar chi --- | Similar to Maybe, but with more appropriate Semigroup and Monoid instances. +-- | Similar to Maybe, but with different Semigroup and Monoid instances. data OrZero a = Zero | NonZero !a + deriving (Eq) + +-- | An equivalent `Functor` instance to `Maybe`. +instance Functor OrZero where + fmap _ Zero = Zero + fmap f (NonZero x) = NonZero (f x) + +-- | An equivalent `Applicative` instance to `Maybe`. +instance Applicative OrZero where + pure = NonZero + NonZero f <*> m = fmap f m + Zero <*> _ = Zero + + liftA2 f (NonZero x) (NonZero y) = NonZero (f x y) + liftA2 _ _ _ = Zero + + NonZero _ *> m = m + Zero *> _ = Zero +-- | `Zero` is an absorbing element for this semigroup instance Semigroup a => Semigroup (OrZero a) where - Zero <> _ = Zero - _ <> Zero = Zero NonZero a <> NonZero b = NonZero (a <> b) + _ <> _ = Zero instance Monoid a => Monoid (OrZero a) where mempty = NonZero mempty @@ -466,6 +490,7 @@ instance Show a => Show (OrZero a) where show Zero = "0" show (NonZero x) = show x +-- | Interpret an `OrZero` as a number, taking the `Zero` case to be 0. asNumber :: Num a => (b -> a) -> OrZero b -> a asNumber _ Zero = 0 asNumber f (NonZero x) = f x diff --git a/test-suite/Math/NumberTheory/DirichletCharactersTests.hs b/test-suite/Math/NumberTheory/DirichletCharactersTests.hs index 296f5d03e..cd9a41157 100644 --- a/test-suite/Math/NumberTheory/DirichletCharactersTests.hs +++ b/test-suite/Math/NumberTheory/DirichletCharactersTests.hs @@ -23,16 +23,18 @@ import Data.Ratio import Numeric.Natural import Data.Semigroup import Data.Complex -import Data.List (genericLength, genericReplicate) -import Data.Maybe (mapMaybe, isJust) +import Data.List (genericLength) +import Data.Maybe (isJust) +import qualified Data.Vector as V import GHC.TypeNats.Compat (SomeNat(..), someNatVal, KnownNat, natVal) import Math.NumberTheory.ArithmeticFunctions (totient) import Math.NumberTheory.DirichletCharacters -import Math.NumberTheory.Moduli.Jacobi +import qualified Math.NumberTheory.Moduli.Jacobi as J import Math.NumberTheory.Moduli.Class (SomeMod(..), modulo) import Math.NumberTheory.TestUtils (testSmallAndQuick, Positive(..)) +import Math.NumberTheory.Primes rootOfUnityTest :: Integer -> Positive Integer -> Bool rootOfUnityTest n (Positive d) = toComplex ((d `div` gcd n d) `stimes` toRootOfUnity (n % d)) == (1 :: Complex Double) @@ -66,13 +68,15 @@ countCharacters (Positive n) = SomeNat (Proxy :: Proxy n) -> genericLength (allChars @n) == totient n --- | The principal character should be 1 at all phi(n) places -principalCase :: Positive Natural -> Bool -principalCase (Positive n) = - case someNatVal n of - SomeNat (Proxy :: Proxy n) -> - mapMaybe (generalEval chi) [minBound..maxBound] == genericReplicate (totient n) mempty - where chi = principalChar @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 -> generalEval 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 @@ -87,7 +91,7 @@ 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 [maybe 0 toComplex (generalEval chi a') | chi <- allChars] + where total = sum [asNumber toComplex (generalEval chi a') | chi <- allChars] correct = if a' == 1 then fromIntegral $ totient n else 0 @@ -97,18 +101,19 @@ orthogonality2 (Positive n) a = realityCheck :: KnownNat n => DirichletCharacter n -> Bool realityCheck chi = isJust (isRealCharacter chi) == isReal' where isReal' = and [real (generalEval chi t) | t <- [minBound..maxBound]] - real Nothing = True - real (Just t) = t <> t == mempty + real Zero = True + real (NonZero t) = t <> t == mempty -- | Induced characters agree with the original character. -inducedCheck :: forall d. KnownNat d => DirichletCharacter d -> Positive Natural -> Bool -inducedCheck chi (Positive k) = +inducedCheck :: forall d. KnownNat d => DirichletCharacter d -> Positive Natural -> Natural -> Bool +inducedCheck chi (Positive k) i = case someNatVal (d*k) of SomeNat (Proxy :: Proxy n) -> - case chi2 of - Just chi2' -> and [generalEval chi2' (fromIntegral j) == generalEval chi (fromIntegral j) | j <- [0..d*k-1], gcd j (d*k) == 1] - _ -> False - where chi2 = induced @n chi + case induced @n chi of + Just chi2 -> if (fromIntegral i) `gcd` (d*k) > 0 + then True + else generalEval chi (fromIntegral i) == generalEval chi2 (fromIntegral i) + Nothing -> False where d = natVal @d Proxy -- | The jacobi character agrees with the jacobi symbol @@ -117,14 +122,20 @@ jacobiCheck (Positive n) = case someNatVal (2*n+1) of SomeNat (Proxy :: Proxy n) -> case jacobiCharacter @n of - Just chi -> and [toRealFunction chi (fromIntegral j) == symbolToIntegral (jacobi j (2*n+1)) | j <- [0..2*n]] + Just chi -> and [toRealFunction chi (fromIntegral j) == J.symbolToIntegral (J.jacobi j (2*n+1)) | j <- [0..2*n]] _ -> False -- | Primitive checker is correct (in both directions) -primitiveCheck :: forall n. KnownNat n => DirichletCharacter n -> Bool -primitiveCheck = (==) <$> isPrimitive <*> isPrimitive' - where isPrimitive' chi = error "TODO: this" - n = natVal @n Proxy +-- primitiveCheck :: forall n. KnownNat n => DirichletCharacter n -> Bool +-- primitiveCheck = if n > 5 +-- then (==) <$> isPrimitive <*> isPrimitive' +-- else const True +-- where isPrimitive' chi = not $ any (periodic (allEval chi)) primeFactors +-- n = fromIntegral (natVal @n Proxy) +-- primeFactors = map (unPrime . fst) $ factorise n +-- periodic v k = and [allEqual [v V.! j | j <- [i,i + n `div` k .. n-1]] | i <- [0..k-1]] +-- allEqual :: Eq a => [a] -> Bool +-- allEqual = and . (zipWith (==) <*> tail) testSuite :: TestTree testSuite = testGroup "DirichletCharacters" From f34066c3d3b179ddce5bedc9d377c1a88e85ad73 Mon Sep 17 00:00:00 2001 From: Bhavik Mehta Date: Sun, 5 Jan 2020 00:09:24 +0000 Subject: [PATCH 35/65] update to match new Mods --- Math/NumberTheory/DirichletCharacters.hs | 15 +++++++++------ Math/NumberTheory/Moduli/Multiplicative.hs | 1 + 2 files changed, 10 insertions(+), 6 deletions(-) diff --git a/Math/NumberTheory/DirichletCharacters.hs b/Math/NumberTheory/DirichletCharacters.hs index 77e4e4fc5..a2d89b2a7 100644 --- a/Math/NumberTheory/DirichletCharacters.hs +++ b/Math/NumberTheory/DirichletCharacters.hs @@ -69,12 +69,13 @@ import GHC.TypeNats.Compat (Nat, natVal) import Numeric.Natural (Natural) import Math.NumberTheory.ArithmeticFunctions (totient) -import Math.NumberTheory.Moduli.Class (KnownNat, MultMod(..), getVal, Mod, isMultElement) +import Math.NumberTheory.Moduli.Class hiding (powMod) +import Math.NumberTheory.Moduli.Singleton import Math.NumberTheory.Moduli.DiscreteLogarithm.Internal (discreteLogarithmPP) -import Math.NumberTheory.Moduli.PrimitiveRoot (isPrimitiveRoot', CyclicGroup(..)) -import Math.NumberTheory.Powers (powMod) -import Math.NumberTheory.Primes (primes) -import Math.NumberTheory.UniqueFactorisation (UniqueFactorisation, unPrime, Prime, factorise) +import Math.NumberTheory.Moduli.Multiplicative +import Math.NumberTheory.Powers.Modular (powMod) +import Math.NumberTheory.Primes +-- import Math.NumberTheory.UniqueFactorisation (UniqueFactorisation, unPrime, Prime, factorise) import Math.NumberTheory.Utils.FromIntegral (wordToInt) -- | A Dirichlet character mod \(n\) is a group homomorphism from \((\mathbb{Z}/n\mathbb{Z})^*\) @@ -169,7 +170,9 @@ generator p k | k == 1 = modP | otherwise = if powMod modP (p'-1) (p'*p') == 1 then modP + p' else modP where p' = unPrime p - modP = head $ filter (isPrimitiveRoot' (CGOddPrimePower p 1)) [2..p'-1] + modP = case cyclicGroupFromFactors [(p,k)] of + Just (Some cg) -> head $ filter (isPrimitiveRoot' cg) [2..p'-1] + _ -> error "illegal" -- | Implement the function \(\lambda\) from page 5 of -- https://www2.eecs.berkeley.edu/Pubs/TechRpts/1984/CSD-84-186.pdf diff --git a/Math/NumberTheory/Moduli/Multiplicative.hs b/Math/NumberTheory/Moduli/Multiplicative.hs index c1da2803b..faa0604ee 100644 --- a/Math/NumberTheory/Moduli/Multiplicative.hs +++ b/Math/NumberTheory/Moduli/Multiplicative.hs @@ -21,6 +21,7 @@ module Math.NumberTheory.Moduli.Multiplicative , PrimitiveRoot , unPrimitiveRoot , isPrimitiveRoot + , isPrimitiveRoot' , discreteLogarithm ) where From 6968f4a2afb9bcd08c290ef8cbbc5871df12b730 Mon Sep 17 00:00:00 2001 From: Bhavik Mehta Date: Sun, 5 Jan 2020 20:54:06 +0000 Subject: [PATCH 36/65] add a new test --- Math/NumberTheory/DirichletCharacters.hs | 4 ++-- test-suite/Math/NumberTheory/DirichletCharactersTests.hs | 6 ++++++ 2 files changed, 8 insertions(+), 2 deletions(-) diff --git a/Math/NumberTheory/DirichletCharacters.hs b/Math/NumberTheory/DirichletCharacters.hs index a2d89b2a7..ee0221816 100644 --- a/Math/NumberTheory/DirichletCharacters.hs +++ b/Math/NumberTheory/DirichletCharacters.hs @@ -131,8 +131,8 @@ newtype RootOfUnity = instance Show RootOfUnity where show (RootOfUnity q) - | n == 0 = "e^0" - | d == 1 = "e^(πi)" + | n == 0 = "1" + | d == 1 = "-1" | n == 1 = "e^(πi/" ++ show d ++ ")" | otherwise = "e^(" ++ show n ++ "πi/" ++ show d ++ ")" where n = numerator (2*q) diff --git a/test-suite/Math/NumberTheory/DirichletCharactersTests.hs b/test-suite/Math/NumberTheory/DirichletCharactersTests.hs index cd9a41157..39882a2d5 100644 --- a/test-suite/Math/NumberTheory/DirichletCharactersTests.hs +++ b/test-suite/Math/NumberTheory/DirichletCharactersTests.hs @@ -125,6 +125,11 @@ jacobiCheck (Positive n) = Just chi -> and [toRealFunction chi (fromIntegral j) == J.symbolToIntegral (J.jacobi j (2*n+1)) | j <- [0..2*n]] _ -> False + +-- | Bulk evaluation agrees with pointwise evaluation +allEvalCheck :: forall n. KnownNat n => DirichletCharacter n -> Bool +allEvalCheck chi = V.generate (fromIntegral $ natVal @n Proxy) (generalEval chi . fromIntegral) == allEval chi + -- | Primitive checker is correct (in both directions) -- primitiveCheck :: forall n. KnownNat n => DirichletCharacter n -> Bool -- primitiveCheck = if n > 5 @@ -150,5 +155,6 @@ testSuite = testGroup "DirichletCharacters" , testSmallAndQuick "Real character checking is valid" (dirCharProperty realityCheck) , testSmallAndQuick "Jacobi character matches symbol" jacobiCheck , testSmallAndQuick "Induced character is correct" (dirCharProperty inducedCheck) + , testSmallAndQuick "Bulk evaluation matches pointwise" (dirCharProperty allEvalCheck) -- , testSmallAndQuick "Primitive character checking is valid" (dirCharProperty primitiveCheck) ] From 97c5f3b41e93cdf03faa2c373363180b983560d4 Mon Sep 17 00:00:00 2001 From: Bhavik Mehta Date: Sun, 5 Jan 2020 21:24:40 +0000 Subject: [PATCH 37/65] cosmetic changes and comments --- Math/NumberTheory/DirichletCharacters.hs | 4 +- .../Moduli/DiscreteLogarithm/Internal.hs | 100 ------------------ Math/NumberTheory/Moduli/Multiplicative.hs | 4 +- arithmoi.cabal | 1 - 4 files changed, 3 insertions(+), 106 deletions(-) delete mode 100644 Math/NumberTheory/Moduli/DiscreteLogarithm/Internal.hs diff --git a/Math/NumberTheory/DirichletCharacters.hs b/Math/NumberTheory/DirichletCharacters.hs index ee0221816..5a0fe361b 100644 --- a/Math/NumberTheory/DirichletCharacters.hs +++ b/Math/NumberTheory/DirichletCharacters.hs @@ -69,13 +69,11 @@ import GHC.TypeNats.Compat (Nat, natVal) import Numeric.Natural (Natural) import Math.NumberTheory.ArithmeticFunctions (totient) -import Math.NumberTheory.Moduli.Class hiding (powMod) +import Math.NumberTheory.Moduli.Class (KnownNat, Mod, getVal) import Math.NumberTheory.Moduli.Singleton -import Math.NumberTheory.Moduli.DiscreteLogarithm.Internal (discreteLogarithmPP) import Math.NumberTheory.Moduli.Multiplicative import Math.NumberTheory.Powers.Modular (powMod) import Math.NumberTheory.Primes --- import Math.NumberTheory.UniqueFactorisation (UniqueFactorisation, unPrime, Prime, factorise) import Math.NumberTheory.Utils.FromIntegral (wordToInt) -- | A Dirichlet character mod \(n\) is a group homomorphism from \((\mathbb{Z}/n\mathbb{Z})^*\) diff --git a/Math/NumberTheory/Moduli/DiscreteLogarithm/Internal.hs b/Math/NumberTheory/Moduli/DiscreteLogarithm/Internal.hs deleted file mode 100644 index b0fde3160..000000000 --- a/Math/NumberTheory/Moduli/DiscreteLogarithm/Internal.hs +++ /dev/null @@ -1,100 +0,0 @@ --- | --- Module: Math.NumberTheory.Moduli.DiscreteLogarithm.Internal --- Copyright: (c) 2018 Bhavik Mehta --- License: MIT --- Maintainer: Bhavik Mehta --- --- Internal functions dealing with discrete logarithms. End-users should not import this module. - -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE BangPatterns #-} - -{-# OPTIONS_HADDOCK hide #-} - -module Math.NumberTheory.Moduli.DiscreteLogarithm.Internal - ( discreteLogarithmPP - ) where - -import qualified Data.IntMap.Strict as M -import Data.Maybe (maybeToList) -import Data.Proxy (Proxy(..)) -import Numeric.Natural (Natural) -import GHC.Integer.GMP.Internals (recipModInteger, powModInteger) -import GHC.TypeNats.Compat (SomeNat(..), someNatVal) - -import Math.NumberTheory.Moduli.Chinese (chineseRemainder2) -import Math.NumberTheory.Moduli.Class (Mod, getVal) -import Math.NumberTheory.Moduli.Equations (solveLinear) -import Math.NumberTheory.Powers.Squares (integerSquareRoot) - --- Implementation of Bach reduction (https://www2.eecs.berkeley.edu/Pubs/TechRpts/1984/CSD-84-186.pdf) -{-# INLINE discreteLogarithmPP #-} -discreteLogarithmPP :: Integer -> Word -> Integer -> Integer -> Natural -discreteLogarithmPP p 1 a b = discreteLogarithmPrime p a b -discreteLogarithmPP p k a b = fromInteger result - where - baseSol = toInteger $ discreteLogarithmPrime p (a `rem` p) (b `rem` p) - thetaA = theta p pkMinusOne a - thetaB = theta p pkMinusOne b - pkMinusOne = p^(k-1) - c = (recipModInteger thetaA pkMinusOne * thetaB) `rem` pkMinusOne - result = chineseRemainder2 (baseSol, p-1) (c, pkMinusOne) - --- compute the homomorphism theta given in https://math.stackexchange.com/a/1864495/418148 -{-# INLINE theta #-} -theta :: Integer -> Integer -> Integer -> Integer -theta p pkMinusOne a = (numerator `quot` pk) `rem` pkMinusOne - where - pk = pkMinusOne * p - p2kMinusOne = pkMinusOne * pk - numerator = (powModInteger a (pk - pkMinusOne) p2kMinusOne - 1) `rem` p2kMinusOne - --- TODO: Use Pollig-Hellman to reduce the problem further into groups of prime order. --- While Bach reduction simplifies the problem into groups of the form (Z/pZ)*, these --- have non-prime order, and the Pollig-Hellman algorithm can reduce the problem into --- smaller groups of prime order. --- In addition, the gcd check before solveLinear is applied in Pollard below will be --- made redundant, since n would be prime. -discreteLogarithmPrime :: Integer -> Integer -> Integer -> Natural -discreteLogarithmPrime p a b - | p < 100000000 = fromIntegral $ discreteLogarithmPrimeBSGS (fromInteger p) (fromInteger a) (fromInteger b) - | otherwise = discreteLogarithmPrimePollard p a b - -discreteLogarithmPrimeBSGS :: Int -> Int -> Int -> Int -discreteLogarithmPrimeBSGS p a b = head [i*m + j | (v,i) <- zip giants [0..m-1], j <- maybeToList (M.lookup v table)] - where - m = integerSquareRoot (p - 2) + 1 -- simple way of ceiling (sqrt (p-1)) - babies = iterate (.* a) 1 - table = M.fromList (zip babies [0..m-1]) - aInv = recipModInteger (toInteger a) (toInteger p) - bigGiant = fromInteger $ powModInteger aInv (toInteger m) (toInteger p) - giants = iterate (.* bigGiant) b - x .* y = x * y `rem` p - --- TODO: Use more advanced walks, in order to reduce divisions, cf --- https://maths-people.anu.edu.au/~brent/pd/rpb231.pdf --- This will slightly improve the expected time to collision, and can reduce the --- number of divisions performed. -discreteLogarithmPrimePollard :: Integer -> Integer -> Integer -> Natural -discreteLogarithmPrimePollard p a b = - case concatMap runPollard [(x,y) | x <- [0..n], y <- [0..n]] of - (t:_) -> fromInteger t - [] -> error ("discreteLogarithm: pollard's rho failed, please report this as a bug. inputs " ++ show [p,a,b]) - where - n = p-1 -- order of the cyclic group - halfN = n `quot` 2 - mul2 m = if m < halfN then m * 2 else m * 2 - n - sqrtN = integerSquareRoot n - step (xi,!ai,!bi) = case xi `rem` 3 of - 0 -> (xi*xi `rem` p, mul2 ai, mul2 bi) - 1 -> ( a*xi `rem` p, ai+1, bi) - _ -> ( b*xi `rem` p, ai, bi+1) - initialise (x,y) = (powModInteger a x n * powModInteger b y n `rem` n, x, y) - begin t = go (step t) (step (step t)) - check t = powModInteger a t p == b - go tort@(xi,ai,bi) hare@(x2i,a2i,b2i) - | xi == x2i, gcd (bi - b2i) n < sqrtN = case someNatVal (fromInteger n) of - SomeNat (Proxy :: Proxy n) -> map getVal $ solveLinear (fromInteger (bi - b2i) :: Mod n) (fromInteger (ai - a2i)) - | xi == x2i = [] - | otherwise = go (step tort) (step (step hare)) - runPollard = filter check . begin . initialise diff --git a/Math/NumberTheory/Moduli/Multiplicative.hs b/Math/NumberTheory/Moduli/Multiplicative.hs index faa0604ee..1a50b3bd5 100644 --- a/Math/NumberTheory/Moduli/Multiplicative.hs +++ b/Math/NumberTheory/Moduli/Multiplicative.hs @@ -21,11 +21,11 @@ module Math.NumberTheory.Moduli.Multiplicative , PrimitiveRoot , unPrimitiveRoot , isPrimitiveRoot - , isPrimitiveRoot' + , isPrimitiveRoot' -- TODO (BM): don't expose this , discreteLogarithm + , discreteLogarithmPP -- TODO (BM): don't expose this ) where --- TODO: (BM) put discreteLogarithmPP into an Internal module so it could be used elsewhere import Control.Monad import Data.Constraint import qualified Data.Map as M diff --git a/arithmoi.cabal b/arithmoi.cabal index 8582ee1d0..5036d44d1 100644 --- a/arithmoi.cabal +++ b/arithmoi.cabal @@ -66,7 +66,6 @@ library Math.NumberTheory.Moduli.Chinese Math.NumberTheory.Moduli.Class Math.NumberTheory.Moduli.DiscreteLogarithm - Math.NumberTheory.Moduli.DiscreteLogarithm.Internal Math.NumberTheory.Moduli.Equations Math.NumberTheory.Moduli.Jacobi Math.NumberTheory.Moduli.Multiplicative From 2c987ca777fc7fa9d6eaca6ea72423380afd572a Mon Sep 17 00:00:00 2001 From: Bhavik Mehta Date: Sun, 5 Jan 2020 22:14:06 +0000 Subject: [PATCH 38/65] Start of tests fix [skip ci] --- Math/NumberTheory/DirichletCharacters.hs | 92 +++++++++++-------- Math/NumberTheory/Moduli/Sqrt.hs | 1 + .../NumberTheory/DirichletCharactersTests.hs | 3 +- 3 files changed, 55 insertions(+), 41 deletions(-) diff --git a/Math/NumberTheory/DirichletCharacters.hs b/Math/NumberTheory/DirichletCharacters.hs index 5a0fe361b..cb96867a8 100644 --- a/Math/NumberTheory/DirichletCharacters.hs +++ b/Math/NumberTheory/DirichletCharacters.hs @@ -107,9 +107,11 @@ data DirichletFactor = OddPrime { _getPrime :: Prime Natural } | 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 @@ -117,6 +119,7 @@ instance Eq (DirichletCharacter n) where instance Eq DirichletFactor where TwoPower _ x1 x2 == TwoPower _ y1 y2 = x1 == y1 && x2 == y2 OddPrime _ _ _ x == OddPrime _ _ _ y = x == y + Two == Two = True _ == _ = False -- | A representation of : complex @@ -198,6 +201,7 @@ evalFactor m = then bit k - m' else m' kBits = bit k - 1 + Two -> mempty -- | A character can evaluate to a root of unity or zero: represented by @Nothing@. generalEval :: KnownNat n => DirichletCharacter n -> Mod n -> OrZero RootOfUnity @@ -238,6 +242,7 @@ 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`@. @@ -266,6 +271,7 @@ characterNumber (Generated y) = foldl' go 0 y go x (TwoPower k a b) = x' * 2 + numerator (fromRootOfUnity a * (2 % 1)) where m = bit (k-2) :: Integer x' = x `shiftL` (k-2) + numerator (fromRootOfUnity b * fromIntegral m) + go x Two = x -- | Give the dirichlet character from its number. -- Inverse of `characterNumber`. @@ -301,20 +307,22 @@ data Template = OddTemplate { _getPrime' :: Prime Natural , _getGenerator' :: !Natural , _getModulus' :: !Natural } - | TwoTemplate { _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 + | 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), TwoTemplate k m) + go (TwoPower k _ _) = (Product (2*m), TwoPTemplate k m) where m = bit (k-2) + go Two = (Product 1, TwoTemplate) -- TODO (idea): Template is effectively a CyclicFactor of a generalised CyclicGroup... -- see issue #154 @@ -322,8 +330,8 @@ templateFromCharacter (Generated t) = traverse go t mkTemplate :: Natural -> (Product Natural, [Template]) mkTemplate = go . factorise where go :: [(Prime Natural, Word)] -> (Product Natural, [Template]) - go ((unPrime -> 2, 1):xs) = traverse odds xs - go ((unPrime -> 2, wordToInt -> k):xs) = (Product (2*m), [TwoTemplate k m]) <> traverse odds xs + 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) @@ -337,10 +345,11 @@ 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 $ a2 % n)) where (a1,a2) = quotRem a n - func a (TwoTemplate k n) = (b1, TwoPower k (toRootOfUnity $ a2 % 2) (toRootOfUnity $ b2 % n)) + func a (TwoPTemplate k n) = (b1, TwoPower k (toRootOfUnity $ a2 % 2) (toRootOfUnity $ b2 % n)) where (a1,a2) = quotRem a 2 (b1,b2) = quotRem a1 n -- TODO: consider tidying + 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. @@ -359,34 +368,37 @@ isPrincipal chi = characterNumber chi == 0 -- 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 n' start)) + then Just (Generated (combine (snd $ mkTemplate n) start)) else Nothing where n = natVal (Proxy :: Proxy n) d = natVal (Proxy :: Proxy d) - n' = factorise n - combine :: [(Prime Natural, Word)] -> [DirichletFactor] -> [DirichletFactor] + combine :: [Template] -> [DirichletFactor] -> [DirichletFactor] combine [] _ = [] - combine t [] = plain t - combine ((p1,k1):xs) (y:ys) + combine ts [] = map newFactor ts + combine (t:xs) (y:ys) = undefined -- TODO: consider tidying - | unPrime p1 == 2, TwoPower _ a b <- y = TwoPower (wordToInt k1) a b: combine xs ys - | OddPrime p2 1 _g a <- y, p1 == p2 = - OddPrime p2 k1 (generator p2 k1) a: combine xs ys - -- TODO: generator p2 k1 will be g or g + p2, and we already know g is a primroot mod p - -- so should be able to save work instead of running generator - | OddPrime p2 _ g a <- y, p1 == p2 = - OddPrime p2 k1 g a: combine xs ys - | unPrime p1 == 2, k1 >= 2 = TwoPower (wordToInt k1) mempty mempty: combine xs (y:ys) - | unPrime p1 == 2 = combine xs (y:ys) - | otherwise = OddPrime p1 k1 (generator p1 k1) mempty: combine xs (y:ys) - plain :: [(Prime Natural, Word)] -> [DirichletFactor] - plain [] = [] - plain f@((p,k):xs) = case (unPrime p, k) of - (2,1) -> map rest xs - (2,_) -> TwoPower (wordToInt k) mempty mempty: map rest xs - _ -> map rest f - rest :: (Prime Natural, Word) -> DirichletFactor - rest (p,k) = OddPrime p k (generator p k) mempty + -- unPrime p1 == 2, TwoPower _ a b <- y = TwoPower (wordToInt k1) a b: combine xs ys + -- unPrime p1 == 2, k1 >= 2 = TwoPower (wordToInt k1) mempty mempty: combine xs (y:ys) + -- unPrime p1 == 2 = Two: combine xs (y:ys) + -- OddPrime p2 1 _g a <- y, p1 == p2 = + -- OddPrime p2 k1 (generator p2 k1) a: combine xs ys + -- -- TODO: generator p2 k1 will be g or g + p2, and we already know g is a primroot mod p + -- -- so should be able to save work instead of running generator + -- OddPrime p2 _ g a <- y, p1 == p2 = + -- OddPrime p2 k1 g a: combine xs ys + -- otherwise = OddPrime p1 k1 (generator p1 k1) mempty: combine xs (y:ys) + plain :: [Template] -> [DirichletFactor] + plain = undefined + -- plain [] = [] + -- plain f@((p,k):xs) = case (unPrime p, k) of + -- (2,1) -> Two: map rest xs + -- (2,_) -> TwoPower (wordToInt k) mempty mempty: map rest xs + -- _ -> map rest f + newFactor :: Template -> DirichletFactor + newFactor TwoTemplate = Two + newFactor (TwoPTemplate k _) = TwoPower k mempty mempty + newFactor (OddTemplate p k g _) = OddPrime p k g mempty + -- rest (p,k) = OddPrime p k (generator p k) mempty -- | The gives a real Dirichlet -- character for odd moduli. @@ -396,10 +408,10 @@ jacobiCharacter = if odd n else Nothing where n = natVal (Proxy :: Proxy n) go :: Template -> DirichletFactor - go TwoTemplate{} = error "internal error in jacobiCharacter: please report this as a bug" - -- every factor of n should be odd go (OddTemplate p k g _) = OddPrime p k g $ toRootOfUnity (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`. @@ -412,6 +424,7 @@ isRealCharacter t@(Generated xs) = if all real xs then Just (RealChar t) else No 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 evaluate/generalEval -- and thus avoid using discrete log calculations: consider the order of m @@ -429,15 +442,15 @@ toRealFunction (RealChar chi) m = case generalEval chi (fromIntegral m) of -- | 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 = removeTwo (factorise n) == map getPP xs + where correctDecomposition = factorise n == map getPP xs getPP (TwoPower k _ _) = (two, fromIntegral k) getPP (OddPrime p k _ _) = (p, k) - removeTwo ((unPrime -> 2,1):ys) = ys - removeTwo ys = ys - correctPrimitiveRoot TwoPower{} = True + getPP Two = (two,1) correctPrimitiveRoot (OddPrime p k g _) = g == generator p k + correctPrimitiveRoot _ = True validValued (TwoPower k a b) = a <> a == mempty && (k-2) `stimes` b == mempty validValued (OddPrime _ k _ a) = k `stimes` a == mempty + validValued Two = True n = natVal (Proxy :: Proxy n) two = head primes -- lazy way to get Prime 2 @@ -512,6 +525,7 @@ allEval (Generated xs) = V.generate (fromIntegral n) func 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 (fromIntegral -> g) a) = (modulus, w) where p' = unPrime p diff --git a/Math/NumberTheory/Moduli/Sqrt.hs b/Math/NumberTheory/Moduli/Sqrt.hs index 45347cba6..93cf6d54f 100644 --- a/Math/NumberTheory/Moduli/Sqrt.hs +++ b/Math/NumberTheory/Moduli/Sqrt.hs @@ -21,6 +21,7 @@ module Math.NumberTheory.Moduli.Sqrt -- * Jacobi symbol , JacobiSymbol(..) , jacobi + , symbolToIntegral ) where import Control.Monad (liftM2) diff --git a/test-suite/Math/NumberTheory/DirichletCharactersTests.hs b/test-suite/Math/NumberTheory/DirichletCharactersTests.hs index 39882a2d5..11a139a6d 100644 --- a/test-suite/Math/NumberTheory/DirichletCharactersTests.hs +++ b/test-suite/Math/NumberTheory/DirichletCharactersTests.hs @@ -31,10 +31,9 @@ import GHC.TypeNats.Compat (SomeNat(..), someNatVal, KnownNat, natVal) import Math.NumberTheory.ArithmeticFunctions (totient) import Math.NumberTheory.DirichletCharacters -import qualified Math.NumberTheory.Moduli.Jacobi as J +import qualified Math.NumberTheory.Moduli.Sqrt as J import Math.NumberTheory.Moduli.Class (SomeMod(..), modulo) import Math.NumberTheory.TestUtils (testSmallAndQuick, Positive(..)) -import Math.NumberTheory.Primes rootOfUnityTest :: Integer -> Positive Integer -> Bool rootOfUnityTest n (Positive d) = toComplex ((d `div` gcd n d) `stimes` toRootOfUnity (n % d)) == (1 :: Complex Double) From ffb15378b1e0226c6af31bba469e6b1c70a17125 Mon Sep 17 00:00:00 2001 From: Bhavik Mehta Date: Mon, 6 Jan 2020 04:01:17 +0000 Subject: [PATCH 39/65] Correct implementation of induced characters --- Math/NumberTheory/DirichletCharacters.hs | 45 +++++++------------ .../NumberTheory/DirichletCharactersTests.hs | 31 +++++++------ 2 files changed, 34 insertions(+), 42 deletions(-) diff --git a/Math/NumberTheory/DirichletCharacters.hs b/Math/NumberTheory/DirichletCharacters.hs index cb96867a8..3e27b89ce 100644 --- a/Math/NumberTheory/DirichletCharacters.hs +++ b/Math/NumberTheory/DirichletCharacters.hs @@ -58,7 +58,7 @@ import Data.Bits (Bits(..)) import Data.Complex (Complex, cis) import Data.Foldable (for_) import Data.Functor.Identity (Identity(..)) -import Data.List (mapAccumL, foldl') +import Data.List (mapAccumL, foldl', sort) import Data.Proxy (Proxy(..)) import Data.Ratio (Rational, Ratio, (%), numerator, denominator) import Data.Semigroup (Semigroup(..), Product(..)) @@ -147,7 +147,7 @@ toRootOfUnity q = RootOfUnity ((n `rem` d) % d) -- 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. +-- | 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 * fromIntegral k) @@ -328,10 +328,10 @@ templateFromCharacter (Generated t) = traverse go t -- see issue #154 mkTemplate :: Natural -> (Product Natural, [Template]) -mkTemplate = go . factorise +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 + 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) @@ -357,15 +357,14 @@ 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, a multiplicative function on \(\mathbb{Z}/d\mathbb{Z}\) +-- 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 --- >>> chi = fromIndex 5 :: DirichletCharacter 45 +-- >>> chi = indexToChar 5 :: DirichletCharacter 45 -- >>> chi2 = induced @135 chi -- >>> :t chi2 -- 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)) @@ -375,25 +374,15 @@ induced (Generated start) = if n `rem` d == 0 combine :: [Template] -> [DirichletFactor] -> [DirichletFactor] combine [] _ = [] combine ts [] = map newFactor ts - combine (t:xs) (y:ys) = undefined - -- TODO: consider tidying - -- unPrime p1 == 2, TwoPower _ a b <- y = TwoPower (wordToInt k1) a b: combine xs ys - -- unPrime p1 == 2, k1 >= 2 = TwoPower (wordToInt k1) mempty mempty: combine xs (y:ys) - -- unPrime p1 == 2 = Two: combine xs (y:ys) - -- OddPrime p2 1 _g a <- y, p1 == p2 = - -- OddPrime p2 k1 (generator p2 k1) a: combine xs ys - -- -- TODO: generator p2 k1 will be g or g + p2, and we already know g is a primroot mod p - -- -- so should be able to save work instead of running generator - -- OddPrime p2 _ g a <- y, p1 == p2 = - -- OddPrime p2 k1 g a: combine xs ys - -- otherwise = OddPrime p1 k1 (generator p1 k1) mempty: combine xs (y:ys) - plain :: [Template] -> [DirichletFactor] - plain = undefined - -- plain [] = [] - -- plain f@((p,k):xs) = case (unPrime p, k) of - -- (2,1) -> Two: map rest xs - -- (2,_) -> TwoPower (wordToInt k) mempty mempty: map rest xs - -- _ -> map rest f + 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 @@ -442,7 +431,7 @@ toRealFunction (RealChar chi) m = case generalEval chi (fromIntegral m) of -- | 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 = factorise n == map getPP xs + where correctDecomposition = sort (factorise n) == map getPP xs getPP (TwoPower k _ _) = (two, fromIntegral k) getPP (OddPrime p k _ _) = (p, k) getPP Two = (two,1) diff --git a/test-suite/Math/NumberTheory/DirichletCharactersTests.hs b/test-suite/Math/NumberTheory/DirichletCharactersTests.hs index 11a139a6d..76f5d06d5 100644 --- a/test-suite/Math/NumberTheory/DirichletCharactersTests.hs +++ b/test-suite/Math/NumberTheory/DirichletCharactersTests.hs @@ -102,19 +102,7 @@ realityCheck chi = isJust (isRealCharacter chi) == isReal' where isReal' = and [real (generalEval chi t) | t <- [minBound..maxBound]] real Zero = True real (NonZero t) = t <> t == mempty - --- | Induced characters agree with the original character. -inducedCheck :: forall d. KnownNat d => DirichletCharacter d -> Positive Natural -> Natural -> Bool -inducedCheck chi (Positive k) i = - case someNatVal (d*k) of - SomeNat (Proxy :: Proxy n) -> - case induced @n chi of - Just chi2 -> if (fromIntegral i) `gcd` (d*k) > 0 - then True - else generalEval chi (fromIntegral i) == generalEval chi2 (fromIntegral i) - Nothing -> False - where d = natVal @d Proxy - + -- | The jacobi character agrees with the jacobi symbol jacobiCheck :: Positive Natural -> Bool jacobiCheck (Positive n) = @@ -129,6 +117,21 @@ jacobiCheck (Positive n) = allEvalCheck :: forall n. KnownNat n => DirichletCharacter n -> Bool allEvalCheck chi = V.generate (fromIntegral $ natVal @n Proxy) (generalEval chi . fromIntegral) == allEval 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) (allEval chi))) (allEval 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 +-- TODO: there should be a stronger check on what happens when you induce from 1 + -- | Primitive checker is correct (in both directions) -- primitiveCheck :: forall n. KnownNat n => DirichletCharacter n -> Bool -- primitiveCheck = if n > 5 @@ -153,7 +156,7 @@ testSuite = testGroup "DirichletCharacters" , testSmallAndQuick "Orthogonality relation 2" orthogonality2 , testSmallAndQuick "Real character checking is valid" (dirCharProperty realityCheck) , testSmallAndQuick "Jacobi character matches symbol" jacobiCheck - , testSmallAndQuick "Induced character is correct" (dirCharProperty inducedCheck) , testSmallAndQuick "Bulk evaluation matches pointwise" (dirCharProperty allEvalCheck) + , testSmallAndQuick "Induced character is correct" (dirCharProperty inducedCheck) -- , testSmallAndQuick "Primitive character checking is valid" (dirCharProperty primitiveCheck) ] From 86923f65a8288fe5fa390bca33d9c5e5abb474dc Mon Sep 17 00:00:00 2001 From: Bhavik Mehta Date: Mon, 6 Jan 2020 18:33:28 +0000 Subject: [PATCH 40/65] Fix primitive testing --- Math/NumberTheory/DirichletCharacters.hs | 49 +++++++++++++------ .../NumberTheory/DirichletCharactersTests.hs | 25 +++++----- 2 files changed, 46 insertions(+), 28 deletions(-) diff --git a/Math/NumberTheory/DirichletCharacters.hs b/Math/NumberTheory/DirichletCharacters.hs index 3e27b89ce..c618fa16f 100644 --- a/Math/NumberTheory/DirichletCharacters.hs +++ b/Math/NumberTheory/DirichletCharacters.hs @@ -41,14 +41,19 @@ module Math.NumberTheory.DirichletCharacters -- ** Special Dirichlet characters , principalChar , isPrincipal - , induced - , isPrimitive + , orderChar -- ** Real Dirichlet characters , RealCharacter , isRealCharacter , getRealChar , toRealFunction , jacobiCharacter + -- ** Primitive characters + , PrimitiveCharacter + , isPrimitive + , getPrimitiveCharacter + , induced + , makePrimitive -- * Debugging , validChar ) where @@ -441,23 +446,37 @@ validChar (Generated xs) = correctDecomposition && all correctPrimitiveRoot xs & validValued (OddPrime _ k _ a) = k `stimes` a == mempty validValued Two = True n = natVal (Proxy :: Proxy n) - two = head primes -- lazy way to get Prime 2 + two = toEnum 1 -- lazy way to get Prime 2 --- | Get the order of the character, and the maximal possible order of a character of this modulus. --- The second term is the maximal order, and is carmichael(n) and is easily calculated from the --- factor group breakdown we have. --- orderChar :: DirichletCharacter n -> (Integer, Natural) --- orderChar (Generated xs) = foldl' combine (1,1) $ map orderFactor xs --- where orderFactor (TwoPower k (RootOfUnity a) (RootOfUnity b)) = (denominator a `lcm` denominator b, bit (k-1)) --- orderFactor (OddPrime (unPrime -> p) k _ (RootOfUnity a)) = (denominator a, p^(k-1)*(p-1)) --- combine (o1,n1) (o2,n2) = (lcm o1 o2, lcm n1 n2) +-- | Get the order of the Dirichlet Character. +-- TODO: test this +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 . +-- TODO: turn this into a smart constructor for PrimitiveCharacter isPrimitive :: DirichletCharacter n -> Bool -isPrimitive = undefined --- TODO: this isn't correct. figure out a correct version and write it --- isPrimitive chi = toInteger maxOrder == order --- where (order, maxOrder) = orderChar chi +isPrimitive (Generated xs) = all primitive xs + 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 TODO +newtype PrimitiveCharacter n = PrimitiveCharacter { -- | Extract the character itself from a `PrimitiveCharacter`. + getPrimitiveCharacter :: DirichletCharacter n + } + +-- TODO +makePrimitive :: DirichletCharacter n -> Some PrimitiveCharacter +makePrimitive (Generated _) = Some (PrimitiveCharacter undefined) -- | Similar to Maybe, but with different Semigroup and Monoid instances. data OrZero a = Zero | NonZero !a diff --git a/test-suite/Math/NumberTheory/DirichletCharactersTests.hs b/test-suite/Math/NumberTheory/DirichletCharactersTests.hs index 76f5d06d5..f407b8da3 100644 --- a/test-suite/Math/NumberTheory/DirichletCharactersTests.hs +++ b/test-suite/Math/NumberTheory/DirichletCharactersTests.hs @@ -29,7 +29,7 @@ import qualified Data.Vector as V import GHC.TypeNats.Compat (SomeNat(..), someNatVal, KnownNat, natVal) -import Math.NumberTheory.ArithmeticFunctions (totient) +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) @@ -102,7 +102,7 @@ realityCheck chi = isJust (isRealCharacter chi) == isReal' where isReal' = and [real (generalEval chi t) | t <- [minBound..maxBound]] real Zero = True real (NonZero t) = t <> t == mempty - + -- | The jacobi character agrees with the jacobi symbol jacobiCheck :: Positive Natural -> Bool jacobiCheck (Positive n) = @@ -133,16 +133,15 @@ inducedCheck chi (Positive k) = -- TODO: there should be a stronger check on what happens when you induce from 1 -- | Primitive checker is correct (in both directions) --- primitiveCheck :: forall n. KnownNat n => DirichletCharacter n -> Bool --- primitiveCheck = if n > 5 --- then (==) <$> isPrimitive <*> isPrimitive' --- else const True --- where isPrimitive' chi = not $ any (periodic (allEval chi)) primeFactors --- n = fromIntegral (natVal @n Proxy) --- primeFactors = map (unPrime . fst) $ factorise n --- periodic v k = and [allEqual [v V.! j | j <- [i,i + n `div` k .. n-1]] | i <- [0..k-1]] --- allEqual :: Eq a => [a] -> Bool --- allEqual = and . (zipWith (==) <*> tail) +primitiveCheck :: forall n. KnownNat n => DirichletCharacter n -> Bool +primitiveCheck chi = if n > 5 + then isPrimitive chi == isPrimitive' + else True + where isPrimitive' = all testModulus possibleModuli + n = fromIntegral (natVal @n Proxy) :: Int + possibleModuli = init (divisorsList n) + table = allEval chi + testModulus d = not $ null [a | a <- [1..n-1], gcd a n == 1, a `mod` d == 1 `mod` d, table V.! a /= mempty] testSuite :: TestTree testSuite = testGroup "DirichletCharacters" @@ -158,5 +157,5 @@ testSuite = testGroup "DirichletCharacters" , testSmallAndQuick "Jacobi character matches symbol" jacobiCheck , testSmallAndQuick "Bulk evaluation matches pointwise" (dirCharProperty allEvalCheck) , testSmallAndQuick "Induced character is correct" (dirCharProperty inducedCheck) - -- , testSmallAndQuick "Primitive character checking is valid" (dirCharProperty primitiveCheck) + , testSmallAndQuick "Primitive character checking is valid" (dirCharProperty primitiveCheck) ] From 8fa79812fc868d46013a490c5831f5cd2e7c846a Mon Sep 17 00:00:00 2001 From: Bhavik Mehta Date: Mon, 6 Jan 2020 19:53:54 +0000 Subject: [PATCH 41/65] Attempted bug fix --- Math/NumberTheory/DirichletCharacters.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Math/NumberTheory/DirichletCharacters.hs b/Math/NumberTheory/DirichletCharacters.hs index c618fa16f..2dc4929b5 100644 --- a/Math/NumberTheory/DirichletCharacters.hs +++ b/Math/NumberTheory/DirichletCharacters.hs @@ -504,7 +504,7 @@ instance Semigroup a => Semigroup (OrZero a) where NonZero a <> NonZero b = NonZero (a <> b) _ <> _ = Zero -instance Monoid a => Monoid (OrZero a) where +instance (Semigroup a, Monoid a) => Monoid (OrZero a) where mempty = NonZero mempty mappend = (<>) From 1a347c161a6dccba9d57fec248aba2596321c6cc Mon Sep 17 00:00:00 2001 From: Bhavik Mehta Date: Mon, 6 Jan 2020 20:05:32 +0000 Subject: [PATCH 42/65] attempted bug fix 2 --- Math/NumberTheory/DirichletCharacters.hs | 3 --- 1 file changed, 3 deletions(-) diff --git a/Math/NumberTheory/DirichletCharacters.hs b/Math/NumberTheory/DirichletCharacters.hs index 2dc4929b5..2bbeff76d 100644 --- a/Math/NumberTheory/DirichletCharacters.hs +++ b/Math/NumberTheory/DirichletCharacters.hs @@ -493,9 +493,6 @@ instance Applicative OrZero where NonZero f <*> m = fmap f m Zero <*> _ = Zero - liftA2 f (NonZero x) (NonZero y) = NonZero (f x y) - liftA2 _ _ _ = Zero - NonZero _ *> m = m Zero *> _ = Zero From 864b88d1b6effc24a5187facaab05ee4c33279db Mon Sep 17 00:00:00 2001 From: Bhavik Mehta Date: Mon, 6 Jan 2020 22:23:49 +0000 Subject: [PATCH 43/65] Misc fixups --- Math/NumberTheory/DirichletCharacters.hs | 17 ++++++++--------- .../NumberTheory/DirichletCharactersTests.hs | 3 +-- 2 files changed, 9 insertions(+), 11 deletions(-) diff --git a/Math/NumberTheory/DirichletCharacters.hs b/Math/NumberTheory/DirichletCharacters.hs index 2bbeff76d..2334c9314 100644 --- a/Math/NumberTheory/DirichletCharacters.hs +++ b/Math/NumberTheory/DirichletCharacters.hs @@ -201,11 +201,10 @@ evalFactor m = discreteLogarithmPP p k a (m `rem` p^k) `stimes` b TwoPower k s b -> (if testBit m 1 then s else mempty) <> lambda m'' k `stimes` b - where m' = m .&. kBits + where m' = m .&. (bit k - 1) m'' = if testBit m 1 then bit k - m' else m' - kBits = bit k - 1 Two -> mempty -- | A character can evaluate to a root of unity or zero: represented by @Nothing@. @@ -442,8 +441,8 @@ validChar (Generated xs) = correctDecomposition && all correctPrimitiveRoot xs & getPP Two = (two,1) correctPrimitiveRoot (OddPrime p k g _) = g == generator p k correctPrimitiveRoot _ = True - validValued (TwoPower k a b) = a <> a == mempty && (k-2) `stimes` b == mempty - validValued (OddPrime _ k _ a) = k `stimes` a == mempty + 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 = toEnum 1 -- lazy way to get Prime 2 @@ -458,8 +457,8 @@ orderChar (Generated xs) = foldl' lcm 1 $ map orderFactor xs -- | Test if a Dirichlet character is . -- TODO: turn this into a smart constructor for PrimitiveCharacter -isPrimitive :: DirichletCharacter n -> Bool -isPrimitive (Generated xs) = all primitive xs +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 @@ -469,7 +468,8 @@ isPrimitive (Generated xs) = all primitive xs primitive (TwoPower 2 a _) = a /= mempty primitive (TwoPower k _ b) = (bit (k-3) :: Integer) `stimes` b /= mempty --- | A Dirichlet character is primitive if TODO +-- | 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`. getPrimitiveCharacter :: DirichletCharacter n } @@ -557,11 +557,10 @@ allEval (Generated xs) = V.generate (fromIntegral n) func f m | even m = Zero | otherwise = NonZero ((if testBit m 1 then a else mempty) <> lambda (toInteger m'') k `stimes` b) - where m' = m .&. kBits + where m' = m .&. (bit k - 1) m'' = if testBit m 1 then bit k - m' else m' - kBits = bit k - 1 -- somewhere between unfoldr and iterate iterateMaybe :: (a -> Maybe a) -> a -> [a] diff --git a/test-suite/Math/NumberTheory/DirichletCharactersTests.hs b/test-suite/Math/NumberTheory/DirichletCharactersTests.hs index f407b8da3..ebed63e4b 100644 --- a/test-suite/Math/NumberTheory/DirichletCharactersTests.hs +++ b/test-suite/Math/NumberTheory/DirichletCharactersTests.hs @@ -130,12 +130,11 @@ inducedCheck chi (Positive k) = matchedValue i x1 x2 = if gcd (fromIntegral i) (d*k) > 1 then x2 == Zero else x2 == x1 --- TODO: there should be a stronger check on what happens when you induce from 1 -- | Primitive checker is correct (in both directions) primitiveCheck :: forall n. KnownNat n => DirichletCharacter n -> Bool primitiveCheck chi = if n > 5 - then isPrimitive chi == isPrimitive' + then isJust (isPrimitive chi) == isPrimitive' else True where isPrimitive' = all testModulus possibleModuli n = fromIntegral (natVal @n Proxy) :: Int From e55efd4a86f474a461cda25c5fca3d3b26762a37 Mon Sep 17 00:00:00 2001 From: Bhavik Mehta Date: Thu, 9 Jan 2020 04:29:42 +0000 Subject: [PATCH 44/65] More primitive chars API and real eval test --- Math/NumberTheory/DirichletCharacters.hs | 54 ++++++++++++++----- .../NumberTheory/DirichletCharactersTests.hs | 45 ++++++++++++---- 2 files changed, 78 insertions(+), 21 deletions(-) diff --git a/Math/NumberTheory/DirichletCharacters.hs b/Math/NumberTheory/DirichletCharacters.hs index 2334c9314..ee2d8628f 100644 --- a/Math/NumberTheory/DirichletCharacters.hs +++ b/Math/NumberTheory/DirichletCharacters.hs @@ -14,6 +14,8 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE KindSignatures #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeApplications #-} module Math.NumberTheory.DirichletCharacters ( @@ -54,31 +56,33 @@ module Math.NumberTheory.DirichletCharacters , getPrimitiveCharacter , induced , makePrimitive + , WithNat(..) -- * Debugging , validChar ) where import Control.Applicative (Applicative(..)) import Data.Bits (Bits(..)) -import Data.Complex (Complex, cis) +import Data.Complex (Complex(..), cis) import Data.Foldable (for_) import Data.Functor.Identity (Identity(..)) -import Data.List (mapAccumL, foldl', sort) +import Data.List (mapAccumL, foldl', sort, find) +import Data.Maybe (mapMaybe) import Data.Proxy (Proxy(..)) import Data.Ratio (Rational, Ratio, (%), numerator, denominator) import Data.Semigroup (Semigroup(..), Product(..)) import qualified Data.Vector as V import qualified Data.Vector.Mutable as MV import Data.Vector (Vector, (!)) -import GHC.TypeNats.Compat (Nat, natVal) +import GHC.TypeNats.Compat (Nat, SomeNat(..), natVal, someNatVal) import Numeric.Natural (Natural) import Math.NumberTheory.ArithmeticFunctions (totient) import Math.NumberTheory.Moduli.Class (KnownNat, Mod, getVal) -import Math.NumberTheory.Moduli.Singleton +import Math.NumberTheory.Moduli.Singleton (Some(..), cyclicGroupFromFactors) import Math.NumberTheory.Moduli.Multiplicative import Math.NumberTheory.Powers.Modular (powMod) -import Math.NumberTheory.Primes +import Math.NumberTheory.Primes (Prime(..), UniqueFactorisation, factorise) import Math.NumberTheory.Utils.FromIntegral (wordToInt) -- | A Dirichlet character mod \(n\) is a group homomorphism from \((\mathbb{Z}/n\mathbb{Z})^*\) @@ -167,7 +171,11 @@ instance Monoid RootOfUnity where -- @[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 = cis . (2*pi*) . fromRational . fromRootOfUnity +toComplex (RootOfUnity t) + | t == 1/2 = (-1) :+ 0 + | t == 1/4 = 0 :+ 1 + | t == 3/4 = 0 :+ (-1) + | otherwise = cis . (2*pi*) . fromRational $ t -- | For primes, define the canonical primitive root as the smallest such. For prime powers \(p^k\), -- either the smallest primitive root \(g\) mod \(p\) works, or \(g+p\) works. @@ -410,6 +418,7 @@ jacobiCharacter = if odd n 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) @@ -423,7 +432,7 @@ isRealCharacter t@(Generated xs) = if all real xs then Just (RealChar t) else No -- 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 -> Natural -> Int +toRealFunction :: (Integral a, KnownNat n) => RealCharacter n -> a -> Int toRealFunction (RealChar chi) m = case generalEval chi (fromIntegral m) of Zero -> 0 NonZero t | t == mempty -> 1 @@ -456,7 +465,6 @@ orderChar (Generated xs) = foldl' lcm 1 $ map orderFactor xs orderFactor Two = 1 -- | Test if a Dirichlet character is . --- TODO: turn this into a smart constructor for PrimitiveCharacter isPrimitive :: DirichletCharacter n -> Maybe (PrimitiveCharacter n) isPrimitive t@(Generated xs) = if all primitive xs then Just (PrimitiveCharacter t) else Nothing where primitive :: DirichletFactor -> Bool @@ -473,10 +481,32 @@ isPrimitive t@(Generated xs) = if all primitive xs then Just (PrimitiveCharacter newtype PrimitiveCharacter n = PrimitiveCharacter { -- | Extract the character itself from a `PrimitiveCharacter`. getPrimitiveCharacter :: DirichletCharacter n } - --- TODO -makePrimitive :: DirichletCharacter n -> Some PrimitiveCharacter -makePrimitive (Generated _) = Some (PrimitiveCharacter undefined) + deriving Eq + +data WithNat (a :: Nat -> *) 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 @m (PrimitiveCharacter (Generated ys)) + 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. data OrZero a = Zero | NonZero !a diff --git a/test-suite/Math/NumberTheory/DirichletCharactersTests.hs b/test-suite/Math/NumberTheory/DirichletCharactersTests.hs index ebed63e4b..ea3e7b0c8 100644 --- a/test-suite/Math/NumberTheory/DirichletCharactersTests.hs +++ b/test-suite/Math/NumberTheory/DirichletCharactersTests.hs @@ -13,21 +13,23 @@ {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE GADTs #-} 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.Ratio -import Numeric.Natural import Data.Semigroup -import Data.Complex -import Data.List (genericLength) -import Data.Maybe (isJust) +import Numeric.Natural import qualified Data.Vector as V -import GHC.TypeNats.Compat (SomeNat(..), someNatVal, KnownNat, natVal) +import GHC.TypeNats.Compat (SomeNat(..), someNatVal, KnownNat, natVal, sameNat) +import Data.Type.Equality import Math.NumberTheory.ArithmeticFunctions (totient, divisorsList) import Math.NumberTheory.DirichletCharacters @@ -60,6 +62,13 @@ dirCharProperty test (Positive n) i = 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) = @@ -103,6 +112,10 @@ realityCheck chi = isJust (isRealCharacter chi) == isReal' 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) == toFunction (getRealChar chi) i + -- | The jacobi character agrees with the jacobi symbol jacobiCheck :: Positive Natural -> Bool jacobiCheck (Positive n) = @@ -112,7 +125,6 @@ jacobiCheck (Positive n) = Just chi -> and [toRealFunction chi (fromIntegral j) == J.symbolToIntegral (J.jacobi j (2*n+1)) | j <- [0..2*n]] _ -> False - -- | Bulk evaluation agrees with pointwise evaluation allEvalCheck :: forall n. KnownNat n => DirichletCharacter n -> Bool allEvalCheck chi = V.generate (fromIntegral $ natVal @n Proxy) (generalEval chi . fromIntegral) == allEval chi @@ -133,15 +145,27 @@ inducedCheck chi (Positive k) = -- | Primitive checker is correct (in both directions) primitiveCheck :: forall n. KnownNat n => DirichletCharacter n -> Bool -primitiveCheck chi = if n > 5 - then isJust (isPrimitive chi) == isPrimitive' - else True +primitiveCheck chi = isJust (isPrimitive chi) == isPrimitive' where isPrimitive' = all testModulus possibleModuli n = fromIntegral (natVal @n Proxy) :: Int possibleModuli = init (divisorsList n) table = allEval chi testModulus d = not $ null [a | a <- [1..n-1], gcd a n == 1, a `mod` d == 1 `mod` d, table V.! a /= mempty] +makePrimitiveCheck :: DirichletCharacter n -> Bool +makePrimitiveCheck chi = case makePrimitive chi of + WithNat chi' -> isJust (isPrimitive (getPrimitiveCharacter 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 (getPrimitiveCharacter chi') of + WithNat (chi'' :: PrimitiveCharacter n'') -> + case sameNat (Proxy :: Proxy n') (Proxy :: Proxy n'') of + Just Refl -> chi' == chi'' + Nothing -> False + testSuite :: TestTree testSuite = testGroup "DirichletCharacters" [ testSmallAndQuick "RootOfUnity contains roots of unity" rootOfUnityTest @@ -153,8 +177,11 @@ testSuite = testGroup "DirichletCharacters" , testSmallAndQuick "Orthogonality relation 1" (dirCharProperty orthogonality1) , testSmallAndQuick "Orthogonality relation 2" orthogonality2 , testSmallAndQuick "Real character checking is valid" (dirCharProperty realityCheck) + , testSmallAndQuick "Real character evaluation is accurate" (realCharProperty realEvalCheck) , testSmallAndQuick "Jacobi character matches symbol" jacobiCheck , testSmallAndQuick "Bulk evaluation matches pointwise" (dirCharProperty allEvalCheck) , testSmallAndQuick "Induced character is correct" (dirCharProperty inducedCheck) , testSmallAndQuick "Primitive character checking is valid" (dirCharProperty primitiveCheck) + , testSmallAndQuick "makePrimitive produces primitive character" (dirCharProperty makePrimitiveCheck) + , testSmallAndQuick "makePrimitive is idempotent" (dirCharProperty makePrimitiveIdem) ] From 0a296071663771d4f9b032c793cb5b569b0ae71e Mon Sep 17 00:00:00 2001 From: Bhavik Mehta Date: Thu, 9 Jan 2020 04:37:57 +0000 Subject: [PATCH 45/65] remove a type application --- Math/NumberTheory/DirichletCharacters.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/Math/NumberTheory/DirichletCharacters.hs b/Math/NumberTheory/DirichletCharacters.hs index ee2d8628f..077943cce 100644 --- a/Math/NumberTheory/DirichletCharacters.hs +++ b/Math/NumberTheory/DirichletCharacters.hs @@ -15,7 +15,6 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE TypeApplications #-} module Math.NumberTheory.DirichletCharacters ( @@ -490,7 +489,7 @@ data WithNat (a :: Nat -> *) where makePrimitive :: DirichletCharacter n -> WithNat PrimitiveCharacter makePrimitive (Generated xs) = case someNatVal (product mods) of - SomeNat (Proxy :: Proxy m) -> WithNat @m (PrimitiveCharacter (Generated ys)) + 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 From 11ce7a46d283d3e09651bca1f58880dd43ec0fde Mon Sep 17 00:00:00 2001 From: Bhavik Mehta Date: Thu, 9 Jan 2020 04:47:24 +0000 Subject: [PATCH 46/65] Use Monoid.Ap instead of OrZero --- Math/NumberTheory/DirichletCharacters.hs | 50 ++++++++----------- .../NumberTheory/DirichletCharactersTests.hs | 1 + 2 files changed, 23 insertions(+), 28 deletions(-) diff --git a/Math/NumberTheory/DirichletCharacters.hs b/Math/NumberTheory/DirichletCharacters.hs index 077943cce..2d962c85d 100644 --- a/Math/NumberTheory/DirichletCharacters.hs +++ b/Math/NumberTheory/DirichletCharacters.hs @@ -15,6 +15,8 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE CPP #-} module Math.NumberTheory.DirichletCharacters ( @@ -25,7 +27,7 @@ module Math.NumberTheory.DirichletCharacters , fromRootOfUnity , toComplex -- * An absorbing semigroup - , OrZero(..) + , OrZero, pattern Zero, pattern NonZero , asNumber -- * Dirichlet characters , DirichletCharacter @@ -60,13 +62,15 @@ module Math.NumberTheory.DirichletCharacters , validChar ) where -import Control.Applicative (Applicative(..)) import Data.Bits (Bits(..)) import Data.Complex (Complex(..), cis) import Data.Foldable (for_) import Data.Functor.Identity (Identity(..)) import Data.List (mapAccumL, foldl', sort, find) import Data.Maybe (mapMaybe) +#if MIN_VERSION_base(4,12,0) +import Data.Monoid (Ap(..)) +#endif import Data.Proxy (Proxy(..)) import Data.Ratio (Rational, Ratio, (%), numerator, denominator) import Data.Semigroup (Semigroup(..), Product(..)) @@ -507,36 +511,26 @@ makePrimitive (Generated xs) = 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. -data OrZero a = Zero | NonZero !a - deriving (Eq) - --- | An equivalent `Functor` instance to `Maybe`. -instance Functor OrZero where - fmap _ Zero = Zero - fmap f (NonZero x) = NonZero (f x) - --- | An equivalent `Applicative` instance to `Maybe`. -instance Applicative OrZero where - pure = NonZero - NonZero f <*> m = fmap f m - Zero <*> _ = Zero +#if !MIN_VERSION_base(4,12,0) +newtype Ap f a = Ap { getApp :: f a } + deriving (Functor, Applicative, Monad) - NonZero _ *> m = m - Zero *> _ = Zero +instance (Applicative f, Semigroup a) => Semigroup (Ap f a) where + (<>) = liftA2 (<>) --- | `Zero` is an absorbing element for this semigroup -instance Semigroup a => Semigroup (OrZero a) where - NonZero a <> NonZero b = NonZero (a <> b) - _ <> _ = Zero - -instance (Semigroup a, Monoid a) => Monoid (OrZero a) where - mempty = NonZero mempty +instance (Applicative f, Monoid a) => Monoid (Ap f a) where + mempty = pure mempty mappend = (<>) +#endif + +-- | Similar to Maybe, but with different Semigroup and Monoid instances. +type OrZero a = Ap Maybe a +pattern Zero :: OrZero a +pattern Zero = Ap Nothing -instance Show a => Show (OrZero a) where - show Zero = "0" - show (NonZero x) = show 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. asNumber :: Num a => (b -> a) -> OrZero b -> a diff --git a/test-suite/Math/NumberTheory/DirichletCharactersTests.hs b/test-suite/Math/NumberTheory/DirichletCharactersTests.hs index ea3e7b0c8..e55e2885a 100644 --- a/test-suite/Math/NumberTheory/DirichletCharactersTests.hs +++ b/test-suite/Math/NumberTheory/DirichletCharactersTests.hs @@ -14,6 +14,7 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternSynonyms #-} module Math.NumberTheory.DirichletCharactersTests where From 57b2df0a05b6b7881fd0fa7b98c8d10c532cbc2e Mon Sep 17 00:00:00 2001 From: Bhavik Mehta Date: Thu, 9 Jan 2020 05:12:28 +0000 Subject: [PATCH 47/65] Create internal module --- Math/NumberTheory/DirichletCharacters.hs | 4 +- Math/NumberTheory/Moduli/Internal.hs | 163 +++++++++++++++++++++ Math/NumberTheory/Moduli/Multiplicative.hs | 105 +------------ arithmoi.cabal | 1 + 4 files changed, 168 insertions(+), 105 deletions(-) create mode 100644 Math/NumberTheory/Moduli/Internal.hs diff --git a/Math/NumberTheory/DirichletCharacters.hs b/Math/NumberTheory/DirichletCharacters.hs index 2d962c85d..0103c52ff 100644 --- a/Math/NumberTheory/DirichletCharacters.hs +++ b/Math/NumberTheory/DirichletCharacters.hs @@ -83,7 +83,8 @@ import Numeric.Natural (Natural) import Math.NumberTheory.ArithmeticFunctions (totient) import Math.NumberTheory.Moduli.Class (KnownNat, Mod, getVal) import Math.NumberTheory.Moduli.Singleton (Some(..), cyclicGroupFromFactors) -import Math.NumberTheory.Moduli.Multiplicative +import Math.NumberTheory.Moduli.Multiplicative (MultMod(..), isMultElement) +import Math.NumberTheory.Moduli.Internal (isPrimitiveRoot', discreteLogarithmPP) import Math.NumberTheory.Powers.Modular (powMod) import Math.NumberTheory.Primes (Prime(..), UniqueFactorisation, factorise) import Math.NumberTheory.Utils.FromIntegral (wordToInt) @@ -513,7 +514,6 @@ makePrimitive (Generated xs) = #if !MIN_VERSION_base(4,12,0) newtype Ap f a = Ap { getApp :: f a } - deriving (Functor, Applicative, Monad) instance (Applicative f, Semigroup a) => Semigroup (Ap f a) where (<>) = liftA2 (<>) diff --git a/Math/NumberTheory/Moduli/Internal.hs b/Math/NumberTheory/Moduli/Internal.hs new file mode 100644 index 000000000..fd3208069 --- /dev/null +++ b/Math/NumberTheory/Moduli/Internal.hs @@ -0,0 +1,163 @@ +-- | +-- Module: Math.NumberTheory.Moduli.Multiplicative +-- Copyright: (c) 2017 Andrew Lelechenko +-- Licence: MIT +-- Maintainer: Andrew Lelechenko +-- +-- Multiplicative groups of integers modulo m. +-- + +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} + +module Math.NumberTheory.Moduli.Internal + ( isPrimitiveRoot' + , discreteLogarithmPP + ) where + +import qualified Data.Map as M +import Data.Maybe +import Data.Mod +import Data.Proxy +import Data.Semigroup +import GHC.Integer.GMP.Internals +import GHC.TypeNats.Compat +import Numeric.Natural + +import Math.NumberTheory.ArithmeticFunctions +import Math.NumberTheory.Moduli.Chinese +import Math.NumberTheory.Moduli.Equations +import Math.NumberTheory.Moduli.Singleton +import Math.NumberTheory.Primes +import Math.NumberTheory.Powers.Modular +import Math.NumberTheory.Roots + +-- | This type represents elements of the multiplicative group mod m, i.e. +-- those elements which are coprime to m. Use @toMultElement@ to construct. +newtype MultMod m = MultMod { + multElement :: Mod m -- ^ 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 + mappend = (<>) + +instance KnownNat m => Bounded (MultMod m) where + minBound = MultMod 1 + maxBound = MultMod (-1) + +-- | 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 of m. +newtype PrimitiveRoot m = PrimitiveRoot + { unPrimitiveRoot :: MultMod m -- ^ Extract primitive root value. + } + deriving (Eq, Show) + +-- 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 + oddPrimeTest p g = let phi = totient p + pows = map (\pk -> phi `quot` unPrime (fst pk)) (factorise phi) + exps = map (\x -> powMod g x p) pows + in g /= 0 && gcd g p == 1 && all (/= 1) exps + oddPrimePowerTest p 1 g = oddPrimeTest p (g `mod` p) + oddPrimePowerTest p _ g = oddPrimeTest p (g `mod` p) && powMod g (p-1) (p*p) /= 1 + doubleOddPrimePowerTest p k g = odd g && oddPrimePowerTest p k g + +-- 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) + pkMinusPk1 = pkMinusOne * (p - 1) + c = (recipModInteger thetaA pkMinusOne * thetaB) `rem` pkMinusOne + result = fromJust $ chineseCoprime (baseSol, p-1) (c, pkMinusOne) + +-- compute the homomorphism theta given in https://math.stackexchange.com/a/1864495/418148 +{-# INLINE theta #-} +theta :: Integer -> Integer -> Integer -> Integer +theta p pkMinusOne a = (numerator `quot` pk) `rem` pkMinusOne + where + pk = pkMinusOne * p + p2kMinusOne = pkMinusOne * pk + numerator = (powModInteger a (pk - pkMinusOne) p2kMinusOne - 1) `rem` p2kMinusOne + +-- TODO: Use Pollig-Hellman to reduce the problem further into groups of prime order. +-- While Bach reduction simplifies the problem into groups of the form (Z/pZ)*, these +-- have non-prime order, and the Pollig-Hellman algorithm can reduce the problem into +-- smaller groups of prime order. +-- In addition, the gcd check before solveLinear is applied in Pollard below will be +-- made redundant, since n would be prime. +discreteLogarithmPrime :: Integer -> Integer -> Integer -> Natural +discreteLogarithmPrime p a b + | p < 100000000 = fromIntegral $ discreteLogarithmPrimeBSGS (fromInteger p) (fromInteger a) (fromInteger b) + | otherwise = discreteLogarithmPrimePollard p a b + +discreteLogarithmPrimeBSGS :: Int -> Int -> Int -> Int +discreteLogarithmPrimeBSGS p a b = head [i*m + j | (v,i) <- zip giants [0..m-1], j <- maybeToList (M.lookup v table)] + where + m = integerSquareRoot (p - 2) + 1 -- simple way of ceiling (sqrt (p-1)) + babies = iterate (.* a) 1 + table = M.fromList (zip babies [0..m-1]) + aInv = recipModInteger (toInteger a) (toInteger p) + bigGiant = fromInteger $ powModInteger aInv (toInteger m) (toInteger p) + giants = iterate (.* bigGiant) b + x .* y = x * y `rem` p + +-- TODO: Use more advanced walks, in order to reduce divisions, cf +-- https://maths-people.anu.edu.au/~brent/pd/rpb231.pdf +-- This will slightly improve the expected time to collision, and can reduce the +-- number of divisions performed. +discreteLogarithmPrimePollard :: Integer -> Integer -> Integer -> Natural +discreteLogarithmPrimePollard p a b = + case concatMap runPollard [(x,y) | x <- [0..n], y <- [0..n]] of + (t:_) -> fromInteger t + [] -> error ("discreteLogarithm: pollard's rho failed, please report this as a bug. inputs " ++ show [p,a,b]) + where + n = p-1 -- order of the cyclic group + halfN = n `quot` 2 + mul2 m = if m < halfN then m * 2 else m * 2 - n + sqrtN = integerSquareRoot n + step (xi,!ai,!bi) = case xi `rem` 3 of + 0 -> (xi*xi `rem` p, mul2 ai, mul2 bi) + 1 -> ( a*xi `rem` p, ai+1, bi) + _ -> ( b*xi `rem` p, ai, bi+1) + initialise (x,y) = (powModInteger a x n * powModInteger b y n `rem` n, x, y) + begin t = go (step t) (step (step t)) + check t = powModInteger a t p == b + go tort@(xi,ai,bi) hare@(x2i,a2i,b2i) + | xi == x2i, gcd (bi - b2i) n < sqrtN = case someNatVal (fromInteger n) of + SomeNat (Proxy :: Proxy n) -> map (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 diff --git a/Math/NumberTheory/Moduli/Multiplicative.hs b/Math/NumberTheory/Moduli/Multiplicative.hs index 1a50b3bd5..9723cf64e 100644 --- a/Math/NumberTheory/Moduli/Multiplicative.hs +++ b/Math/NumberTheory/Moduli/Multiplicative.hs @@ -10,6 +10,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE PatternSynonyms #-} module Math.NumberTheory.Moduli.Multiplicative ( -- * Multiplicative group @@ -28,22 +29,14 @@ module Math.NumberTheory.Moduli.Multiplicative import Control.Monad import Data.Constraint -import qualified Data.Map as M -import Data.Maybe import Data.Mod -import Data.Proxy import Data.Semigroup -import GHC.Integer.GMP.Internals import GHC.TypeNats.Compat import Numeric.Natural -import Math.NumberTheory.ArithmeticFunctions -import Math.NumberTheory.Moduli.Chinese -import Math.NumberTheory.Moduli.Equations +import Math.NumberTheory.Moduli.Internal import Math.NumberTheory.Moduli.Singleton import Math.NumberTheory.Primes -import Math.NumberTheory.Powers.Modular -import Math.NumberTheory.Roots -- | This type represents elements of the multiplicative group mod m, i.e. -- those elements which are coprime to m. Use @toMultElement@ to construct. @@ -86,27 +79,6 @@ newtype PrimitiveRoot m = PrimitiveRoot } deriving (Eq, Show) --- 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 - oddPrimeTest p g = let phi = totient p - pows = map (\pk -> phi `quot` unPrime (fst pk)) (factorise phi) - exps = map (\x -> powMod g x p) pows - in g /= 0 && gcd g p == 1 && all (/= 1) exps - oddPrimePowerTest p 1 g = oddPrimeTest p (g `mod` p) - oddPrimePowerTest p _ g = oddPrimeTest p (g `mod` p) && powMod g (p-1) (p*p) /= 1 - doubleOddPrimePowerTest p k g = odd g && oddPrimePowerTest p k g - -- | Check whether a given modular residue is -- a . -- @@ -150,76 +122,3 @@ discreteLogarithm cg (multElement . unPrimitiveRoot -> a) (multElement -> b) = c 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)* - --- 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) - pkMinusPk1 = pkMinusOne * (p - 1) - c = (recipModInteger thetaA pkMinusOne * thetaB) `rem` pkMinusOne - result = fromJust $ chineseCoprime (baseSol, p-1) (c, pkMinusOne) - --- compute the homomorphism theta given in https://math.stackexchange.com/a/1864495/418148 -{-# INLINE theta #-} -theta :: Integer -> Integer -> Integer -> Integer -theta p pkMinusOne a = (numerator `quot` pk) `rem` pkMinusOne - where - pk = pkMinusOne * p - p2kMinusOne = pkMinusOne * pk - numerator = (powModInteger a (pk - pkMinusOne) p2kMinusOne - 1) `rem` p2kMinusOne - --- TODO: Use Pollig-Hellman to reduce the problem further into groups of prime order. --- While Bach reduction simplifies the problem into groups of the form (Z/pZ)*, these --- have non-prime order, and the Pollig-Hellman algorithm can reduce the problem into --- smaller groups of prime order. --- In addition, the gcd check before solveLinear is applied in Pollard below will be --- made redundant, since n would be prime. -discreteLogarithmPrime :: Integer -> Integer -> Integer -> Natural -discreteLogarithmPrime p a b - | p < 100000000 = fromIntegral $ discreteLogarithmPrimeBSGS (fromInteger p) (fromInteger a) (fromInteger b) - | otherwise = discreteLogarithmPrimePollard p a b - -discreteLogarithmPrimeBSGS :: Int -> Int -> Int -> Int -discreteLogarithmPrimeBSGS p a b = head [i*m + j | (v,i) <- zip giants [0..m-1], j <- maybeToList (M.lookup v table)] - where - m = integerSquareRoot (p - 2) + 1 -- simple way of ceiling (sqrt (p-1)) - babies = iterate (.* a) 1 - table = M.fromList (zip babies [0..m-1]) - aInv = recipModInteger (toInteger a) (toInteger p) - bigGiant = fromInteger $ powModInteger aInv (toInteger m) (toInteger p) - giants = iterate (.* bigGiant) b - x .* y = x * y `rem` p - --- TODO: Use more advanced walks, in order to reduce divisions, cf --- https://maths-people.anu.edu.au/~brent/pd/rpb231.pdf --- This will slightly improve the expected time to collision, and can reduce the --- number of divisions performed. -discreteLogarithmPrimePollard :: Integer -> Integer -> Integer -> Natural -discreteLogarithmPrimePollard p a b = - case concatMap runPollard [(x,y) | x <- [0..n], y <- [0..n]] of - (t:_) -> fromInteger t - [] -> error ("discreteLogarithm: pollard's rho failed, please report this as a bug. inputs " ++ show [p,a,b]) - where - n = p-1 -- order of the cyclic group - halfN = n `quot` 2 - mul2 m = if m < halfN then m * 2 else m * 2 - n - sqrtN = integerSquareRoot n - step (xi,!ai,!bi) = case xi `rem` 3 of - 0 -> (xi*xi `rem` p, mul2 ai, mul2 bi) - 1 -> ( a*xi `rem` p, ai+1, bi) - _ -> ( b*xi `rem` p, ai, bi+1) - initialise (x,y) = (powModInteger a x n * powModInteger b y n `rem` n, x, y) - begin t = go (step t) (step (step t)) - check t = powModInteger a t p == b - go tort@(xi,ai,bi) hare@(x2i,a2i,b2i) - | xi == x2i, gcd (bi - b2i) n < sqrtN = case someNatVal (fromInteger n) of - SomeNat (Proxy :: Proxy n) -> map (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 diff --git a/arithmoi.cabal b/arithmoi.cabal index 5036d44d1..08229056f 100644 --- a/arithmoi.cabal +++ b/arithmoi.cabal @@ -67,6 +67,7 @@ library Math.NumberTheory.Moduli.Class Math.NumberTheory.Moduli.DiscreteLogarithm Math.NumberTheory.Moduli.Equations + Math.NumberTheory.Moduli.Internal Math.NumberTheory.Moduli.Jacobi Math.NumberTheory.Moduli.Multiplicative Math.NumberTheory.Moduli.PrimitiveRoot From ea781c5fb19eeafe756ace6a8aade32d9bc9a0bc Mon Sep 17 00:00:00 2001 From: Bhavik Mehta Date: Thu, 9 Jan 2020 05:21:34 +0000 Subject: [PATCH 48/65] try again to get it to compile --- Math/NumberTheory/DirichletCharacters.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/Math/NumberTheory/DirichletCharacters.hs b/Math/NumberTheory/DirichletCharacters.hs index 0103c52ff..15921d23b 100644 --- a/Math/NumberTheory/DirichletCharacters.hs +++ b/Math/NumberTheory/DirichletCharacters.hs @@ -10,6 +10,7 @@ -- {-# LANGUAGE DataKinds #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -513,7 +514,8 @@ makePrimitive (Generated xs) = worksb (_,phi) = phi `stimes` b == mempty #if !MIN_VERSION_base(4,12,0) -newtype Ap f a = Ap { getApp :: f a } +newtype Ap f a = Ap { getAp :: f a } + deriving (Functor, Applicative, Monad) instance (Applicative f, Semigroup a) => Semigroup (Ap f a) where (<>) = liftA2 (<>) From c1bc03e58113b8f1f2e03e6b51ea5cec3ab5a71d Mon Sep 17 00:00:00 2001 From: Bhavik Mehta Date: Thu, 9 Jan 2020 05:27:41 +0000 Subject: [PATCH 49/65] try again again to get it to compile --- Math/NumberTheory/DirichletCharacters.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/Math/NumberTheory/DirichletCharacters.hs b/Math/NumberTheory/DirichletCharacters.hs index 15921d23b..d96d75df7 100644 --- a/Math/NumberTheory/DirichletCharacters.hs +++ b/Math/NumberTheory/DirichletCharacters.hs @@ -63,6 +63,7 @@ module Math.NumberTheory.DirichletCharacters , validChar ) where +import Control.Applicative (Applicative(..)) import Data.Bits (Bits(..)) import Data.Complex (Complex(..), cis) import Data.Foldable (for_) From b7bd66312ff0cf820893db0fc6561336578f6f7b Mon Sep 17 00:00:00 2001 From: Bhavik Mehta Date: Thu, 9 Jan 2020 05:31:21 +0000 Subject: [PATCH 50/65] try again again again to get it to compile --- Math/NumberTheory/DirichletCharacters.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/Math/NumberTheory/DirichletCharacters.hs b/Math/NumberTheory/DirichletCharacters.hs index d96d75df7..0251aba58 100644 --- a/Math/NumberTheory/DirichletCharacters.hs +++ b/Math/NumberTheory/DirichletCharacters.hs @@ -63,7 +63,7 @@ module Math.NumberTheory.DirichletCharacters , validChar ) where -import Control.Applicative (Applicative(..)) +import Control.Applicative (Applicative(..), liftA2) import Data.Bits (Bits(..)) import Data.Complex (Complex(..), cis) import Data.Foldable (for_) @@ -516,12 +516,12 @@ makePrimitive (Generated xs) = #if !MIN_VERSION_base(4,12,0) newtype Ap f a = Ap { getAp :: f a } - deriving (Functor, Applicative, Monad) + deriving (Eq, Functor, Applicative, Monad) instance (Applicative f, Semigroup a) => Semigroup (Ap f a) where (<>) = liftA2 (<>) -instance (Applicative f, Monoid a) => Monoid (Ap f a) where +instance (Applicative f, Semigroup a, Monoid a) => Monoid (Ap f a) where mempty = pure mempty mappend = (<>) #endif From 4dffb79a23a3e19fabc11319caab19e82cb36c76 Mon Sep 17 00:00:00 2001 From: Bhavik Mehta Date: Thu, 9 Jan 2020 06:01:56 +0000 Subject: [PATCH 51/65] [skip ci] Clean up TODOs --- Math/NumberTheory/DirichletCharacters.hs | 4 ---- 1 file changed, 4 deletions(-) diff --git a/Math/NumberTheory/DirichletCharacters.hs b/Math/NumberTheory/DirichletCharacters.hs index 0251aba58..9563720c1 100644 --- a/Math/NumberTheory/DirichletCharacters.hs +++ b/Math/NumberTheory/DirichletCharacters.hs @@ -342,9 +342,6 @@ templateFromCharacter (Generated t) = traverse go t where m = bit (k-2) go Two = (Product 1, TwoTemplate) --- TODO (idea): Template is effectively a CyclicFactor of a generalised CyclicGroup... --- see issue #154 - mkTemplate :: Natural -> (Product Natural, [Template]) mkTemplate = go . sort . factorise where go :: [(Prime Natural, Word)] -> (Product Natural, [Template]) @@ -366,7 +363,6 @@ unroll t m = snd (mapAccumL func m t) func a (TwoPTemplate k n) = (b1, TwoPower k (toRootOfUnity $ a2 % 2) (toRootOfUnity $ b2 % n)) where (a1,a2) = quotRem a 2 (b1,b2) = quotRem a1 n - -- TODO: consider tidying func a TwoTemplate = (a, Two) -- | Test if a given Dirichlet character is prinicpal for its modulus: a principal character mod From 0a339496be8cd0c79d7ab90257df4dc7fccee0ea Mon Sep 17 00:00:00 2001 From: Bhavik Mehta Date: Fri, 10 Jan 2020 03:18:46 +0000 Subject: [PATCH 52/65] order test and remove comment --- Math/NumberTheory/Moduli/Multiplicative.hs | 2 -- test-suite/Math/NumberTheory/DirichletCharactersTests.hs | 5 +++++ 2 files changed, 5 insertions(+), 2 deletions(-) diff --git a/Math/NumberTheory/Moduli/Multiplicative.hs b/Math/NumberTheory/Moduli/Multiplicative.hs index 9723cf64e..af04f4653 100644 --- a/Math/NumberTheory/Moduli/Multiplicative.hs +++ b/Math/NumberTheory/Moduli/Multiplicative.hs @@ -22,9 +22,7 @@ module Math.NumberTheory.Moduli.Multiplicative , PrimitiveRoot , unPrimitiveRoot , isPrimitiveRoot - , isPrimitiveRoot' -- TODO (BM): don't expose this , discreteLogarithm - , discreteLogarithmPP -- TODO (BM): don't expose this ) where import Control.Monad diff --git a/test-suite/Math/NumberTheory/DirichletCharactersTests.hs b/test-suite/Math/NumberTheory/DirichletCharactersTests.hs index e55e2885a..8d4070224 100644 --- a/test-suite/Math/NumberTheory/DirichletCharactersTests.hs +++ b/test-suite/Math/NumberTheory/DirichletCharactersTests.hs @@ -167,6 +167,10 @@ makePrimitiveIdem chi = case makePrimitive chi 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 + testSuite :: TestTree testSuite = testGroup "DirichletCharacters" [ testSmallAndQuick "RootOfUnity contains roots of unity" rootOfUnityTest @@ -185,4 +189,5 @@ testSuite = testGroup "DirichletCharacters" , testSmallAndQuick "Primitive character checking is valid" (dirCharProperty primitiveCheck) , testSmallAndQuick "makePrimitive produces primitive character" (dirCharProperty makePrimitiveCheck) , testSmallAndQuick "makePrimitive is idempotent" (dirCharProperty makePrimitiveIdem) + , testSmallAndQuick "Calculates correct order" (dirCharProperty orderCheck) ] From 6b2db102118f946e6be7aa439d0e3dd34dbb2c72 Mon Sep 17 00:00:00 2001 From: Bhavik Mehta Date: Fri, 10 Jan 2020 03:21:44 +0000 Subject: [PATCH 53/65] Hlint suggestions --- Math/NumberTheory/Moduli/Internal.hs | 3 +-- Math/NumberTheory/Moduli/Multiplicative.hs | 1 - 2 files changed, 1 insertion(+), 3 deletions(-) diff --git a/Math/NumberTheory/Moduli/Internal.hs b/Math/NumberTheory/Moduli/Internal.hs index fd3208069..4cd0e6f6d 100644 --- a/Math/NumberTheory/Moduli/Internal.hs +++ b/Math/NumberTheory/Moduli/Internal.hs @@ -9,7 +9,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE ViewPatterns #-} module Math.NumberTheory.Moduli.Internal ( isPrimitiveRoot' @@ -84,7 +83,7 @@ isPrimitiveRoot' cg r = oddPrimeTest p g = let phi = totient p pows = map (\pk -> phi `quot` unPrime (fst pk)) (factorise phi) exps = map (\x -> powMod g x p) pows - in g /= 0 && gcd g p == 1 && all (/= 1) exps + in g /= 0 && gcd g p == 1 && notElem 1 exps oddPrimePowerTest p 1 g = oddPrimeTest p (g `mod` p) oddPrimePowerTest p _ g = oddPrimeTest p (g `mod` p) && powMod g (p-1) (p*p) /= 1 doubleOddPrimePowerTest p k g = odd g && oddPrimePowerTest p k g diff --git a/Math/NumberTheory/Moduli/Multiplicative.hs b/Math/NumberTheory/Moduli/Multiplicative.hs index af04f4653..2160e1664 100644 --- a/Math/NumberTheory/Moduli/Multiplicative.hs +++ b/Math/NumberTheory/Moduli/Multiplicative.hs @@ -7,7 +7,6 @@ -- Multiplicative groups of integers modulo m. -- -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE PatternSynonyms #-} From 58ed2c9a57e5ab3d6e6047a8a2115638f85bd60a Mon Sep 17 00:00:00 2001 From: Bhavik Mehta Date: Sat, 11 Jan 2020 01:45:08 +0000 Subject: [PATCH 54/65] Changes from review --- Math/NumberTheory/DirichletCharacters.hs | 72 +++++++++---------- Math/NumberTheory/Moduli/JacobiSymbol.hs | 14 ++-- Math/NumberTheory/Moduli/Sqrt.hs | 2 +- arithmoi.cabal | 2 +- .../NumberTheory/DirichletCharactersTests.hs | 36 +++++----- 5 files changed, 60 insertions(+), 66 deletions(-) diff --git a/Math/NumberTheory/DirichletCharacters.hs b/Math/NumberTheory/DirichletCharacters.hs index 9563720c1..5b0d91918 100644 --- a/Math/NumberTheory/DirichletCharacters.hs +++ b/Math/NumberTheory/DirichletCharacters.hs @@ -3,21 +3,19 @@ -- Copyright: (c) 2018 Bhavik Mehta -- Licence: MIT -- Maintainer: Bhavik Mehta --- Stability: Provisional --- Portability: Non-portable (GHC extensions) -- -- Implementation and enumeration of Dirichlet characters. -- -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE CPP #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} module Math.NumberTheory.DirichletCharacters ( @@ -38,10 +36,10 @@ module Math.NumberTheory.DirichletCharacters , characterNumber , allChars -- ** Evaluation - , evaluate - , generalEval + , eval + , evalGeneral , toFunction - , allEval + , evalAll -- ** Special Dirichlet characters , principalChar , isPrincipal @@ -63,7 +61,6 @@ module Math.NumberTheory.DirichletCharacters , validChar ) where -import Control.Applicative (Applicative(..), liftA2) import Data.Bits (Bits(..)) import Data.Complex (Complex(..), cis) import Data.Foldable (for_) @@ -74,7 +71,7 @@ import Data.Maybe (mapMaybe) import Data.Monoid (Ap(..)) #endif import Data.Proxy (Proxy(..)) -import Data.Ratio (Rational, Ratio, (%), numerator, denominator) +import Data.Ratio (Rational, (%), numerator, denominator) import Data.Semigroup (Semigroup(..), Product(..)) import qualified Data.Vector as V import qualified Data.Vector.Mutable as MV @@ -84,18 +81,18 @@ import Numeric.Natural (Natural) import Math.NumberTheory.ArithmeticFunctions (totient) import Math.NumberTheory.Moduli.Class (KnownNat, Mod, getVal) -import Math.NumberTheory.Moduli.Singleton (Some(..), cyclicGroupFromFactors) -import Math.NumberTheory.Moduli.Multiplicative (MultMod(..), isMultElement) import Math.NumberTheory.Moduli.Internal (isPrimitiveRoot', discreteLogarithmPP) +import Math.NumberTheory.Moduli.Multiplicative (MultMod(..), isMultElement) +import Math.NumberTheory.Moduli.Singleton (Some(..), cyclicGroupFromFactors) import Math.NumberTheory.Powers.Modular (powMod) -import Math.NumberTheory.Primes (Prime(..), UniqueFactorisation, factorise) +import Math.NumberTheory.Primes (Prime(..), UniqueFactorisation, factorise, nextPrime) import Math.NumberTheory.Utils.FromIntegral (wordToInt) -- | 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 `evaluate`. +-- 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 `generalEval`. +-- 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. @@ -155,7 +152,7 @@ instance Show RootOfUnity where d = denominator (2*q) -- | Given a rational \(q\), produce the root of unity \(e^{2 \pi i q}\). -toRootOfUnity :: Integral a => Ratio a -> RootOfUnity +toRootOfUnity :: Rational -> RootOfUnity toRootOfUnity q = RootOfUnity ((n `rem` d) % d) where n = toInteger $ numerator q d = toInteger $ denominator q @@ -203,8 +200,8 @@ lambda x e = ((powMod x (2*modulus) largeMod - 1) `shiftR` (e+1)) .&. (modulus - -- | For elements of the multiplicative group \((\mathbb{Z}/n\mathbb{Z})^*\), a Dirichlet -- character evaluates to a root of unity. -evaluate :: DirichletCharacter n -> MultMod n -> RootOfUnity -evaluate (Generated ds) m = foldMap (evalFactor m') ds +eval :: DirichletCharacter n -> MultMod n -> RootOfUnity +eval (Generated ds) m = foldMap (evalFactor m') ds where m' = getVal $ multElement m -- | Evaluate each factor of the Dirichlet character. @@ -222,15 +219,15 @@ evalFactor m = Two -> mempty -- | A character can evaluate to a root of unity or zero: represented by @Nothing@. -generalEval :: KnownNat n => DirichletCharacter n -> Mod n -> OrZero RootOfUnity -generalEval chi t = case isMultElement t of +evalGeneral :: KnownNat n => DirichletCharacter n -> Mod n -> OrZero RootOfUnity +evalGeneral chi t = case isMultElement t of Nothing -> Zero - Just x -> NonZero $ evaluate chi x + Just x -> NonZero $ eval chi x -- | Convert a Dirichlet character to a complex-valued function. As in `toComplex`, the result is -- inexact due to floating-point inaccuracies. See `toComplex`. toFunction :: (Integral a, RealFloat b, KnownNat n) => DirichletCharacter n -> a -> Complex b -toFunction chi = asNumber toComplex . generalEval chi . fromIntegral +toFunction chi = asNumber toComplex . evalGeneral chi . fromIntegral -- | Give the principal character for this modulus: a principal character mod \(n\) is 1 for -- \(a\) coprime to \(n\), and 0 otherwise. @@ -358,9 +355,9 @@ mkTemplate = go . sort . factorise 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 $ a2 % n)) + 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 $ a2 % 2) (toRootOfUnity $ b2 % 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) @@ -411,7 +408,7 @@ jacobiCharacter = if odd n else Nothing where n = natVal (Proxy :: Proxy n) go :: Template -> DirichletFactor - go (OddTemplate p k g _) = OddPrime p k g $ toRootOfUnity (k % 2) + 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 @@ -430,12 +427,12 @@ isRealCharacter t@(Generated xs) = if all real xs then Just (RealChar t) else No real (TwoPower _ _ b) = b <> b == mempty real Two = True --- TODO: it should be possible to calculate this without evaluate/generalEval +-- 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 :: (Integral a, KnownNat n) => RealCharacter n -> a -> Int -toRealFunction (RealChar chi) m = case generalEval chi (fromIntegral m) of +toRealFunction (RealChar chi) m = case evalGeneral chi (fromIntegral m) of Zero -> 0 NonZero t | t == mempty -> 1 NonZero t | t == RootOfUnity (1 % 2) -> -1 @@ -456,10 +453,9 @@ validChar (Generated xs) = correctDecomposition && all correctPrimitiveRoot xs & validValued (OddPrime (unPrime -> p) k _ a) = (p^(k-1)*(p-1)) `stimes` a == mempty validValued Two = True n = natVal (Proxy :: Proxy n) - two = toEnum 1 -- lazy way to get Prime 2 + two = nextPrime 2 -- | Get the order of the Dirichlet Character. --- TODO: test this 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 @@ -478,7 +474,7 @@ isPrimitive t@(Generated xs) = if all primitive xs then Just (PrimitiveCharacter 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 +-- | 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`. getPrimitiveCharacter :: DirichletCharacter n @@ -541,10 +537,10 @@ asNumber f (NonZero x) = f x -- 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, `allEval` will be better than `generalEval`, since +-- of a dirichlet character are required, `evalAll` will be better than `evalGeneral`, since -- computations can be shared. -allEval :: forall n. KnownNat n => DirichletCharacter n -> Vector (OrZero RootOfUnity) -allEval (Generated xs) = V.generate (fromIntegral n) func +evalAll :: forall n. KnownNat n => DirichletCharacter n -> Vector (OrZero RootOfUnity) +evalAll (Generated xs) = V.generate (fromIntegral n) func where n = natVal (Proxy :: Proxy n) vectors = map mkVector xs func :: Int -> OrZero RootOfUnity diff --git a/Math/NumberTheory/Moduli/JacobiSymbol.hs b/Math/NumberTheory/Moduli/JacobiSymbol.hs index 28d1363be..9be421d6a 100644 --- a/Math/NumberTheory/Moduli/JacobiSymbol.hs +++ b/Math/NumberTheory/Moduli/JacobiSymbol.hs @@ -17,7 +17,7 @@ module Math.NumberTheory.Moduli.JacobiSymbol ( JacobiSymbol(..) , jacobi - , symbolToIntegral + , symbolToNum ) where import Data.Bits @@ -49,14 +49,14 @@ negJS = \case Zero -> Zero One -> MinusOne -{-# SPECIALISE symbolToIntegral :: JacobiSymbol -> Integer, - JacobiSymbol -> Int, - JacobiSymbol -> Word, - JacobiSymbol -> Natural +{-# SPECIALISE symbolToNum :: JacobiSymbol -> Integer, + JacobiSymbol -> Int, + JacobiSymbol -> Word, + JacobiSymbol -> Natural #-} -- | Convenience function to convert out of a Jacobi symbol -symbolToIntegral :: Integral a => JacobiSymbol -> a -symbolToIntegral = \case +symbolToNum :: Num a => JacobiSymbol -> a +symbolToNum = \case Zero -> 0 One -> 1 MinusOne -> -1 diff --git a/Math/NumberTheory/Moduli/Sqrt.hs b/Math/NumberTheory/Moduli/Sqrt.hs index 93cf6d54f..074189aba 100644 --- a/Math/NumberTheory/Moduli/Sqrt.hs +++ b/Math/NumberTheory/Moduli/Sqrt.hs @@ -21,7 +21,7 @@ module Math.NumberTheory.Moduli.Sqrt -- * Jacobi symbol , JacobiSymbol(..) , jacobi - , symbolToIntegral + , symbolToNum ) where import Control.Monad (liftM2) diff --git a/arithmoi.cabal b/arithmoi.cabal index 08229056f..de5853a9c 100644 --- a/arithmoi.cabal +++ b/arithmoi.cabal @@ -67,7 +67,6 @@ library Math.NumberTheory.Moduli.Class Math.NumberTheory.Moduli.DiscreteLogarithm Math.NumberTheory.Moduli.Equations - Math.NumberTheory.Moduli.Internal Math.NumberTheory.Moduli.Jacobi Math.NumberTheory.Moduli.Multiplicative Math.NumberTheory.Moduli.PrimitiveRoot @@ -96,6 +95,7 @@ library 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 diff --git a/test-suite/Math/NumberTheory/DirichletCharactersTests.hs b/test-suite/Math/NumberTheory/DirichletCharactersTests.hs index 8d4070224..86c545d16 100644 --- a/test-suite/Math/NumberTheory/DirichletCharactersTests.hs +++ b/test-suite/Math/NumberTheory/DirichletCharactersTests.hs @@ -3,18 +3,16 @@ -- Copyright: (c) 2018 Bhavik Mehta -- License: MIT -- Maintainer: Andrew Lelechenko --- Stability: Provisional --- Portability: Non-portable -- -- Tests for Math.NumberTheory.DirichletCharacters -- -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE PatternSynonyms #-} module Math.NumberTheory.DirichletCharactersTests where @@ -26,8 +24,8 @@ import Data.Maybe (isJust, mapMaybe) import Data.Proxy import Data.Ratio import Data.Semigroup -import Numeric.Natural import qualified Data.Vector as V +import Numeric.Natural import GHC.TypeNats.Compat (SomeNat(..), someNatVal, KnownNat, natVal, sameNat) import Data.Type.Equality @@ -49,13 +47,13 @@ dirCharOrder chi = isPrincipal (totient n `stimes` chi) -- | 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' = generalEval chi + 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 = evaluate chi mempty == mempty +testAtOne chi = eval chi mempty == mempty dirCharProperty :: (forall n. KnownNat n => DirichletCharacter n -> a) -> Positive Natural -> Natural -> a dirCharProperty test (Positive n) i = @@ -81,7 +79,7 @@ countCharacters (Positive n) = principalCase :: Positive Natural -> Positive Integer -> Bool principalCase (Positive n) (Positive k) = case k `modulo` n of - SomeMod a -> generalEval chi a == if gcd k (fromIntegral n) > 1 + SomeMod a -> evalGeneral chi a == if gcd k (fromIntegral n) > 1 then Zero else mempty where chi = principalChar @@ -100,7 +98,7 @@ 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 [asNumber toComplex (generalEval chi a') | chi <- allChars] + where total = sum [asNumber toComplex (evalGeneral chi a') | chi <- allChars] correct = if a' == 1 then fromIntegral $ totient n else 0 @@ -109,7 +107,7 @@ orthogonality2 (Positive n) a = -- | Manually confirm isRealCharacter is correct (in both directions) realityCheck :: KnownNat n => DirichletCharacter n -> Bool realityCheck chi = isJust (isRealCharacter chi) == isReal' - where isReal' = and [real (generalEval chi t) | t <- [minBound..maxBound]] + where isReal' = and [real (evalGeneral chi t) | t <- [minBound..maxBound]] real Zero = True real (NonZero t) = t <> t == mempty @@ -123,12 +121,12 @@ 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.symbolToIntegral (J.jacobi j (2*n+1)) | j <- [0..2*n]] + 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 -allEvalCheck :: forall n. KnownNat n => DirichletCharacter n -> Bool -allEvalCheck chi = V.generate (fromIntegral $ natVal @n Proxy) (generalEval chi . fromIntegral) == allEval chi +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) @@ -137,7 +135,7 @@ 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) (allEval chi))) (allEval chi2)) + 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 @@ -150,7 +148,7 @@ primitiveCheck chi = isJust (isPrimitive chi) == isPrimitive' where isPrimitive' = all testModulus possibleModuli n = fromIntegral (natVal @n Proxy) :: Int possibleModuli = init (divisorsList n) - table = allEval chi + 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] makePrimitiveCheck :: DirichletCharacter n -> Bool @@ -181,12 +179,12 @@ testSuite = testGroup "DirichletCharacters" , testSmallAndQuick "Principal character behaves as expected" principalCase , testSmallAndQuick "Orthogonality relation 1" (dirCharProperty orthogonality1) , testSmallAndQuick "Orthogonality relation 2" orthogonality2 - , testSmallAndQuick "Real character checking is valid" (dirCharProperty realityCheck) + , 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 allEvalCheck) + , testSmallAndQuick "Bulk evaluation matches pointwise" (dirCharProperty evalAllCheck) , testSmallAndQuick "Induced character is correct" (dirCharProperty inducedCheck) - , testSmallAndQuick "Primitive character checking is valid" (dirCharProperty primitiveCheck) + , 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) From 7be578e928f7a2c271d77c1efffdd4fdb076a8f1 Mon Sep 17 00:00:00 2001 From: Bhavik Mehta Date: Sat, 11 Jan 2020 02:10:30 +0000 Subject: [PATCH 55/65] A bunch more tests --- Math/NumberTheory/DirichletCharacters.hs | 12 ++-- .../NumberTheory/DirichletCharactersTests.hs | 61 ++++++++++++++++++- 2 files changed, 66 insertions(+), 7 deletions(-) diff --git a/Math/NumberTheory/DirichletCharacters.hs b/Math/NumberTheory/DirichletCharacters.hs index 5b0d91918..b12fb73b3 100644 --- a/Math/NumberTheory/DirichletCharacters.hs +++ b/Math/NumberTheory/DirichletCharacters.hs @@ -53,7 +53,7 @@ module Math.NumberTheory.DirichletCharacters -- ** Primitive characters , PrimitiveCharacter , isPrimitive - , getPrimitiveCharacter + , getPrimitiveChar , induced , makePrimitive , WithNat(..) @@ -237,6 +237,7 @@ 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) = @@ -301,14 +302,15 @@ indicesToChars = fmap (Generated . unroll t . (`mod` m) . fromIntegral) (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 :: forall n. KnownNat n => [DirichletCharacter n] allChars = indicesToChars [0..m-1] where m = totient $ natVal (Proxy :: Proxy n) -makeChar :: (Integral a) => DirichletCharacter n -> a -> DirichletCharacter 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 +-- | 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) @@ -477,7 +479,7 @@ isPrimitive t@(Generated xs) = if all primitive xs then Just (PrimitiveCharacter -- | 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`. - getPrimitiveCharacter :: DirichletCharacter n + getPrimitiveChar :: DirichletCharacter n } deriving Eq diff --git a/test-suite/Math/NumberTheory/DirichletCharactersTests.hs b/test-suite/Math/NumberTheory/DirichletCharactersTests.hs index 86c545d16..f7bb3dacc 100644 --- a/test-suite/Math/NumberTheory/DirichletCharactersTests.hs +++ b/test-suite/Math/NumberTheory/DirichletCharactersTests.hs @@ -151,15 +151,16 @@ primitiveCheck chi = isJust (isPrimitive chi) == isPrimitive' 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 (getPrimitiveCharacter chi')) + 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 (getPrimitiveCharacter chi') of + case makePrimitive (getPrimitiveChar chi') of WithNat (chi'' :: PrimitiveCharacter n'') -> case sameNat (Proxy :: Proxy n') (Proxy :: Proxy n'') of Just Refl -> chi' == chi'' @@ -169,6 +170,52 @@ orderCheck :: DirichletCharacter n -> Bool orderCheck chi = isPrincipal (n `stimes` chi) && and [not (isPrincipal (i `stimes` chi)) | i <- [1..n-1]] where n = orderChar 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 (d*k) of + SomeNat (Proxy :: Proxy n) -> + case induced @n chi of + Just chi2 -> validChar chi2 + Nothing -> False + where d = natVal @d Proxy + +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 "RootOfUnity contains roots of unity" rootOfUnityTest @@ -188,4 +235,14 @@ testSuite = testGroup "DirichletCharacters" , testSmallAndQuick "makePrimitive produces primitive character" (dirCharProperty makePrimitiveCheck) , testSmallAndQuick "makePrimitive is idempotent" (dirCharProperty makePrimitiveIdem) , testSmallAndQuick "Calculates correct order" (dirCharProperty orderCheck) + , 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) + ] ] From 1a5c634e65afce7386f7fec93ba36650929cfbde Mon Sep 17 00:00:00 2001 From: Bhavik Mehta Date: Sat, 11 Jan 2020 02:19:16 +0000 Subject: [PATCH 56/65] restore applicative import --- Math/NumberTheory/DirichletCharacters.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/Math/NumberTheory/DirichletCharacters.hs b/Math/NumberTheory/DirichletCharacters.hs index b12fb73b3..2e0b26bf5 100644 --- a/Math/NumberTheory/DirichletCharacters.hs +++ b/Math/NumberTheory/DirichletCharacters.hs @@ -61,6 +61,7 @@ module Math.NumberTheory.DirichletCharacters , validChar ) where +import Control.Applicative (liftA2) import Data.Bits (Bits(..)) import Data.Complex (Complex(..), cis) import Data.Foldable (for_) From 1a0ccb101e82da5969934945c3b8d076dbc4b88d Mon Sep 17 00:00:00 2001 From: Bhavik Mehta Date: Sat, 11 Jan 2020 22:35:46 +0000 Subject: [PATCH 57/65] changes from review --- Math/NumberTheory/DirichletCharacters.hs | 28 ++++++++----------- .../NumberTheory/DirichletCharactersTests.hs | 5 ++-- 2 files changed, 15 insertions(+), 18 deletions(-) diff --git a/Math/NumberTheory/DirichletCharacters.hs b/Math/NumberTheory/DirichletCharacters.hs index 2e0b26bf5..080514023 100644 --- a/Math/NumberTheory/DirichletCharacters.hs +++ b/Math/NumberTheory/DirichletCharacters.hs @@ -38,7 +38,6 @@ module Math.NumberTheory.DirichletCharacters -- ** Evaluation , eval , evalGeneral - , toFunction , evalAll -- ** Special Dirichlet characters , principalChar @@ -61,7 +60,9 @@ module Math.NumberTheory.DirichletCharacters , validChar ) where +#if !MIN_VERSION_base(4,12,0) import Control.Applicative (liftA2) +#endif import Data.Bits (Bits(..)) import Data.Complex (Complex(..), cis) import Data.Foldable (for_) @@ -155,8 +156,8 @@ instance Show RootOfUnity where -- | 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 = toInteger $ numerator q - d = toInteger $ denominator q + 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. @@ -225,11 +226,6 @@ evalGeneral chi t = case isMultElement t of Nothing -> Zero Just x -> NonZero $ eval chi x --- | Convert a Dirichlet character to a complex-valued function. As in `toComplex`, the result is --- inexact due to floating-point inaccuracies. See `toComplex`. -toFunction :: (Integral a, RealFloat b, KnownNat n) => DirichletCharacter n -> a -> Complex b -toFunction chi = asNumber toComplex . evalGeneral chi . fromIntegral - -- | 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 @@ -264,7 +260,7 @@ stimesChar s (Generated xs) = Generated (map mult xs) -- | We define `succ` and `pred` with more efficient implementations than -- @`toEnum` . (+1) . `fromEnum`@. instance KnownNat n => Enum (DirichletCharacter n) where - toEnum = indexToChar + toEnum = indexToChar . fromIntegral fromEnum = fromIntegral . characterNumber succ x = makeChar x (characterNumber x + 1) pred x = makeChar x (characterNumber x - 1) @@ -275,29 +271,29 @@ instance KnownNat n => Enum (DirichletCharacter n) where enumFromThen x y = bulkMakeChars x [fromEnum x, fromEnum y..] instance KnownNat n => Bounded (DirichletCharacter n) where - minBound = indexToChar (0 :: Int) + 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 go x (OddPrime p k _ a) = x * m + numerator (fromRootOfUnity a * fromIntegral m) where p' = fromIntegral (unPrime p) m = p'^(k-1)*(p'-1) - go x (TwoPower k a b) = x' * 2 + numerator (fromRootOfUnity a * (2 % 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 * fromIntegral m) go x Two = x -- | Give the dirichlet character from its number. -- Inverse of `characterNumber`. -indexToChar :: forall n a. (KnownNat n, Integral a) => a -> DirichletCharacter n +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 a f. (KnownNat n, Integral a, Functor f) => f a -> f (DirichletCharacter n) +indicesToChars :: forall n f. (KnownNat n, Functor f) => f Natural -> f (DirichletCharacter n) indicesToChars = fmap (Generated . unroll t . (`mod` m) . fromIntegral) where n = natVal (Proxy :: Proxy n) (Product m, t) = mkTemplate n @@ -434,8 +430,8 @@ isRealCharacter t@(Generated xs) = if all real xs then Just (RealChar t) else No -- 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 :: (Integral a, KnownNat n) => RealCharacter n -> a -> Int -toRealFunction (RealChar chi) m = case evalGeneral chi (fromIntegral m) of +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 diff --git a/test-suite/Math/NumberTheory/DirichletCharactersTests.hs b/test-suite/Math/NumberTheory/DirichletCharactersTests.hs index f7bb3dacc..c9f88dd4e 100644 --- a/test-suite/Math/NumberTheory/DirichletCharactersTests.hs +++ b/test-suite/Math/NumberTheory/DirichletCharactersTests.hs @@ -89,7 +89,7 @@ principalCase (Positive n) (Positive k) = orthogonality1 :: forall n. KnownNat n => DirichletCharacter n -> Bool orthogonality1 chi = magnitude (total - correct) < (1e-13 :: Double) where n = natVal @n Proxy - total = sum [toFunction chi a | a <- [0..n-1]] + total = sum [asNumber toComplex (evalGeneral chi a) | a <- [0 .. maxBound]] correct = if isPrincipal chi then fromIntegral $ totient n else 0 @@ -113,7 +113,8 @@ realityCheck chi = isJust (isRealCharacter chi) == isReal' -- | Check real character evaluation matches normal evaluation realEvalCheck :: KnownNat n => RealCharacter n -> Int -> Bool -realEvalCheck chi i = fromIntegral (toRealFunction chi i) == toFunction (getRealChar chi) i +realEvalCheck chi i' = fromIntegral (toRealFunction chi i) == asNumber toComplex (evalGeneral (getRealChar chi) i) + where i = fromIntegral i' -- | The jacobi character agrees with the jacobi symbol jacobiCheck :: Positive Natural -> Bool From 2de6e0682b272a6573434c0936b253d94b00f8e3 Mon Sep 17 00:00:00 2001 From: Bhavik Mehta Date: Sat, 11 Jan 2020 22:45:05 +0000 Subject: [PATCH 58/65] Remove unnecessary definitions --- Math/NumberTheory/Moduli/Internal.hs | 40 ++-------------------------- 1 file changed, 2 insertions(+), 38 deletions(-) diff --git a/Math/NumberTheory/Moduli/Internal.hs b/Math/NumberTheory/Moduli/Internal.hs index 4cd0e6f6d..266e85a34 100644 --- a/Math/NumberTheory/Moduli/Internal.hs +++ b/Math/NumberTheory/Moduli/Internal.hs @@ -1,6 +1,6 @@ -- | --- Module: Math.NumberTheory.Moduli.Multiplicative --- Copyright: (c) 2017 Andrew Lelechenko +-- Module: Math.NumberTheory.Moduli.Internal +-- Copyright: (c) 2020 Andrew Lelechenko -- Licence: MIT -- Maintainer: Andrew Lelechenko -- @@ -19,7 +19,6 @@ import qualified Data.Map as M import Data.Maybe import Data.Mod import Data.Proxy -import Data.Semigroup import GHC.Integer.GMP.Internals import GHC.TypeNats.Compat import Numeric.Natural @@ -32,41 +31,6 @@ import Math.NumberTheory.Primes import Math.NumberTheory.Powers.Modular import Math.NumberTheory.Roots --- | This type represents elements of the multiplicative group mod m, i.e. --- those elements which are coprime to m. Use @toMultElement@ to construct. -newtype MultMod m = MultMod { - multElement :: Mod m -- ^ 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 - mappend = (<>) - -instance KnownNat m => Bounded (MultMod m) where - minBound = MultMod 1 - maxBound = MultMod (-1) - --- | 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 of m. -newtype PrimitiveRoot m = PrimitiveRoot - { unPrimitiveRoot :: MultMod m -- ^ Extract primitive root value. - } - deriving (Eq, Show) - -- https://en.wikipedia.org/wiki/Primitive_root_modulo_n#Finding_primitive_roots isPrimitiveRoot' :: (Integral a, UniqueFactorisation a) From 7743a9fd9aa24ebb69c00cb8c4545f7cf74eaaea Mon Sep 17 00:00:00 2001 From: Bhavik Mehta Date: Sat, 11 Jan 2020 22:53:21 +0000 Subject: [PATCH 59/65] Other changes from review --- Math/NumberTheory/DirichletCharacters.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Math/NumberTheory/DirichletCharacters.hs b/Math/NumberTheory/DirichletCharacters.hs index 080514023..144c1c31e 100644 --- a/Math/NumberTheory/DirichletCharacters.hs +++ b/Math/NumberTheory/DirichletCharacters.hs @@ -73,7 +73,7 @@ import Data.Maybe (mapMaybe) import Data.Monoid (Ap(..)) #endif import Data.Proxy (Proxy(..)) -import Data.Ratio (Rational, (%), numerator, denominator) +import Data.Ratio ((%), numerator, denominator) import Data.Semigroup (Semigroup(..), Product(..)) import qualified Data.Vector as V import qualified Data.Vector.Mutable as MV @@ -294,7 +294,7 @@ 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) . fromIntegral) +indicesToChars = fmap (Generated . unroll t . (`mod` m)) where n = natVal (Proxy :: Proxy n) (Product m, t) = mkTemplate n From 9574b4d2a5dffae7157c17197588ee707df5c0c5 Mon Sep 17 00:00:00 2001 From: Bhavik Mehta Date: Sat, 11 Jan 2020 23:20:22 +0000 Subject: [PATCH 60/65] Change name to orZeroToNum --- Math/NumberTheory/DirichletCharacters.hs | 8 ++++---- Math/NumberTheory/Moduli/Internal.hs | 4 ++-- test-suite/Math/NumberTheory/DirichletCharactersTests.hs | 6 +++--- 3 files changed, 9 insertions(+), 9 deletions(-) diff --git a/Math/NumberTheory/DirichletCharacters.hs b/Math/NumberTheory/DirichletCharacters.hs index 144c1c31e..90d47903e 100644 --- a/Math/NumberTheory/DirichletCharacters.hs +++ b/Math/NumberTheory/DirichletCharacters.hs @@ -27,7 +27,7 @@ module Math.NumberTheory.DirichletCharacters , toComplex -- * An absorbing semigroup , OrZero, pattern Zero, pattern NonZero - , asNumber + , orZeroToNum -- * Dirichlet characters , DirichletCharacter -- ** Construction @@ -527,9 +527,9 @@ pattern NonZero x = Ap (Just x) {-# COMPLETE Zero, NonZero #-} -- | Interpret an `OrZero` as a number, taking the `Zero` case to be 0. -asNumber :: Num a => (b -> a) -> OrZero b -> a -asNumber _ Zero = 0 -asNumber f (NonZero x) = f x +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). diff --git a/Math/NumberTheory/Moduli/Internal.hs b/Math/NumberTheory/Moduli/Internal.hs index 266e85a34..c2148b987 100644 --- a/Math/NumberTheory/Moduli/Internal.hs +++ b/Math/NumberTheory/Moduli/Internal.hs @@ -1,8 +1,8 @@ -- | -- Module: Math.NumberTheory.Moduli.Internal --- Copyright: (c) 2020 Andrew Lelechenko +-- Copyright: (c) 2020 Bhavik Mehta -- Licence: MIT --- Maintainer: Andrew Lelechenko +-- Maintainer: Bhavik Mehta -- -- Multiplicative groups of integers modulo m. -- diff --git a/test-suite/Math/NumberTheory/DirichletCharactersTests.hs b/test-suite/Math/NumberTheory/DirichletCharactersTests.hs index c9f88dd4e..6ab05da43 100644 --- a/test-suite/Math/NumberTheory/DirichletCharactersTests.hs +++ b/test-suite/Math/NumberTheory/DirichletCharactersTests.hs @@ -89,7 +89,7 @@ principalCase (Positive n) (Positive k) = orthogonality1 :: forall n. KnownNat n => DirichletCharacter n -> Bool orthogonality1 chi = magnitude (total - correct) < (1e-13 :: Double) where n = natVal @n Proxy - total = sum [asNumber toComplex (evalGeneral chi a) | a <- [0 .. maxBound]] + total = sum [orZeroToNum toComplex (evalGeneral chi a) | a <- [0 .. maxBound]] correct = if isPrincipal chi then fromIntegral $ totient n else 0 @@ -98,7 +98,7 @@ 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 [asNumber toComplex (evalGeneral chi a') | chi <- allChars] + where total = sum [orZeroToNum toComplex (evalGeneral chi a') | chi <- allChars] correct = if a' == 1 then fromIntegral $ totient n else 0 @@ -113,7 +113,7 @@ realityCheck chi = isJust (isRealCharacter chi) == isReal' -- | Check real character evaluation matches normal evaluation realEvalCheck :: KnownNat n => RealCharacter n -> Int -> Bool -realEvalCheck chi i' = fromIntegral (toRealFunction chi i) == asNumber toComplex (evalGeneral (getRealChar chi) i) +realEvalCheck chi i' = fromIntegral (toRealFunction chi i) == orZeroToNum toComplex (evalGeneral (getRealChar chi) i) where i = fromIntegral i' -- | The jacobi character agrees with the jacobi symbol From 23ef877c27f527412d9c8f0d8dda4227541a70ab Mon Sep 17 00:00:00 2001 From: Bhavik Mehta Date: Sun, 12 Jan 2020 03:27:19 +0000 Subject: [PATCH 61/65] construction from table --- Math/NumberTheory/DirichletCharacters.hs | 58 +++++++++++++++---- Math/NumberTheory/Moduli/Chinese.hs | 3 + .../NumberTheory/DirichletCharactersTests.hs | 4 ++ 3 files changed, 54 insertions(+), 11 deletions(-) diff --git a/Math/NumberTheory/DirichletCharacters.hs b/Math/NumberTheory/DirichletCharacters.hs index 90d47903e..92ac07d73 100644 --- a/Math/NumberTheory/DirichletCharacters.hs +++ b/Math/NumberTheory/DirichletCharacters.hs @@ -16,6 +16,7 @@ {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE MagicHash #-} module Math.NumberTheory.DirichletCharacters ( @@ -35,6 +36,7 @@ module Math.NumberTheory.DirichletCharacters , indicesToChars , characterNumber , allChars + , fromTable -- ** Evaluation , eval , evalGeneral @@ -63,12 +65,13 @@ module Math.NumberTheory.DirichletCharacters #if !MIN_VERSION_base(4,12,0) import Control.Applicative (liftA2) #endif +import Control.Monad (zipWithM) import Data.Bits (Bits(..)) import Data.Complex (Complex(..), cis) import Data.Foldable (for_) import Data.Functor.Identity (Identity(..)) import Data.List (mapAccumL, foldl', sort, find) -import Data.Maybe (mapMaybe) +import Data.Maybe (mapMaybe, fromJust, fromMaybe) #if MIN_VERSION_base(4,12,0) import Data.Monoid (Ap(..)) #endif @@ -78,10 +81,12 @@ import Data.Semigroup (Semigroup(..), Produ import qualified Data.Vector as V import qualified Data.Vector.Mutable as MV import Data.Vector (Vector, (!)) -import GHC.TypeNats.Compat (Nat, SomeNat(..), natVal, someNatVal) +import GHC.Exts (proxy#, Proxy#) +import GHC.TypeNats.Compat (Nat, SomeNat(..), natVal, someNatVal, natVal') import Numeric.Natural (Natural) import Math.NumberTheory.ArithmeticFunctions (totient) +import Math.NumberTheory.Moduli.Chinese import Math.NumberTheory.Moduli.Class (KnownNat, Mod, getVal) import Math.NumberTheory.Moduli.Internal (isPrimitiveRoot', discreteLogarithmPP) import Math.NumberTheory.Moduli.Multiplicative (MultMod(..), isMultElement) @@ -89,6 +94,7 @@ import Math.NumberTheory.Moduli.Singleton (Some(..), cyclicGrou import Math.NumberTheory.Powers.Modular (powMod) import Math.NumberTheory.Primes (Prime(..), UniqueFactorisation, factorise, nextPrime) import Math.NumberTheory.Utils.FromIntegral (wordToInt) +import Math.NumberTheory.Utils -- | 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 @@ -213,13 +219,15 @@ evalFactor m = 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 m'' k `stimes` b - where m' = m .&. (bit k - 1) - m'' = if testBit m 1 - then bit k - m' - else m' + <> 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 @@ -574,11 +582,39 @@ evalAll (Generated xs) = V.generate (fromIntegral n) func f m | even m = Zero | otherwise = NonZero ((if testBit m 1 then a else mempty) <> lambda (toInteger m'') k `stimes` b) - where m' = m .&. (bit k - 1) - m'' = if testBit m 1 - then bit k - m' - else m' + where m'' = thingy k m -- somewhere between unfoldr and iterate iterateMaybe :: (a -> Maybe a) -> a -> [a] iterateMaybe f = go where go x = x: maybe [] go (f x) + +fromTable :: forall n. KnownNat n => Vector (OrZero RootOfUnity) -> Maybe (DirichletCharacter n) +fromTable v = if length v == fromIntegral n + then Generated <$> (zipWithM makeFactor tmpl vals) >>= check + else Nothing + where n = natVal' (proxy# :: Proxy# n) + n' = fromIntegral n :: Integer + tmpl = snd (mkTemplate n) + vals = map ((`mod` n') . fromJust . chineseCoprimeList) $ thing $ map makePairs tmpl + makePairs :: Template -> (Integer, Integer) + makePairs TwoTemplate = (1,2) + makePairs (OddTemplate p k g _) = (toInteger g, (toInteger $ unPrime p)^k) + makePairs (TwoPTemplate k _) = (exp4 k, bit k) + check :: DirichletCharacter n -> Maybe (DirichletCharacter n) + check chi = if evalAll chi == v then Just chi else Nothing + makeFactor :: Template -> Integer -> Maybe DirichletFactor + makeFactor TwoTemplate _ = Just Two + makeFactor (TwoPTemplate k _) z = TwoPower k <$> getAp (v ! fromInteger ((fromJust (chineseCoprime (1,n' `quot` bit k) (-1, bit k))) `mod` n')) <*> getAp (v ! (fromInteger z)) + makeFactor (OddTemplate p k g _) z = OddPrime p k g <$> getAp (v ! (fromInteger z)) + +thing :: (Eq a, Eq b, Num a) => [(a,b)] -> [[(a,b)]] +thing xs = fmap (\t -> fmap (\(x,y) -> if (x,y) == t then t else (1,y)) xs) xs + +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) +exp4 :: Int -> Integer +exp4 n = (`mod` bit n) $ sum $ map (`mod` bit n) $ map (\q -> numerator q * fromMaybe (error "error in exp4") (recipMod (denominator q) (bit n))) $ take n $ exp4terms diff --git a/Math/NumberTheory/Moduli/Chinese.hs b/Math/NumberTheory/Moduli/Chinese.hs index 7a67b475e..8c5bf3dda 100644 --- a/Math/NumberTheory/Moduli/Chinese.hs +++ b/Math/NumberTheory/Moduli/Chinese.hs @@ -68,6 +68,9 @@ chineseCoprime (n1, m1) (n2, m2) {-# SPECIALISE chineseCoprime :: (Word, Word) -> (Word, Word) -> Maybe Word #-} {-# SPECIALISE chineseCoprime :: (Integer, Integer) -> (Integer, Integer) -> Maybe Integer #-} +chineseCoprimeList :: (Eq a, Ring a, Euclidean a) => [(a, a)] -> Maybe a +chineseCoprimeList xs = fmap fst $ foldM (\x y -> fmap (,snd x `times` snd y) (chineseCoprime x y)) (zero, one) xs + -- | 'chinese' @(n1, m1)@ @(n2, m2)@ returns @n@ such that -- @n \`mod\` m1 == n1@ and @n \`mod\` m2 == n2@, if exists. -- Moduli @m1@ and @m2@ are allowed to have common factors. diff --git a/test-suite/Math/NumberTheory/DirichletCharactersTests.hs b/test-suite/Math/NumberTheory/DirichletCharactersTests.hs index 6ab05da43..5b23c3c0a 100644 --- a/test-suite/Math/NumberTheory/DirichletCharactersTests.hs +++ b/test-suite/Math/NumberTheory/DirichletCharactersTests.hs @@ -171,6 +171,9 @@ 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 @@ -236,6 +239,7 @@ testSuite = testGroup "DirichletCharacters" , 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 From 9286cab268f5dfcb7a6e69887d6a305181cfd36d Mon Sep 17 00:00:00 2001 From: Bhavik Mehta Date: Sun, 12 Jan 2020 03:43:29 +0000 Subject: [PATCH 62/65] simplify fromTable --- Math/NumberTheory/DirichletCharacters.hs | 22 ++++++++-------------- Math/NumberTheory/Moduli/Chinese.hs | 3 --- 2 files changed, 8 insertions(+), 17 deletions(-) diff --git a/Math/NumberTheory/DirichletCharacters.hs b/Math/NumberTheory/DirichletCharacters.hs index 92ac07d73..8188f0117 100644 --- a/Math/NumberTheory/DirichletCharacters.hs +++ b/Math/NumberTheory/DirichletCharacters.hs @@ -65,7 +65,6 @@ module Math.NumberTheory.DirichletCharacters #if !MIN_VERSION_base(4,12,0) import Control.Applicative (liftA2) #endif -import Control.Monad (zipWithM) import Data.Bits (Bits(..)) import Data.Complex (Complex(..), cis) import Data.Foldable (for_) @@ -590,25 +589,19 @@ iterateMaybe f = go where go x = x: maybe [] go (f x) fromTable :: forall n. KnownNat n => Vector (OrZero RootOfUnity) -> Maybe (DirichletCharacter n) fromTable v = if length v == fromIntegral n - then Generated <$> (zipWithM makeFactor tmpl vals) >>= check + then Generated <$> traverse makeFactor tmpl >>= check else Nothing where n = natVal' (proxy# :: Proxy# n) n' = fromIntegral n :: Integer tmpl = snd (mkTemplate n) - vals = map ((`mod` n') . fromJust . chineseCoprimeList) $ thing $ map makePairs tmpl - makePairs :: Template -> (Integer, Integer) - makePairs TwoTemplate = (1,2) - makePairs (OddTemplate p k g _) = (toInteger g, (toInteger $ unPrime p)^k) - makePairs (TwoPTemplate k _) = (exp4 k, bit k) check :: DirichletCharacter n -> Maybe (DirichletCharacter n) check chi = if evalAll chi == v then Just chi else Nothing - makeFactor :: Template -> Integer -> Maybe DirichletFactor - makeFactor TwoTemplate _ = Just Two - makeFactor (TwoPTemplate k _) z = TwoPower k <$> getAp (v ! fromInteger ((fromJust (chineseCoprime (1,n' `quot` bit k) (-1, bit k))) `mod` n')) <*> getAp (v ! (fromInteger z)) - makeFactor (OddTemplate p k g _) z = OddPrime p k g <$> getAp (v ! (fromInteger z)) - -thing :: (Eq a, Eq b, Num a) => [(a,b)] -> [[(a,b)]] -thing xs = fmap (\t -> fmap (\(x,y) -> if (x,y) == t then t else (1,y)) xs) xs + 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 (fromJust (chineseCoprime (g,m) (1,n' `quot` m)) `mod` n')) exp4terms :: [Rational] exp4terms = [4^k % product [1..k] | k <- [0..]] @@ -616,5 +609,6 @@ 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 (`mod` bit n) $ map (\q -> numerator q * fromMaybe (error "error in exp4") (recipMod (denominator q) (bit n))) $ take n $ exp4terms diff --git a/Math/NumberTheory/Moduli/Chinese.hs b/Math/NumberTheory/Moduli/Chinese.hs index 8c5bf3dda..7a67b475e 100644 --- a/Math/NumberTheory/Moduli/Chinese.hs +++ b/Math/NumberTheory/Moduli/Chinese.hs @@ -68,9 +68,6 @@ chineseCoprime (n1, m1) (n2, m2) {-# SPECIALISE chineseCoprime :: (Word, Word) -> (Word, Word) -> Maybe Word #-} {-# SPECIALISE chineseCoprime :: (Integer, Integer) -> (Integer, Integer) -> Maybe Integer #-} -chineseCoprimeList :: (Eq a, Ring a, Euclidean a) => [(a, a)] -> Maybe a -chineseCoprimeList xs = fmap fst $ foldM (\x y -> fmap (,snd x `times` snd y) (chineseCoprime x y)) (zero, one) xs - -- | 'chinese' @(n1, m1)@ @(n2, m2)@ returns @n@ such that -- @n \`mod\` m1 == n1@ and @n \`mod\` m2 == n2@, if exists. -- Moduli @m1@ and @m2@ are allowed to have common factors. From 7066373b04b76c29f1a6d83ffc6698029f48bdd4 Mon Sep 17 00:00:00 2001 From: Bhavik Mehta Date: Sun, 12 Jan 2020 03:57:15 +0000 Subject: [PATCH 63/65] fix compile error --- Math/NumberTheory/DirichletCharacters.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/Math/NumberTheory/DirichletCharacters.hs b/Math/NumberTheory/DirichletCharacters.hs index 8188f0117..78f796186 100644 --- a/Math/NumberTheory/DirichletCharacters.hs +++ b/Math/NumberTheory/DirichletCharacters.hs @@ -80,8 +80,7 @@ import Data.Semigroup (Semigroup(..), Produ import qualified Data.Vector as V import qualified Data.Vector.Mutable as MV import Data.Vector (Vector, (!)) -import GHC.Exts (proxy#, Proxy#) -import GHC.TypeNats.Compat (Nat, SomeNat(..), natVal, someNatVal, natVal') +import GHC.TypeNats.Compat (Nat, SomeNat(..), natVal, someNatVal) import Numeric.Natural (Natural) import Math.NumberTheory.ArithmeticFunctions (totient) @@ -591,7 +590,7 @@ fromTable :: forall n. KnownNat n => Vector (OrZero RootOfUnity) -> Maybe (Diric fromTable v = if length v == fromIntegral n then Generated <$> traverse makeFactor tmpl >>= check else Nothing - where n = natVal' (proxy# :: Proxy# n) + where n = natVal (Proxy :: Proxy n) n' = fromIntegral n :: Integer tmpl = snd (mkTemplate n) check :: DirichletCharacter n -> Maybe (DirichletCharacter n) From dd57b4304198be78aa066350b3084e096016a4fc Mon Sep 17 00:00:00 2001 From: Bhavik Mehta Date: Sun, 12 Jan 2020 04:21:02 +0000 Subject: [PATCH 64/65] Use inbuilt functions and add docs --- Math/NumberTheory/DirichletCharacters.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/Math/NumberTheory/DirichletCharacters.hs b/Math/NumberTheory/DirichletCharacters.hs index 78f796186..f86a37f32 100644 --- a/Math/NumberTheory/DirichletCharacters.hs +++ b/Math/NumberTheory/DirichletCharacters.hs @@ -69,7 +69,7 @@ import Data.Bits (Bits(..)) import Data.Complex (Complex(..), cis) import Data.Foldable (for_) import Data.Functor.Identity (Identity(..)) -import Data.List (mapAccumL, foldl', sort, find) +import Data.List (mapAccumL, foldl', sort, find, unfoldr) import Data.Maybe (mapMaybe, fromJust, fromMaybe) #if MIN_VERSION_base(4,12,0) import Data.Monoid (Ap(..)) @@ -584,8 +584,10 @@ evalAll (Generated xs) = V.generate (fromIntegral n) func -- somewhere between unfoldr and iterate iterateMaybe :: (a -> Maybe a) -> a -> [a] -iterateMaybe f = go where go x = x: maybe [] go (f x) +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 == fromIntegral n then Generated <$> traverse makeFactor tmpl >>= check From d71843cff7b62e6ca42c5ac8192f70838fd2bb12 Mon Sep 17 00:00:00 2001 From: Bhavik Mehta Date: Sun, 12 Jan 2020 05:02:27 +0000 Subject: [PATCH 65/65] remove redundant pragma --- Math/NumberTheory/DirichletCharacters.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/Math/NumberTheory/DirichletCharacters.hs b/Math/NumberTheory/DirichletCharacters.hs index f86a37f32..f4896ef72 100644 --- a/Math/NumberTheory/DirichletCharacters.hs +++ b/Math/NumberTheory/DirichletCharacters.hs @@ -16,7 +16,6 @@ {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE MagicHash #-} module Math.NumberTheory.DirichletCharacters (