From 4ba5e3a7f74887b718c1ee4671927cab0d3bfe86 Mon Sep 17 00:00:00 2001 From: Alexandre Date: Tue, 25 Feb 2020 02:51:41 +0000 Subject: [PATCH] [#148] Generalize 'inverseSigma' and 'inverseTotient' --- .../ArithmeticFunctions/Inverse.hs | 62 ++++++++++++- .../Quadratic/EisensteinIntegers.hs | 3 +- .../ArithmeticFunctions/InverseTests.hs | 90 +++++++++++++++++++ test-suite/Math/NumberTheory/TestUtils.hs | 12 ++- 4 files changed, 162 insertions(+), 5 deletions(-) diff --git a/Math/NumberTheory/ArithmeticFunctions/Inverse.hs b/Math/NumberTheory/ArithmeticFunctions/Inverse.hs index 6f5bfe7b4..27fbbd6b7 100644 --- a/Math/NumberTheory/ArithmeticFunctions/Inverse.hs +++ b/Math/NumberTheory/ArithmeticFunctions/Inverse.hs @@ -16,7 +16,9 @@ module Math.NumberTheory.ArithmeticFunctions.Inverse ( inverseTotient + , inverseJordan , inverseSigma + , inverseSigmaK , -- * Wrappers MinWord(..) , MaxWord(..) @@ -268,12 +270,40 @@ inverseTotient => (a -> b) -> a -> b -inverseTotient point = invertFunction point totientA invTotient +inverseTotient = inverseJordan 1 {-# SPECIALISE inverseTotient :: Semiring b => (Int -> b) -> Int -> b #-} {-# SPECIALISE inverseTotient :: Semiring b => (Word -> b) -> Word -> b #-} {-# SPECIALISE inverseTotient :: Semiring b => (Integer -> b) -> Integer -> b #-} {-# SPECIALISE inverseTotient :: Semiring b => (Natural -> b) -> Natural -> b #-} +-- | The inverse for 'jordan_k' function, where 'k' is a nonnegative integer. +-- +-- Generalizes the 'inverseTotient' function, which is 'inverseJordan' when 'k' +-- is '1'. +-- +-- The return value is parameterized by a 'Semiring', which allows +-- various applications by providing different (multiplicative) embeddings. +-- E. g., list all preimages (see a helper 'asSetOfPreimages'): +-- +-- >>> import qualified Data.Set as S +-- >>> import Data.Semigroup +-- >>> S.mapMonotonic getProduct (inverseJordan (S.singleton . Product) 192) +-- fromList [15,16] +-- +-- Similarly to 'inverseTotient', it is possible to count and sum preimages, or +-- get the maximum/minimum preimage. +inverseJordan + :: (Semiring b, Euclidean a, UniqueFactorisation a, Ord a) + => Word + -> (a -> b) + -> a + -> b +inverseJordan k point = invertFunction point (jordanA k) invTotient +{-# SPECIALISE inverseJordan :: Semiring b => Word -> (Int -> b) -> Int -> b #-} +{-# SPECIALISE inverseJordan :: Semiring b => Word -> (Word -> b) -> Word -> b #-} +{-# SPECIALISE inverseJordan :: Semiring b => Word -> (Integer -> b) -> Integer -> b #-} +{-# SPECIALISE inverseJordan :: Semiring b => Word -> (Natural -> b) -> Natural -> b #-} + -- | The inverse for 'sigma' 1 function. -- -- The return value is parameterized by a 'Semiring', which allows @@ -306,12 +336,40 @@ inverseSigma => (a -> b) -> a -> b -inverseSigma point = invertFunction point (sigmaA 1) invSigma +inverseSigma = inverseSigmaK 1 {-# SPECIALISE inverseSigma :: Semiring b => (Int -> b) -> Int -> b #-} {-# SPECIALISE inverseSigma :: Semiring b => (Word -> b) -> Word -> b #-} {-# SPECIALISE inverseSigma :: Semiring b => (Integer -> b) -> Integer -> b #-} {-# SPECIALISE inverseSigma :: Semiring b => (Natural -> b) -> Natural -> b #-} +-- | The inverse for 'sigma_k' function, where 'k' is a nonnegative integer. +-- +-- Generalizes the 'inverseSigma' function, which is 'inverseSigmaK' when 'k' +-- is '1'. +-- +-- The return value is parameterized by a 'Semiring', which allows +-- various applications by providing different (multiplicative) embeddings. +-- E. g., list all preimages (see a helper 'asSetOfPreimages'): +-- +-- >>> import qualified Data.Set as S +-- >>> import Data.Semigroup +-- >>> S.mapMonotonic getProduct (inverseSigmaK 4 (S.singleton . Product) 6651267) +-- fromList [50] +-- +-- Similarly to 'inverseSigma', it is possible to count and sum preimages, or +-- get the maximum/minimum preimage. +inverseSigmaK + :: (Semiring b, Euclidean a, UniqueFactorisation a, Integral a, Enum (Prime a), Bits a) + => Word + -> (a -> b) + -> a + -> b +inverseSigmaK k point = invertFunction point (sigmaA k) invSigma +{-# SPECIALISE inverseSigmaK :: Semiring b => Word -> (Int -> b) -> Int -> b #-} +{-# SPECIALISE inverseSigmaK :: Semiring b => Word -> (Word -> b) -> Word -> b #-} +{-# SPECIALISE inverseSigmaK :: Semiring b => Word -> (Integer -> b) -> Integer -> b #-} +{-# SPECIALISE inverseSigmaK :: Semiring b => Word -> (Natural -> b) -> Natural -> b #-} + -------------------------------------------------------------------------------- -- Wrappers diff --git a/Math/NumberTheory/Quadratic/EisensteinIntegers.hs b/Math/NumberTheory/Quadratic/EisensteinIntegers.hs index 071a1de79..9e0f2308a 100644 --- a/Math/NumberTheory/Quadratic/EisensteinIntegers.hs +++ b/Math/NumberTheory/Quadratic/EisensteinIntegers.hs @@ -303,8 +303,7 @@ divideByPrime p p' np k = go k 0 where (d1, z') = go1 c 0 z d2 = c - d1 - z'' = head $ drop (wordToInt d2) - $ iterate (\g -> fromMaybe err $ (g * unPrime p) `quotEvenI` np) z' + z'' = iterate (\g -> fromMaybe err $ (g * unPrime p) `quotEvenI` np) z' !! max 0 (wordToInt d2) go1 :: Word -> Word -> EisensteinInteger -> (Word, EisensteinInteger) go1 0 d z = (d, z) diff --git a/test-suite/Math/NumberTheory/ArithmeticFunctions/InverseTests.hs b/test-suite/Math/NumberTheory/ArithmeticFunctions/InverseTests.hs index 623f7d4c9..852972b8b 100644 --- a/test-suite/Math/NumberTheory/ArithmeticFunctions/InverseTests.hs +++ b/test-suite/Math/NumberTheory/ArithmeticFunctions/InverseTests.hs @@ -36,9 +36,28 @@ import Math.NumberTheory.TestUtils totientProperty1 :: forall a. (Euclidean a, Integral a, UniqueFactorisation a) => Positive a -> Bool totientProperty1 (Positive x) = x `S.member` asSetOfPreimages inverseTotient (totient x) +jordanProperty1 + :: (Euclidean a, Integral a, UniqueFactorisation a) + => Power Word + -> Positive a + -> Bool +jordanProperty1 (Power k') (Positive x) = + -- 'k' shouldn't be large to avoid slow tests. + let k = succ $ k' `Prelude.div` 50 + in x `S.member` asSetOfPreimages (inverseJordan k) (jordan k x) + totientProperty2 :: (Euclidean a, Integral a, UniqueFactorisation a) => Positive a -> Bool totientProperty2 (Positive x) = all (== x) (S.map totient (asSetOfPreimages inverseTotient x)) +jordanProperty2 + :: (Euclidean a, Integral a, UniqueFactorisation a, Ord a) + => Power Word + -> Positive a + -> Bool +jordanProperty2 (Power k') (Positive x) = + let k = succ $ k' `Prelude.div` 50 + in all (== x) (S.map (jordan k) (asSetOfPreimages (inverseJordan k) x)) + -- | http://oeis.org/A055506 totientCountFactorial :: [Word] totientCountFactorial = @@ -132,15 +151,74 @@ totientSpecialCases3 = zipWith mkAssert (tail factorial) totientMaxFactorial totientMax :: Word -> Word totientMax = unMaxWord . inverseTotient MaxWord +jordans5 :: [Word] +jordans5 = + [ 1 + , 31 + , 242 + , 992 + , 3124 + , 7502 + , 16806 + , 31744 + , 58806 + , 96844 + , 161050 + , 240064 + , 371292 + , 520986 + , 756008 + , 1015808 + , 1419856 + , 1822986 + , 2476098 + , 3099008 + , 4067052 + , 4992550 + , 6436342 + , 7682048 + , 9762500 + , 11510052 + , 14289858 + , 16671552 + , 20511148 + ] + +jordanSpecialCase1 :: [Assertion] +jordanSpecialCase1 = zipWith mkAssert ixs jordans5 + where + mkAssert a b = assertEqual "should be equal" (S.singleton a) (asSetOfPreimages (inverseJordan 5) b) + ixs = [1 .. 29] + ------------------------------------------------------------------------------- -- Sigma sigmaProperty1 :: forall a. (Euclidean a, UniqueFactorisation a, Integral a, Enum (Prime a), Bits a) => Positive a -> Bool sigmaProperty1 (Positive x) = x `S.member` asSetOfPreimages inverseSigma (sigma 1 x) +sigmaKProperty1 + :: forall a + . (Euclidean a, UniqueFactorisation a, Integral a, Enum (Prime a), Bits a) + => Power Word + -> Positive a + -> Bool +sigmaKProperty1 (Power k') (Positive x) = + -- 'k' shouldn't be large to avoid slow tests. + let k = 2 + k' `Prelude.mod` 50 + in x `S.member` asSetOfPreimages (inverseSigmaK k) (sigma k x) + sigmaProperty2 :: (Euclidean a, UniqueFactorisation a, Integral a, Enum (Prime a), Bits a) => Positive a -> Bool sigmaProperty2 (Positive x) = all (== x) (S.map (sigma 1) (asSetOfPreimages inverseSigma x)) +sigmaKProperty2 + :: (Euclidean a, UniqueFactorisation a, Integral a, Enum (Prime a), Bits a) + => Power Word + -> Positive a + -> Bool +sigmaKProperty2 (Power k') (Positive x) = + let k = 2 + k' `Prelude.mod` 50 + in all (== x) (S.map (sigma k) (asSetOfPreimages (inverseSigmaK k) x)) + -- | http://oeis.org/A055486 sigmaCountFactorial :: [Word] sigmaCountFactorial = @@ -260,4 +338,16 @@ testSuite = testGroup "Inverse" , testGroup "max" (zipWith (\i a -> testCase ("factorial " ++ show i) a) [1..] sigmaSpecialCases3) ] + + , testGroup "Jordan" + [ testIntegralPropertyNoLarge2 "forward" jordanProperty1 + , testIntegralPropertyNoLarge2 "backward" jordanProperty2 + , testGroup "inverseJordan" + (zipWith (\i test -> testCase ("inverseJordan 5" ++ show i) test) jordans5 jordanSpecialCase1) + ] + + , testGroup "SigmaK" + [ testIntegralPropertyNoLarge2 "forward" sigmaKProperty1 + , testIntegralPropertyNoLarge2 "backward" sigmaKProperty2 + ] ] diff --git a/test-suite/Math/NumberTheory/TestUtils.hs b/test-suite/Math/NumberTheory/TestUtils.hs index 182a78f9e..f1aac7f74 100644 --- a/test-suite/Math/NumberTheory/TestUtils.hs +++ b/test-suite/Math/NumberTheory/TestUtils.hs @@ -12,7 +12,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -34,6 +33,7 @@ module Math.NumberTheory.TestUtils , NonZero(..) , testIntegralProperty , testIntegralPropertyNoLarge + , testIntegralPropertyNoLarge2 , testSameIntegralProperty , testSameIntegralProperty3 , testIntegral2Property @@ -153,6 +153,16 @@ testIntegralPropertyNoLarge name f = testGroup name , QC.testProperty "quickcheck Natural" (f :: wrapper Natural -> bool) ] +testIntegralPropertyNoLarge2 + :: forall wrapper1 wrapper2 bool. (TestableIntegral wrapper1, TestableIntegral wrapper2, SC.Testable IO bool, QC.Testable bool) + => String -> (forall a. (Euclidean a, Semiring a, Integral a, Bits a, UniqueFactorisation a, Show a, Enum (Prime a)) => wrapper1 Word -> wrapper2 a -> bool) -> TestTree +testIntegralPropertyNoLarge2 name f = testGroup name + [ SC.testProperty "smallcheck Integer" (f :: wrapper1 Word -> wrapper2 Integer -> bool) + , SC.testProperty "smallcheck Natural" (f :: wrapper1 Word -> wrapper2 Natural -> bool) + , QC.testProperty "quickcheck Integer" (f :: wrapper1 Word -> wrapper2 Integer -> bool) + , QC.testProperty "quickcheck Natural" (f :: wrapper1 Word -> wrapper2 Natural -> bool) + ] + testSameIntegralProperty :: forall wrapper1 wrapper2 bool. (TestableIntegral wrapper1, TestableIntegral wrapper2, SC.Testable IO bool, QC.Testable bool) => String -> (forall a. (GcdDomain a, Euclidean a, Integral a, Bits a, UniqueFactorisation a, Show a) => wrapper1 a -> wrapper2 a -> bool) -> TestTree