diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,12 +1,39 @@ # Change log for galois-field +## 1.0.0 + +* Refactor library structure from `GaloisField` to `Data.Field.Galois`. +* Add `Field` export for Galois fields. +* Add `Semiring` dependency for Galois fields. +* Rename `PrimeField` to `Prime` and add `PrimeField` class. +* Rename `ExtensionField` to `Extension` and add `ExtensionField` class. +* Rename `BinaryField` to `Binary` and add `BinaryField` class. +* Rename `split` to `poly` and swap `IrreducibleMonic` parameters. +* Rename `toInt`, `toField`, `fromField` to `from`, `to` conversion functions. +* Replace `Integer` with `Natural`. +* Add `CyclicSubgroup` class with generator function. +* Add `RootsOfUnity` type with cofactor, check, and conversion functions. +* Add `TowerOfFields` class with embed and scalar multiplication functions. +* Add `Bounded` instances for prime fields and binary fields. +* Add `Enum` instances for prime fields and binary fields. +* Add `Group` instances for Galois fields. +* Add `Hashable` instances for prime fields and binary fields. +* Add `Integral` instances for prime fields and binary fields. +* Add `IsList` instances for Galois fields. +* Add `Real` instances for prime fields and binary fields. +* Add `rndR` function for Galois fields. +* Add `conj` function for extension fields. +* Add minor optimisations to exponentiation with `SPECIALISE`. +* Add major optimisations to `frob` function. +* Add pattern synonyms for field elements. + ## 0.4.1 * Add compilation optimisations with `INLINABLE`. ## 0.4.0 -* Add `Vector` implementation of extension fields. +* Add `Poly` dependency for extension fields. * Add `qnr` function for Galois fields. * Add `qr` function for Galois fields. * Add `quad` function for extension fields and binary fields. @@ -14,6 +41,7 @@ * Add `Semiring` instances for Galois fields. * Add `Ord` instances for Galois fields. * Add minor optimisations to exponentiation with `RULES`. +* Add pattern synonyms for monic monomials. ## 0.3.0 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -27,9 +27,9 @@ ### Extension fields -Any Galois field has order a prime power p^q for prime p and positive q, and there is a Galois field GF(p^q) of any prime power order p^q that is *unique up to non-unique isomorphism*. Any Galois field GF(p^q) can be constructed as an **extension field** over a smaller Galois subfield GF(p^r), through the identification GF(p^q) = GF(p^r)[X] / \ for an *irreducible monic splitting polynomial* f(X) of degree q - r + 1 in the *polynomial ring* GF(p^r)[X]. +Any Galois field has order a prime power p^q for prime p and positive q, and there is a Galois field GF(p^q) of any prime power order p^q that is *unique up to non-unique isomorphism*. Any Galois field GF(p^q) can be constructed as an **extension field** over a smaller Galois subfield GF(p^r), through the identification GF(p^q) = GF(p^r)[X] / \ for an *irreducible monic polynomial* f(X) of degree q - r + 1 in the *polynomial ring* GF(p^r)[X]. -For example, GF(4) has order 2^2 and can be constructed as an extension field GF(2)[X] / \ where f(X) = X^2 + X + 1 is an irreducible monic splitting quadratic polynomial in GF(2)[X]. +For example, GF(4) has order 2^2 and can be constructed as an extension field GF(2)[X] / \ where f(X) = X^2 + X + 1 is an irreducible monic quadratic polynomial in GF(2)[X]. ### Binary fields @@ -44,21 +44,20 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE PatternSynonyms #-} ``` Import the following functions at minimum. ```haskell -import PrimeField (PrimeField) -import ExtensionField (ExtensionField, IrreducibleMonic(split), toField, - pattern X, pattern X2, pattern X3, pattern Y) -import BinaryField (BinaryField) +import Data.Field.Galois (Prime, Extension, IrreducibleMonic(poly), Binary, + pattern X, pattern X2, pattern X3, pattern Y) ``` ### Prime fields The following type declaration creates a prime field of a given characteristic. ```haskell -type Fq = PrimeField 21888242871839275222246405745257275088696311157297823662689037894645226208583 +type Fq = Prime 21888242871839275222246405745257275088696311157297823662689037894645226208583 ``` Note that the characteristic given *must* be prime. @@ -76,95 +75,79 @@ ### Extension fields -The following data type declaration creates a splitting polynomial given an irreducible monic polynomial. +The following data type declaration creates a polynomial given an irreducible monic polynomial. ```haskell data P2 -instance IrreducibleMonic Fq P2 where - split _ = X2 + 1 +instance IrreducibleMonic P2 Fq where + poly _ = X2 + 1 ``` -The following type declaration then creates an extension field with this splitting polynomial. +The following type declaration then creates an extension field with this polynomial. ```haskell -type Fq2 = ExtensionField Fq P2 +type Fq2 = Extension P2 Fq ``` -Note that the splitting polynomial given *must* be irreducible and monic in the prime field. +Note that the polynomial given *must* be irreducible and monic in the prime field. Similarly, further extension fields can be constructed iteratively as follows. ```haskell data P6 -instance IrreducibleMonic Fq2 P6 where - split _ = X3 - (9 + Y X) +instance IrreducibleMonic P6 Fq2 where + poly _ = X3 - (9 + Y X) -type Fq6 = ExtensionField Fq2 P6 +type Fq6 = Extension P6 Fq2 data P12 -instance IrreducibleMonic Fq6 P12 where - split _ = X2 - Y X +instance IrreducibleMonic P12 Fq6 where + poly _ = X2 - Y X -type Fq12 = ExtensionField Fq6 P12 +type Fq12 = Extension P12 Fq6 ``` Note that `X, X2, X3` accesses the current indeterminate variables and `Y` descends the tower of indeterminate variables. Galois field arithmetic can then be performed in this extension field. ```haskell fq12 :: Fq12 -fq12 = toField - [ toField - [ toField - [ 4025484419428246835913352650763180341703148406593523188761836807196412398582 +fq12 = + [ [ [ 4025484419428246835913352650763180341703148406593523188761836807196412398582 , 5087667423921547416057913184603782240965080921431854177822601074227980319916 ] - , toField - [ 8868355606921194740459469119392835913522089996670570126495590065213716724895 + , [ 8868355606921194740459469119392835913522089996670570126495590065213716724895 , 12102922015173003259571598121107256676524158824223867520503152166796819430680 ] - , toField - [ 92336131326695228787620679552727214674825150151172467042221065081506740785 + , [ 92336131326695228787620679552727214674825150151172467042221065081506740785 , 5482141053831906120660063289735740072497978400199436576451083698548025220729 ] ] - , toField - [ toField - [ 7642691434343136168639899684817459509291669149586986497725240920715691142493 + , [ [ 7642691434343136168639899684817459509291669149586986497725240920715691142493 , 1211355239100959901694672926661748059183573115580181831221700974591509515378 ] - , toField - [ 20725578899076721876257429467489710434807801418821512117896292558010284413176 + , [ 20725578899076721876257429467489710434807801418821512117896292558010284413176 , 17642016461759614884877567642064231230128683506116557502360384546280794322728 ] - , toField - [ 17449282511578147452934743657918270744212677919657988500433959352763226500950 + , [ 17449282511578147452934743657918270744212677919657988500433959352763226500950 , 1205855382909824928004884982625565310515751070464736233368671939944606335817 ] ] ] fq12' :: Fq12 -fq12' = toField - [ toField - [ toField - [ 495492586688946756331205475947141303903957329539236899715542920513774223311 +fq12' = + [ [ [ 495492586688946756331205475947141303903957329539236899715542920513774223311 , 9283314577619389303419433707421707208215462819919253486023883680690371740600 ] - , toField - [ 11142072730721162663710262820927009044232748085260948776285443777221023820448 + , [ 11142072730721162663710262820927009044232748085260948776285443777221023820448 , 1275691922864139043351956162286567343365697673070760209966772441869205291758 ] - , toField - [ 20007029371545157738471875537558122753684185825574273033359718514421878893242 + , [ 20007029371545157738471875537558122753684185825574273033359718514421878893242 , 9839139739201376418106411333971304469387172772449235880774992683057627654905 ] ] - , toField - [ toField - [ 9503058454919356208294350412959497499007919434690988218543143506584310390240 + , [ [ 9503058454919356208294350412959497499007919434690988218543143506584310390240 , 19236630380322614936323642336645412102299542253751028194541390082750834966816 ] - , toField - [ 18019769232924676175188431592335242333439728011993142930089933693043738917983 + , [ 18019769232924676175188431592335242333439728011993142930089933693043738917983 , 11549213142100201239212924317641009159759841794532519457441596987622070613872 ] - , toField - [ 9656683724785441232932664175488314398614795173462019188529258009817332577664 + , [ 9656683724785441232932664175488314398614795173462019188529258009817332577664 , 20666848762667934776817320505559846916719041700736383328805334359135638079015 ] ] @@ -179,17 +162,17 @@ ``` where `X, Y, Z` is a tower of indeterminate variables, is constructed by ```haskell -toField [ toField [toField [a, b], toField [c, d], toField [e, f]] - , toField [toField [g, h], toField [i, j], toField [k, l]] ] :: Fq12 +[ [ [a, b], [c, d], [e, f] ] +, [ [g, h], [i, j], [k, l] ] ] :: Fq12 ``` ### Binary fields -The following type declaration creates a binary field modulo a given splitting irreducible binary polynomial. +The following type declaration creates a binary field modulo a given irreducible binary polynomial. ```haskell -type F2m = BinaryField 0x80000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000425 +type F2m = Binary 0x80000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000425 ``` -Note that the splitting polynomial given *must* be irreducible in F2. +Note that the polynomial given *must* be irreducible in F2. Galois field arithmetic can then be performed in this binary field. ```haskell diff --git a/bench/Bench/Binary.hs b/bench/Bench/Binary.hs new file mode 100644 --- /dev/null +++ b/bench/Bench/Binary.hs @@ -0,0 +1,20 @@ +module Bench.Binary where + +import Protolude + +import Control.Monad.Random +import Criterion.Main +import Data.Field.Galois + +import Bench.Galois + +type F2m = Binary 0x80000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000425 + +f2m :: F2m +f2m = evalRand getRandom $ mkStdGen 0 + +f2m' :: F2m +f2m' = evalRand getRandom $ mkStdGen 1 + +benchBinary :: Benchmark +benchBinary = benchmark "Binary" f2m f2m' diff --git a/bench/Bench/Extension.hs b/bench/Bench/Extension.hs new file mode 100644 --- /dev/null +++ b/bench/Bench/Extension.hs @@ -0,0 +1,34 @@ +module Bench.Extension where + +import Protolude + +import Control.Monad.Random +import Criterion.Main +import Data.Field.Galois + +import Bench.Galois +import Bench.Prime + +data PU +instance IrreducibleMonic PU Fq where + poly _ = X2 + 1 +type Fq2 = Extension PU Fq + +data PV +instance IrreducibleMonic PV Fq2 where + poly _ = X3 - 9 - Y X +type Fq6 = Extension PV Fq2 + +data PW +instance IrreducibleMonic PW Fq6 where + poly _ = X2 - Y X +type Fq12 = Extension PW Fq6 + +fq12 :: Fq12 +fq12 = evalRand getRandom $ mkStdGen 0 + +fq12' :: Fq12 +fq12' = evalRand getRandom $ mkStdGen 1 + +benchExtension :: Benchmark +benchExtension = benchmark "Extension" fq12 fq12' diff --git a/bench/Bench/Galois.hs b/bench/Bench/Galois.hs new file mode 100644 --- /dev/null +++ b/bench/Bench/Galois.hs @@ -0,0 +1,27 @@ +module Bench.Galois where + +import Protolude + +import Criterion.Main +import Data.Field.Galois hiding (recip, (/)) +import GHC.Base + +benchmark :: GaloisField k => String -> k -> k -> Benchmark +benchmark s a b = bgroup s + [ bench "Addition" $ + nf (uncurry (+)) (a, b) + , bench "Multiplication" $ + nf (uncurry (*)) (a, b) + , bench "Negation" $ + nf negate a + , bench "Subtraction" $ + nf (uncurry (-)) (a, b) + , bench "Inversion" $ + nf recip a + , bench "Division" $ + nf (uncurry (/)) (a, b) + , bench "Frobenius endomorphism" $ + nf frob a + , bench "Square root" $ + nf sr a + ] diff --git a/bench/Bench/Prime.hs b/bench/Bench/Prime.hs new file mode 100644 --- /dev/null +++ b/bench/Bench/Prime.hs @@ -0,0 +1,20 @@ +module Bench.Prime where + +import Protolude + +import Control.Monad.Random +import Criterion.Main +import Data.Field.Galois + +import Bench.Galois + +type Fq = Prime 21888242871839275222246405745257275088696311157297823662689037894645226208583 + +fq :: Fq +fq = evalRand getRandom $ mkStdGen 0 + +fq' :: Fq +fq' = evalRand getRandom $ mkStdGen 1 + +benchPrime :: Benchmark +benchPrime = benchmark "Prime" fq fq' diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 --- /dev/null +++ b/bench/Main.hs @@ -0,0 +1,13 @@ +module Main where + +import Protolude + +import Criterion.Main + +import Bench.Binary +import Bench.Extension +import Bench.Prime + +main :: IO () +main = defaultMain + [benchBinary, benchExtension, benchPrime] diff --git a/benchmarks/BinaryFieldBenchmarks.hs b/benchmarks/BinaryFieldBenchmarks.hs deleted file mode 100644 --- a/benchmarks/BinaryFieldBenchmarks.hs +++ /dev/null @@ -1,17 +0,0 @@ -module BinaryFieldBenchmarks where - -import BinaryField -import Criterion.Main - -import GaloisFieldBenchmarks - -type F2m = BinaryField 0x80000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000425 - -f2m :: F2m -f2m = 0x303001d34b856296c16c0d40d3cd7750a93d1d2955fa80aa5f40fc8db7b2abdbde53950f4c0d293cdd711a35b67fb1499ae60038614f1394abfa3b4c850d927e1e7769c8eec2d19 - -f2m' :: F2m -f2m' = 0x37bf27342da639b6dccfffeb73d69d78c6c27a6009cbbca1980f8533921e8a684423e43bab08a576291af8f461bb2a8b3531d2f0485c19b16e2f1516e23dd3c1a4827af1b8ac15b - -benchmarkBinaryField :: Benchmark -benchmarkBinaryField = benchmark "BinaryField F2m" f2m f2m' diff --git a/benchmarks/ExtensionFieldBenchmarks.hs b/benchmarks/ExtensionFieldBenchmarks.hs deleted file mode 100644 --- a/benchmarks/ExtensionFieldBenchmarks.hs +++ /dev/null @@ -1,91 +0,0 @@ -module ExtensionFieldBenchmarks where - -import Protolude - -import Criterion.Main -import ExtensionField - -import GaloisFieldBenchmarks -import PrimeFieldBenchmarks - -data Pu -instance IrreducibleMonic Fq Pu where - split _ = X2 + 1 -type Fq2 = ExtensionField Fq Pu - -data Pv -instance IrreducibleMonic Fq2 Pv where - split _ = X3 - 9 - Y X -type Fq6 = ExtensionField Fq2 Pv - -data Pw -instance IrreducibleMonic Fq6 Pw where - split _ = X2 - Y X -type Fq12 = ExtensionField Fq6 Pw - -fq12 :: Fq12 -fq12 = toField - [ toField - [ toField - [ 4025484419428246835913352650763180341703148406593523188761836807196412398582 - , 5087667423921547416057913184603782240965080921431854177822601074227980319916 - ] - , toField - [ 8868355606921194740459469119392835913522089996670570126495590065213716724895 - , 12102922015173003259571598121107256676524158824223867520503152166796819430680 - ] - , toField - [ 92336131326695228787620679552727214674825150151172467042221065081506740785 - , 5482141053831906120660063289735740072497978400199436576451083698548025220729 - ] - ] - , toField - [ toField - [ 7642691434343136168639899684817459509291669149586986497725240920715691142493 - , 1211355239100959901694672926661748059183573115580181831221700974591509515378 - ] - , toField - [ 20725578899076721876257429467489710434807801418821512117896292558010284413176 - , 17642016461759614884877567642064231230128683506116557502360384546280794322728 - ] - , toField - [ 17449282511578147452934743657918270744212677919657988500433959352763226500950 - , 1205855382909824928004884982625565310515751070464736233368671939944606335817 - ] - ] - ] - -fq12' :: Fq12 -fq12' = toField - [ toField - [ toField - [ 495492586688946756331205475947141303903957329539236899715542920513774223311 - , 9283314577619389303419433707421707208215462819919253486023883680690371740600 - ] - , toField - [ 11142072730721162663710262820927009044232748085260948776285443777221023820448 - , 1275691922864139043351956162286567343365697673070760209966772441869205291758 - ] - , toField - [ 20007029371545157738471875537558122753684185825574273033359718514421878893242 - , 9839139739201376418106411333971304469387172772449235880774992683057627654905 - ] - ] - , toField - [ toField - [ 9503058454919356208294350412959497499007919434690988218543143506584310390240 - , 19236630380322614936323642336645412102299542253751028194541390082750834966816 - ] - , toField - [ 18019769232924676175188431592335242333439728011993142930089933693043738917983 - , 11549213142100201239212924317641009159759841794532519457441596987622070613872 - ] - , toField - [ 9656683724785441232932664175488314398614795173462019188529258009817332577664 - , 20666848762667934776817320505559846916719041700736383328805334359135638079015 - ] - ] - ] - -benchmarkExtensionField :: Benchmark -benchmarkExtensionField = benchmark "ExtensionField Fq12" fq12 fq12' diff --git a/benchmarks/GaloisFieldBenchmarks.hs b/benchmarks/GaloisFieldBenchmarks.hs deleted file mode 100644 --- a/benchmarks/GaloisFieldBenchmarks.hs +++ /dev/null @@ -1,23 +0,0 @@ -module GaloisFieldBenchmarks where - -import Protolude - -import Criterion.Main -import GaloisField -import GHC.Base - -benchmark :: GaloisField k => String -> k -> k -> Benchmark -benchmark s a b = bgroup s - [ bench "Addition" $ - whnf (uncurry (+)) (a, b) - , bench "Multiplication" $ - whnf (uncurry (*)) (a, b) - , bench "Negation" $ - whnf negate a - , bench "Subtraction" $ - whnf (uncurry (-)) (a, b) - , bench "Inversion" $ - whnf recip a - , bench "Division" $ - whnf (uncurry (/)) (a, b) - ] diff --git a/benchmarks/Main.hs b/benchmarks/Main.hs deleted file mode 100644 --- a/benchmarks/Main.hs +++ /dev/null @@ -1,13 +0,0 @@ -module Main where - -import Protolude - -import Criterion.Main - -import BinaryFieldBenchmarks -import ExtensionFieldBenchmarks -import PrimeFieldBenchmarks - -main :: IO () -main = defaultMain - [benchmarkBinaryField, benchmarkExtensionField, benchmarkPrimeField] diff --git a/benchmarks/PrimeFieldBenchmarks.hs b/benchmarks/PrimeFieldBenchmarks.hs deleted file mode 100644 --- a/benchmarks/PrimeFieldBenchmarks.hs +++ /dev/null @@ -1,17 +0,0 @@ -module PrimeFieldBenchmarks where - -import Criterion.Main -import PrimeField - -import GaloisFieldBenchmarks - -type Fq = PrimeField 21888242871839275222246405745257275088696311157297823662689037894645226208583 - -fq :: Fq -fq = 5216004179354450092383934373463611881445186046129513844852096383579774061693 - -fq' :: Fq -fq' = 10757805228921058098980668000791497318123219899766237205512608761387909753942 - -benchmarkPrimeField :: Benchmark -benchmarkPrimeField = benchmark "PrimeField Fq" fq fq' diff --git a/galois-field.cabal b/galois-field.cabal --- a/galois-field.cabal +++ b/galois-field.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 4e436d9365d8254a628fd2f0a1ce476eb6073af326050f22b8aac993adf97375 +-- hash: 4ec66cf45e03db7c043a78fe75435c0909e60ebf77e5ef4a2adef098ba4b12b9 name: galois-field -version: 0.4.1 +version: 1.0.0 synopsis: Galois field library description: An efficient implementation of Galois fields used in cryptography research category: Cryptography @@ -27,23 +27,28 @@ library exposed-modules: - BinaryField - ExtensionField - GaloisField - PrimeField + Data.Field.Galois other-modules: - Paths_galois_field + Data.Field.Galois.Base + Data.Field.Galois.Binary + Data.Field.Galois.Extension + Data.Field.Galois.Frobenius + Data.Field.Galois.Prime + Data.Field.Galois.Sqrt + Data.Field.Galois.Tower + Data.Field.Galois.Unity hs-source-dirs: src - default-extensions: LambdaCase RecordWildCards OverloadedStrings NoImplicitPrelude FlexibleInstances FlexibleContexts ScopedTypeVariables RankNTypes DataKinds DeriveGeneric GeneralizedNewtypeDeriving KindSignatures MultiParamTypeClasses PatternSynonyms - ghc-options: -Wall + default-extensions: LambdaCase RecordWildCards OverloadedStrings NoImplicitPrelude FlexibleInstances FlexibleContexts ScopedTypeVariables RankNTypes DataKinds DeriveFunctor DeriveGeneric GeneralizedNewtypeDeriving KindSignatures MultiParamTypeClasses OverloadedLists PatternSynonyms TypeFamilies + ghc-options: -freverse-errors -O2 -Wall build-depends: MonadRandom , base >=4.10 && <5 + , groups , integer-gmp - , poly - , protolude - , semirings + , poly >=0.3.2 + , protolude >=0.2 && <0.3 + , semirings >=0.5 , tasty-quickcheck , vector , wl-pprint-text @@ -53,27 +58,24 @@ type: exitcode-stdio-1.0 main-is: Main.hs other-modules: - BinaryFieldTests - ExtensionFieldTests - GaloisFieldTests - PrimeFieldTests - BinaryField - ExtensionField - GaloisField - PrimeField + Test.Binary + Test.Extension + Test.Galois + Test.Prime Paths_galois_field hs-source-dirs: - tests - src - default-extensions: LambdaCase RecordWildCards OverloadedStrings NoImplicitPrelude FlexibleInstances FlexibleContexts ScopedTypeVariables RankNTypes DataKinds DeriveGeneric GeneralizedNewtypeDeriving KindSignatures MultiParamTypeClasses PatternSynonyms - ghc-options: -Wall -main-is Main + test + default-extensions: LambdaCase RecordWildCards OverloadedStrings NoImplicitPrelude FlexibleInstances FlexibleContexts ScopedTypeVariables RankNTypes DataKinds DeriveFunctor DeriveGeneric GeneralizedNewtypeDeriving KindSignatures MultiParamTypeClasses OverloadedLists PatternSynonyms TypeFamilies + ghc-options: -freverse-errors -O2 -Wall -main-is Main build-depends: MonadRandom , base >=4.10 && <5 + , galois-field + , groups , integer-gmp - , poly - , protolude - , semirings + , poly >=0.3.2 + , protolude >=0.2 && <0.3 + , semirings >=0.5 , tasty , tasty-quickcheck , vector @@ -84,28 +86,25 @@ type: exitcode-stdio-1.0 main-is: Main.hs other-modules: - BinaryFieldBenchmarks - ExtensionFieldBenchmarks - GaloisFieldBenchmarks - PrimeFieldBenchmarks - BinaryField - ExtensionField - GaloisField - PrimeField + Bench.Binary + Bench.Extension + Bench.Galois + Bench.Prime Paths_galois_field hs-source-dirs: - benchmarks - src - default-extensions: LambdaCase RecordWildCards OverloadedStrings NoImplicitPrelude FlexibleInstances FlexibleContexts ScopedTypeVariables RankNTypes DataKinds DeriveGeneric GeneralizedNewtypeDeriving KindSignatures MultiParamTypeClasses PatternSynonyms - ghc-options: -Wall -main-is Main + bench + default-extensions: LambdaCase RecordWildCards OverloadedStrings NoImplicitPrelude FlexibleInstances FlexibleContexts ScopedTypeVariables RankNTypes DataKinds DeriveFunctor DeriveGeneric GeneralizedNewtypeDeriving KindSignatures MultiParamTypeClasses OverloadedLists PatternSynonyms TypeFamilies + ghc-options: -freverse-errors -O2 -Wall -main-is Main build-depends: MonadRandom , base >=4.10 && <5 , criterion + , galois-field + , groups , integer-gmp - , poly - , protolude - , semirings + , poly >=0.3.2 + , protolude >=0.2 && <0.3 + , semirings >=0.5 , tasty-quickcheck , vector , wl-pprint-text diff --git a/src/BinaryField.hs b/src/BinaryField.hs deleted file mode 100644 --- a/src/BinaryField.hs +++ /dev/null @@ -1,179 +0,0 @@ -module BinaryField - ( BinaryField - ) where - -import Protolude as P hiding (Semiring) - -import Control.Monad.Random (Random(..)) -import Data.Euclidean (Euclidean(..), GcdDomain(..)) -import Data.Semiring (Ring(..), Semiring(..)) -import Test.Tasty.QuickCheck (Arbitrary(..), choose) -import Text.PrettyPrint.Leijen.Text (Pretty(..)) - -import GaloisField (Field(..), GaloisField(..)) - -------------------------------------------------------------------------------- --- Data types -------------------------------------------------------------------------------- - --- | Binary fields @GF(2^q)[X]/\@ for @q@ positive and --- @f(X)@ irreducible monic in @GF(2^q)[X]@ encoded as an integer. -newtype BinaryField (im :: Nat) = BF Integer - deriving (Eq, Generic, Ord, Show) - --- Binary fields are Galois fields. -instance KnownNat im => GaloisField (BinaryField im) where - char = const 2 - {-# INLINABLE char #-} - deg = binLog . natVal - {-# INLINABLE deg #-} - frob = flip pow 2 - {-# INLINABLE frob #-} - -{-# RULES "BinaryField/pow" - forall (k :: KnownNat im => BinaryField im) n . (^) k n = pow k n - #-} - -------------------------------------------------------------------------------- --- Numeric instances -------------------------------------------------------------------------------- - --- Binary fields are fractional. -instance KnownNat im => Fractional (BinaryField im) where - recip (BF x) = BF (binInv x (natVal (witness :: BinaryField im))) - {-# INLINE recip #-} - fromRational (x:%y) = fromInteger x / fromInteger y - {-# INLINABLE fromRational #-} - --- Binary fields are numeric. -instance KnownNat im => Num (BinaryField im) where - BF x + BF y = BF (xor x y) - {-# INLINE (+) #-} - BF x * BF y = BF (binMul (natVal (witness :: BinaryField im)) x y) - {-# INLINE (*) #-} - BF x - BF y = BF (xor x y) - {-# INLINE (-) #-} - negate = identity - {-# INLINE negate #-} - fromInteger = BF . binMod (natVal (witness :: BinaryField im)) - {-# INLINABLE fromInteger #-} - abs = panic "not implemented." - signum = panic "not implemented." - -------------------------------------------------------------------------------- --- Semiring instances -------------------------------------------------------------------------------- - --- Binary fields are Euclidean domains. -instance KnownNat im => Euclidean (BinaryField im) where - quotRem = (flip (,) 0 .) . (/) - {-# INLINE quotRem #-} - degree = panic "not implemented." - --- Binary fields are fields. -instance KnownNat im => Field (BinaryField im) where - invert = recip - {-# INLINE invert #-} - minus = (-) - {-# INLINE minus #-} - --- Binary fields are GCD domains. -instance KnownNat im => GcdDomain (BinaryField im) - --- Binary fields are rings. -instance KnownNat im => Ring (BinaryField im) where - negate = P.negate - {-# INLINE negate #-} - --- Binary fields are semirings. -instance KnownNat im => Semiring (BinaryField im) where - zero = 0 - {-# INLINE zero #-} - plus = (+) - {-# INLINE plus #-} - one = 1 - {-# INLINE one #-} - times = (*) - {-# INLINE times #-} - fromNatural = fromIntegral - {-# INLINABLE fromNatural #-} - -------------------------------------------------------------------------------- --- Other instances -------------------------------------------------------------------------------- - --- Binary fields are arbitrary. -instance KnownNat im => Arbitrary (BinaryField im) where - arbitrary = BF <$> choose (0, order (witness :: BinaryField im) - 1) - {-# INLINABLE arbitrary #-} - --- Binary fields are pretty. -instance KnownNat im => Pretty (BinaryField im) where - pretty (BF x) = pretty x - --- Binary fields are random. -instance KnownNat im => Random (BinaryField im) where - random = first BF . randomR (0, order (witness :: BinaryField im) - 1) - {-# INLINABLE random #-} - randomR = panic "not implemented." - -------------------------------------------------------------------------------- --- Binary arithmetic -------------------------------------------------------------------------------- - --- Binary logarithm. -binLog :: Integer -> Int -binLog = binLog' 2 - where - binLog' :: Integer -> Integer -> Int - binLog' p x - | x < p = 0 - | otherwise = case binLog' (p * p) x of - l -> let l' = 2 * l in binLog'' (P.quot x (p ^ l')) l' - where - binLog'' :: Integer -> Int -> Int - binLog'' y n - | y < p = n - | otherwise = binLog'' (P.quot y p) (n + 1) -{-# INLINE binLog #-} - --- Binary multiplication. -binMul :: Integer -> Integer -> Integer -> Integer -binMul = (. binMul' 0) . (.) . binMod - where - binMul' :: Integer -> Integer -> Integer -> Integer - binMul' n x y - | y == 0 = n - | testBit y 0 = binMul' (xor n x) x' y' - | otherwise = binMul' n x' y' - where - x' = shiftL x 1 :: Integer - y' = shiftR y 1 :: Integer -{-# INLINE binMul #-} - --- Binary modulus. -binMod :: Integer -> Integer -> Integer -binMod f = binMod' - where - m = binLog f :: Int - binMod' :: Integer -> Integer - binMod' x - | n < 0 = x - | otherwise = binMod' (xor x (shiftL f n)) - where - n = binLog x - m :: Int -{-# INLINE binMod #-} - --- Binary inversion. -binInv :: Integer -> Integer -> Integer -binInv f x = case binInv' 0 1 x f of - (y, 1) -> y - _ -> panic "no multiplicative inverse." - where - binInv' :: Integer -> Integer -> Integer -> Integer -> (Integer, Integer) - binInv' s s' r r' - | r' == 0 = (s, r) - | otherwise = binInv' s' (xor s (shift s' q)) r' (xor r (shift r' q)) - where - q = max 0 (binLog r - binLog r') :: Int -{-# INLINE binInv #-} diff --git a/src/Data/Field/Galois.hs b/src/Data/Field/Galois.hs new file mode 100644 --- /dev/null +++ b/src/Data/Field/Galois.hs @@ -0,0 +1,26 @@ +module Data.Field.Galois + ( module Data.Field + -- * Galois fields + , module Data.Field.Galois.Base + -- ** Prime fields + , module Data.Field.Galois.Prime + -- ** Extension fields + , module Data.Field.Galois.Extension + -- ** Binary fields + , module Data.Field.Galois.Binary + -- ** Square roots + , module Data.Field.Galois.Sqrt + -- ** Towers of fields + , module Data.Field.Galois.Tower + -- ** Roots of unity + , module Data.Field.Galois.Unity + ) where + +import Data.Field +import Data.Field.Galois.Base +import Data.Field.Galois.Binary +import Data.Field.Galois.Extension +import Data.Field.Galois.Prime +import Data.Field.Galois.Sqrt +import Data.Field.Galois.Tower +import Data.Field.Galois.Unity diff --git a/src/Data/Field/Galois/Base.hs b/src/Data/Field/Galois/Base.hs new file mode 100644 --- /dev/null +++ b/src/Data/Field/Galois/Base.hs @@ -0,0 +1,47 @@ +module Data.Field.Galois.Base + ( module Data.Field.Galois.Base + ) where + +import Protolude hiding ((-), one, quot) + +import Control.Monad.Random (Random) +import Data.Field (Field) +import qualified Data.Group as G (Group(..)) +import GHC.Natural (Natural) +import Test.Tasty.QuickCheck (Arbitrary) +import Text.PrettyPrint.Leijen.Text (Pretty) + +------------------------------------------------------------------------------- +-- Classes +------------------------------------------------------------------------------- + +-- | Galois fields @GF(p^q)@ for @p@ prime and @q@ non-negative. +class (Arbitrary k, Field k, Fractional k, Generic k, G.Group k, + NFData k, Ord k, Pretty k, Random k, Show k) => GaloisField k where + {-# MINIMAL char, deg, frob #-} + + -- | Characteristic @p@ of field and order of prime subfield. + char :: k -> Natural + + -- | Degree @q@ of field as extension field over prime subfield. + deg :: k -> Word + + -- | Frobenius endomorphism @x -> x^p@ of prime subfield. + frob :: k -> k + + -- | Order @p^q@ of field. + order :: k -> Natural + order = (^) <$> char <*> deg + {-# INLINABLE order #-} + +-- | Exponentiation of field element to integer. +pow :: (GaloisField k, Integral n) => k -> n -> k +pow = G.pow +{-# INLINABLE pow #-} + +{-# SPECIALISE pow :: + GaloisField k => k -> Int -> k, + GaloisField k => k -> Integer -> k, + GaloisField k => k -> Natural -> k, + GaloisField k => k -> Word -> k + #-} diff --git a/src/Data/Field/Galois/Binary.hs b/src/Data/Field/Galois/Binary.hs new file mode 100644 --- /dev/null +++ b/src/Data/Field/Galois/Binary.hs @@ -0,0 +1,272 @@ +module Data.Field.Galois.Binary + ( Binary + , BinaryField + , fromB + , toB + , toB' + ) where + +import Protolude as P hiding (Semiring, natVal) + +import Control.Monad.Random (Random(..)) +import Data.Euclidean as S (Euclidean(..), GcdDomain) +import Data.Field (Field) +import Data.Group (Group(..)) +import Data.Semiring (Ring(..), Semiring(..)) +import GHC.Exts (IsList(..)) +import GHC.Natural (Natural, naturalFromInteger, naturalToInteger) +import GHC.TypeNats (natVal) +import Test.Tasty.QuickCheck (Arbitrary(..), choose) +import Text.PrettyPrint.Leijen.Text (Pretty(..)) + +import Data.Field.Galois.Base (GaloisField(..)) + +------------------------------------------------------------------------------- +-- Data types +------------------------------------------------------------------------------- + +-- | Binary fields @GF(2^q)[X]/\@ for @q@ positive and +-- @f(X)@ irreducible monic in @GF(2^q)[X]@ encoded as an integer. +class GaloisField k => BinaryField k where + {-# MINIMAL fromB #-} + -- | Convert from @GF(2^q)[X]/\@ to @Z@. + fromB :: k -> Integer + +-- | Binary field elements. +newtype Binary (p :: Nat) = B Natural + deriving (Bits, Eq, Generic, Hashable, NFData, Ord, Show) + +-- Binary fields are convertible. +instance KnownNat p => BinaryField (Binary p) where + fromB (B x) = naturalToInteger x + {-# INLINABLE fromB #-} + +-- Binary fields are Galois fields. +instance KnownNat p => GaloisField (Binary p) where + char = const 2 + {-# INLINABLE char #-} + deg = binLog . natVal + {-# INLINABLE deg #-} + frob = join (*) + {-# INLINABLE frob #-} + +{-# RULES "Binary.pow" + forall (k :: KnownNat p => Binary p) n . (^) k n = pow k n + #-} + +------------------------------------------------------------------------------- +-- Group instances +------------------------------------------------------------------------------- + +-- Binary fields are multiplicative groups. +instance KnownNat p => Group (Binary p) where + invert = recip + {-# INLINE invert #-} + pow x n + | n >= 0 = x ^ n + | otherwise = recip x ^ P.negate n + {-# INLINE pow #-} + +-- Binary fields are multiplicative monoids. +instance KnownNat p => Monoid (Binary p) where + mempty = B 1 + {-# INLINE mempty #-} + +-- Binary fields are multiplicative semigroups. +instance KnownNat p => Semigroup (Binary p) where + (<>) = (*) + {-# INLINE (<>) #-} + stimes = flip pow + {-# INLINE stimes #-} + +------------------------------------------------------------------------------- +-- Numeric instances +------------------------------------------------------------------------------- + +-- Binary fields are fractional. +instance KnownNat p => Fractional (Binary p) where + recip (B x) = B $ binInv x $ natVal (witness :: Binary p) + {-# INLINE recip #-} + fromRational (x:%y) = fromInteger x / fromInteger y + {-# INLINABLE fromRational #-} + +-- Binary fields are numeric. +instance KnownNat p => Num (Binary p) where + B x + B y = B $ xor x y + {-# INLINE (+) #-} + B x * B y = B $ binMul (natVal (witness :: Binary p)) x y + {-# INLINE (*) #-} + B x - B y = B $ xor x y + {-# INLINE (-) #-} + negate = identity + {-# INLINE negate #-} + fromInteger = B . binMod (natVal (witness :: Binary p)) . naturalFromInteger + {-# INLINABLE fromInteger #-} + abs = panic "Binary.abs: not implemented." + signum = panic "Binary.signum: not implemented." + +------------------------------------------------------------------------------- +-- Semiring instances +------------------------------------------------------------------------------- + +-- Binary fields are Euclidean domains. +instance KnownNat p => Euclidean (Binary p) where + degree = panic "Binary.degree: not implemented." + quotRem = (flip (,) 0 .) . (/) + {-# INLINE quotRem #-} + +-- Binary fields are fields. +instance KnownNat p => Field (Binary p) where + +-- Binary fields are GCD domains. +instance KnownNat p => GcdDomain (Binary p) + +-- Binary fields are rings. +instance KnownNat p => Ring (Binary p) where + negate = P.negate + {-# INLINE negate #-} + +-- Binary fields are semirings. +instance KnownNat p => Semiring (Binary p) where + fromNatural = fromIntegral + {-# INLINABLE fromNatural #-} + one = B 1 + {-# INLINE one #-} + plus = (+) + {-# INLINE plus #-} + times = (*) + {-# INLINE times #-} + zero = B 0 + {-# INLINE zero #-} + +------------------------------------------------------------------------------- +-- Other instances +------------------------------------------------------------------------------- + +-- Binary fields are arbitrary. +instance KnownNat p => Arbitrary (Binary p) where + arbitrary = B . naturalFromInteger <$> + choose (0, naturalToInteger $ order (witness :: Binary p) - 1) + {-# INLINABLE arbitrary #-} + +-- Binary fields are lists. +instance KnownNat p => IsList (Binary p) where + type instance Item (Binary p) = Natural + fromList = fromIntegral . foldr' ((. flip shiftL 1) . (+)) 0 + {-# INLINABLE fromList #-} + toList (B x) = unfoldr unfold x + where + unfold y = if y == 0 then Nothing else Just (y .&. 1, shiftR y 1) + {-# INLINABLE toList #-} + +-- Binary fields are bounded. +instance KnownNat p => Bounded (Binary p) where + maxBound = B $ order (witness :: Binary p) - 1 + {-# INLINE maxBound #-} + minBound = B 0 + {-# INLINE minBound #-} + +-- Binary fields are enumerable. +instance KnownNat p => Enum (Binary p) where + fromEnum = fromIntegral + {-# INLINABLE fromEnum #-} + toEnum = fromIntegral + {-# INLINABLE toEnum #-} + +-- Binary fields are integral. +instance KnownNat p => Integral (Binary p) where + quotRem = S.quotRem + {-# INLINE quotRem #-} + toInteger = fromB + {-# INLINABLE toInteger #-} + +-- Binary fields are pretty. +instance KnownNat p => Pretty (Binary p) where + pretty (B x) = pretty $ naturalToInteger x + +-- Binary fields are random. +instance KnownNat p => Random (Binary p) where + random = randomR (B 0, B $ natVal (witness :: Binary p) - 1) + {-# INLINABLE random #-} + randomR (a, b) = first (B . naturalFromInteger) . randomR (fromB a, fromB b) + {-# INLINABLE randomR #-} + +-- Binary fields are real. +instance KnownNat p => Real (Binary p) where + toRational = fromIntegral + {-# INLINABLE toRational #-} + +------------------------------------------------------------------------------- +-- Auxiliary functions +------------------------------------------------------------------------------- + +-- | Safe convert from @Z@ to @GF(2^q)[X]/\@. +toB :: KnownNat p => Integer -> Binary p +toB = fromInteger +{-# INLINABLE toB #-} + +-- | Unsafe convert from @Z@ to @GF(2^q)[X]/\@. +toB' :: KnownNat p => Integer -> Binary p +toB' = B . naturalFromInteger +{-# INLINABLE toB' #-} + +------------------------------------------------------------------------------- +-- Binary arithmetic +------------------------------------------------------------------------------- + +-- Binary logarithm. +binLog :: Natural -> Word +binLog = binLog' 2 + where + binLog' :: Natural -> Natural -> Word + binLog' p x + | x < p = 0 + | otherwise = case binLog' (p * p) x of + l -> let l' = 2 * l in binLog'' (P.quot x $ p ^ l') l' + where + binLog'' :: Natural -> Word -> Word + binLog'' y n + | y < p = n + | otherwise = binLog'' (P.quot y p) (n + 1) +{-# INLINE binLog #-} + +-- Binary multiplication. +binMul :: Natural -> Natural -> Natural -> Natural +binMul = (. binMul' 0) . (.) . binMod + where + binMul' :: Natural -> Natural -> Natural -> Natural + binMul' n x y + | y == 0 = n + | testBit y 0 = binMul' (xor n x) x' y' + | otherwise = binMul' n x' y' + where + x' = shiftL x 1 :: Natural + y' = shiftR y 1 :: Natural +{-# INLINE binMul #-} + +-- Binary modulus. +binMod :: Natural -> Natural -> Natural +binMod f = binMod' + where + m = fromIntegral $ binLog f :: Int + binMod' :: Natural -> Natural + binMod' x + | n < 0 = x + | otherwise = binMod' (xor x $ shiftL f n) + where + n = fromIntegral (binLog x) - m :: Int +{-# INLINE binMod #-} + +-- Binary inversion. +binInv :: Natural -> Natural -> Natural +binInv f x = case binInv' 0 1 x f of + (y, 1) -> y + _ -> divZeroError + where + binInv' :: Natural -> Natural -> Natural -> Natural -> (Natural, Natural) + binInv' s s' r r' + | r' == 0 = (s, r) + | otherwise = binInv' s' (xor s $ shift s' q) r' (xor r $ shift r' q) + where + q = max 0 $ fromIntegral (binLog r) - fromIntegral (binLog r') :: Int +{-# INLINE binInv #-} diff --git a/src/Data/Field/Galois/Extension.hs b/src/Data/Field/Galois/Extension.hs new file mode 100644 --- /dev/null +++ b/src/Data/Field/Galois/Extension.hs @@ -0,0 +1,257 @@ +module Data.Field.Galois.Extension + ( Extension + , ExtensionField + , IrreducibleMonic(..) + , fromE + , conj + , toE + , toE' + , pattern U + , pattern U2 + , pattern U3 + , pattern V + , pattern X + , pattern X2 + , pattern X3 + , pattern Y + ) where + +import Protolude as P hiding (Semiring, rem, toList) + +import Control.Monad.Random (Random(..)) +import Data.Euclidean (Euclidean(..), GcdDomain) +import Data.Field (Field) +import Data.Group (Group(..)) +import Data.Poly (VPoly, gcdExt, monomial, toPoly, unPoly) +import Data.Semiring (Ring(..), Semiring(..)) +import GHC.Exts (IsList(..)) +import Test.Tasty.QuickCheck (Arbitrary(..), vector) +import Text.PrettyPrint.Leijen.Text (Pretty(..)) + +import Data.Field.Galois.Base (GaloisField(..)) +import Data.Field.Galois.Frobenius (frobenius) + +------------------------------------------------------------------------------- +-- Data types +------------------------------------------------------------------------------- + +-- | Irreducible monic polynomial @f(X)@ of extension field. +class GaloisField k => IrreducibleMonic p k where + {-# MINIMAL poly #-} + -- | Polynomial @f(X)@. + poly :: Extension p k -> VPoly k + +-- | Extension fields @GF(p^q)[X]/\@ for @p@ prime, @q@ positive, and +-- @f(X)@ irreducible monic in @GF(p^q)[X]@. +class GaloisField k => ExtensionField k where + {-# MINIMAL fromE #-} + -- | Convert from @GF(p^q)[X]/\@ to @GF(p^q)[X]@. + fromE :: (GaloisField l, IrreducibleMonic p l, k ~ Extension p l) => k -> [l] + +-- | Extension field elements. +newtype Extension p k = E (VPoly k) + deriving (Eq, Generic, NFData, Ord, Show) + +-- Extension fields are convertible. +instance IrreducibleMonic p k => ExtensionField (Extension p k) where + fromE = toList + {-# INLINABLE fromE #-} + +-- Extension fields are Galois fields. +instance IrreducibleMonic p k => GaloisField (Extension p k) where + char = const $ char (witness :: k) + {-# INLINABLE char #-} + deg = (deg (witness :: k) *) . deg' + {-# INLINABLE deg #-} + frob y@(E x) = case frobenius (unPoly x) (unPoly $ poly y) of + Just z -> E $ toPoly z + Nothing -> pow y $ char y + {-# INLINABLE frob #-} + +{-# RULES "Extension.pow" + forall (k :: IrreducibleMonic p k => Extension p k) n . (^) k n = pow k n + #-} + +------------------------------------------------------------------------------- +-- Group instances +------------------------------------------------------------------------------- + +-- Extension fields are multiplicative groups. +instance IrreducibleMonic p k => Group (Extension p k) where + invert = recip + {-# INLINE invert #-} + pow x n + | n >= 0 = x ^ n + | otherwise = recip x ^ P.negate n + {-# INLINE pow #-} + +-- Extension fields are multiplicative monoids. +instance IrreducibleMonic p k => Monoid (Extension p k) where + mempty = E 1 + {-# INLINE mempty #-} + +-- Extension fields are multiplicative semigroups. +instance IrreducibleMonic p k => Semigroup (Extension p k) where + (<>) = (*) + {-# INLINE (<>) #-} + stimes = flip pow + {-# INLINE stimes #-} + +------------------------------------------------------------------------------- +-- Numeric instances +------------------------------------------------------------------------------- + +-- Extension fields are fractional. +instance IrreducibleMonic p k => Fractional (Extension p k) where + recip (E x) = case gcdExt x $ poly (witness :: Extension p k) of + (1, y) -> E y + _ -> divZeroError + {-# INLINABLE recip #-} + fromRational (x:%y) = fromInteger x / fromInteger y + {-# INLINABLE fromRational #-} + +-- Extension fields are numeric. +instance IrreducibleMonic p k => Num (Extension p k) where + E x + E y = E $ x + y + {-# INLINE (+) #-} + E x * E y = E $ rem (x * y) $ poly (witness :: Extension p k) + {-# INLINABLE (*) #-} + E x - E y = E $ x - y + {-# INLINE (-) #-} + negate (E x) = E $ P.negate x + {-# INLINE negate #-} + fromInteger = E . fromInteger + {-# INLINABLE fromInteger #-} + abs = panic "Extension.abs: not implemented." + signum = panic "Extension.signum: not implemented." + +------------------------------------------------------------------------------- +-- Semiring instances +------------------------------------------------------------------------------- + +-- Extension fields are Euclidean domains. +instance IrreducibleMonic p k => Euclidean (Extension p k) where + degree = panic "Extension.degree: not implemented." + quotRem = (flip (,) 0 .) . (/) + {-# INLINE quotRem #-} + +-- Extension fields are fields. +instance IrreducibleMonic p k => Field (Extension p k) + +-- Extension fields are GCD domains. +instance IrreducibleMonic p k => GcdDomain (Extension p k) + +-- Extension fields are rings. +instance IrreducibleMonic p k => Ring (Extension p k) where + negate = P.negate + {-# INLINE negate #-} + +-- Extension fields are semirings. +instance IrreducibleMonic p k => Semiring (Extension p k) where + fromNatural = fromIntegral + {-# INLINABLE fromNatural #-} + one = E 1 + {-# INLINE one #-} + plus = (+) + {-# INLINE plus #-} + times = (*) + {-# INLINE times #-} + zero = E 0 + {-# INLINE zero #-} + +------------------------------------------------------------------------------- +-- Other instances +------------------------------------------------------------------------------- + +-- Extension fields are arbitrary. +instance IrreducibleMonic p k => Arbitrary (Extension p k) where + arbitrary = fromList <$> vector (fromIntegral $ deg' (witness :: Extension p k)) + {-# INLINABLE arbitrary #-} + +-- Extension fields are lists. +instance IrreducibleMonic p k => IsList (Extension p k) where + type instance Item (Extension p k) = k + fromList = E . fromList + {-# INLINABLE fromList #-} + toList (E x) = toList $ unPoly x + {-# INLINABLE toList #-} + +-- Extension fields are pretty. +instance IrreducibleMonic p k => Pretty (Extension p k) where + pretty (E x) = pretty $ toList x + +-- Extension fields are random. +instance IrreducibleMonic p k => Random (Extension p k) where + random = first fromList . unfold (deg' (witness :: Extension p k)) [] + where + unfold n xs g + | n <= 0 = (xs, g) + | otherwise = case random g of + (x, g') -> unfold (n - 1) (x : xs) g' + {-# INLINABLE random #-} + randomR = panic "Extension.randomR: not implemented." + +------------------------------------------------------------------------------- +-- Auxiliary functions +------------------------------------------------------------------------------- + +-- Polynomial degree. +deg' :: IrreducibleMonic p k => Extension p k -> Word +deg' = pred . fromIntegral . degree . poly +{-# INLINABLE deg' #-} + +-- | Complex conjugation @a+bi -> a-bi@ of quadratic extension field. +conj :: IrreducibleMonic p k => Extension p k -> Extension p k +conj y@(E x) = case unPoly $ poly y of + [_, 0, 1] -> case x of + [a, b] -> [a, P.negate b] + [a] -> [a] + _ -> [] + _ -> panic "Extension.conj: extension degree is not two." +{-# INLINABLE conj #-} + +-- | Safe convert from @GF(p^q)[X]@ to @GF(p^q)[X]/\@. +toE :: forall k p . IrreducibleMonic p k => [k] -> Extension p k +toE = E . flip rem (poly (witness :: Extension p k)) . fromList +{-# INLINABLE toE #-} + +-- | Unsafe convert from @GF(p^q)[X]@ to @GF(p^q)[X]/\@. +toE' :: forall k p . IrreducibleMonic p k => [k] -> Extension p k +toE' = fromList +{-# INLINABLE toE' #-} + +------------------------------------------------------------------------------- +-- Pattern synonyms +------------------------------------------------------------------------------- + +-- | Pattern for field element @U@. +pattern U :: IrreducibleMonic p k => Extension p k +pattern U <- _ where U = [0, 1] + +-- | Pattern for field element @U^2@. +pattern U2 :: IrreducibleMonic p k => Extension p k +pattern U2 <- _ where U2 = toE [0, 0, 1] + +-- | Pattern for field element @U^3@. +pattern U3 :: IrreducibleMonic p k => Extension p k +pattern U3 <- _ where U3 = toE [0, 0, 0, 1] + +-- | Pattern for descending tower of indeterminate variables for field elements. +pattern V :: IrreducibleMonic p k => k -> Extension p k +pattern V <- _ where V = E . monomial 0 + +-- | Pattern for monic monomial @X@. +pattern X :: GaloisField k => VPoly k +pattern X <- _ where X = [0, 1] + +-- | Pattern for monic monomial @X^2@. +pattern X2 :: GaloisField k => VPoly k +pattern X2 <- _ where X2 = [0, 0, 1] + +-- | Pattern for monic monomial @X^3@. +pattern X3 :: GaloisField k => VPoly k +pattern X3 <- _ where X3 = [0, 0, 0, 1] + +-- | Pattern for descending tower of indeterminate variables for monic monomials. +pattern Y :: IrreducibleMonic p k => VPoly k -> VPoly (Extension p k) +pattern Y <- _ where Y = monomial 0 . E diff --git a/src/Data/Field/Galois/Frobenius.hs b/src/Data/Field/Galois/Frobenius.hs new file mode 100644 --- /dev/null +++ b/src/Data/Field/Galois/Frobenius.hs @@ -0,0 +1,41 @@ +module Data.Field.Galois.Frobenius + ( frobenius + ) where + +import Protolude + +import Data.Vector (Vector) + +import Data.Field.Galois.Base (GaloisField(..)) + +------------------------------------------------------------------------------- +-- Functions +------------------------------------------------------------------------------- + +-- | Frobenius endomorphism precomputation. +frobenius :: GaloisField k => Vector k -> Vector k -> Maybe (Vector k) +frobenius [ ] _ = Just [] +frobenius [a] _ = Just [frob a] +frobenius [a, b] [x, 0, 1] + | deg x == 2 = Just [a, negate b] + | char x == 2 = Just [frob a - frob b * x] + | otherwise = Just [frob a, frob b * nxq] + where + nxq = negate x ^ shiftR (char x) 1 +frobenius [a, b] [x, 0, 0, 1] + | char x == 3 = Just [frob a - frob b * x] + | r == 1 = Just [frob a, frob b * nxq] + | otherwise = Just [frob a, 0, frob b * nxq] + where + (q, r) = quotRem (char x) 3 + nxq = negate x ^ q +frobenius [a, b, c] [x, 0, 0, 1] + | char x == 3 = Just [frob a - (frob b - frob c * x) * x] + | r == 1 = Just [frob a, frob b * nxq, frob c * nxq * nxq] + | otherwise = Just [frob a, frob c * nx * nxq * nxq, frob b * nxq] + where + (q, r) = quotRem (char x) 3 + nx = negate x + nxq = nx ^ q +frobenius _ _ = Nothing +{-# INLINABLE frobenius #-} diff --git a/src/Data/Field/Galois/Prime.hs b/src/Data/Field/Galois/Prime.hs new file mode 100644 --- /dev/null +++ b/src/Data/Field/Galois/Prime.hs @@ -0,0 +1,215 @@ +module Data.Field.Galois.Prime + ( Prime + , PrimeField + , fromP + , toP + , toP' + ) where + +import Protolude as P hiding (Semiring, natVal, rem) + +import Control.Monad.Random (Random(..)) +import Data.Euclidean as S (Euclidean(..), GcdDomain) +import Data.Field (Field) +import Data.Group (Group(..)) +import Data.Semiring (Ring(..), Semiring(..)) +import GHC.Integer.GMP.Internals (recipModInteger) +import GHC.Natural (Natural, naturalFromInteger, naturalToInteger, powModNatural) +import GHC.TypeNats (natVal) +import Test.Tasty.QuickCheck (Arbitrary(..), choose) +import Text.PrettyPrint.Leijen.Text (Pretty(..)) + +import Data.Field.Galois.Base (GaloisField(..)) + +------------------------------------------------------------------------------- +-- Data types +------------------------------------------------------------------------------- + +-- | Prime fields @GF(p) = Z/pZ@ for @p@ prime. +class GaloisField k => PrimeField k where + {-# MINIMAL fromP #-} + -- | Convert from @GF(p)@ to @Z@. + fromP :: k -> Integer + +-- | Prime field elements. +newtype Prime (p :: Nat) = P Natural + deriving (Bits, Eq, Generic, Hashable, NFData, Ord, Show) + +-- Prime fields are convertible. +instance KnownNat p => PrimeField (Prime p) where + fromP (P x) = naturalToInteger x + {-# INLINABLE fromP #-} + +-- Prime fields are Galois fields. +instance KnownNat p => GaloisField (Prime p) where + char = natVal + {-# INLINABLE char #-} + deg = const 1 + {-# INLINABLE deg #-} + frob = identity + {-# INLINABLE frob #-} + +{-# RULES "Prime.pow" + forall (k :: KnownNat p => Prime p) n . (^) k n = pow k n + #-} + +------------------------------------------------------------------------------- +-- Group instances +------------------------------------------------------------------------------- + +-- Prime fields are multiplicative groups. +instance KnownNat p => Group (Prime p) where + invert = recip + {-# INLINE invert #-} + pow y@(P x) n + | n >= 0 = P $ powModNatural x (fromIntegral n) $ natVal (witness :: Prime p) + | otherwise = pow (recip y) $ P.negate n + {-# INLINE pow #-} + +-- Prime fields are multiplicative monoids. +instance KnownNat p => Monoid (Prime p) where + mempty = P 1 + {-# INLINE mempty #-} + +-- Prime fields are multiplicative semigroups. +instance KnownNat p => Semigroup (Prime p) where + (<>) = (*) + {-# INLINE (<>) #-} + stimes = flip pow + {-# INLINE stimes #-} + +------------------------------------------------------------------------------- +-- Numeric instances +------------------------------------------------------------------------------- + +-- Prime fields are fractional. +instance KnownNat p => Fractional (Prime p) where + recip (P 0) = divZeroError + recip (P x) = P $ recipModNatural x $ natVal (witness :: Prime p) + {-# INLINE recip #-} + fromRational (x:%y) = fromInteger x / fromInteger y + {-# INLINABLE fromRational #-} + +-- Prime fields are numeric. +instance KnownNat p => Num (Prime p) where + P x + P y = P $ if xy >= p then xy - p else xy + where + xy = x + y + p = natVal (witness :: Prime p) + {-# INLINE (+) #-} + P x * P y = P $ rem (x * y) $ natVal (witness :: Prime p) + {-# INLINE (*) #-} + P x - P y = P $ if x >= y then x - y else natVal (witness :: Prime p) + x - y + {-# INLINE (-) #-} + negate (P 0) = P 0 + negate (P x) = P $ natVal (witness :: Prime p) - x + {-# INLINE negate #-} + fromInteger x = P $ naturalFromInteger $ mod x $ naturalToInteger $ natVal (witness :: Prime p) + {-# INLINABLE fromInteger #-} + abs = panic "Prime.abs: not implemented." + signum = panic "Prime.signum: not implemented." + +------------------------------------------------------------------------------- +-- Semiring instances +------------------------------------------------------------------------------- + +-- Prime fields are Euclidean domains. +instance KnownNat p => Euclidean (Prime p) where + degree = panic "Prime.degree: not implemented." + quotRem = (flip (,) 0 .) . (/) + {-# INLINE quotRem #-} + +-- Prime fields are fields. +instance KnownNat p => Field (Prime p) + +-- Prime fields are GCD domains. +instance KnownNat p => GcdDomain (Prime p) + +-- Prime fields are rings. +instance KnownNat p => Ring (Prime p) where + negate = P.negate + {-# INLINE negate #-} + +-- Prime fields are semirings. +instance KnownNat p => Semiring (Prime p) where + fromNatural = fromIntegral + {-# INLINABLE fromNatural #-} + one = P 1 + {-# INLINE one #-} + plus = (+) + {-# INLINE plus #-} + times = (*) + {-# INLINE times #-} + zero = P 0 + {-# INLINE zero #-} + +------------------------------------------------------------------------------- +-- Other instances +------------------------------------------------------------------------------- + +-- Prime fields are arbitrary. +instance KnownNat p => Arbitrary (Prime p) where + arbitrary = P . naturalFromInteger <$> + choose (0, naturalToInteger $ natVal (witness :: Prime p) - 1) + {-# INLINABLE arbitrary #-} + +-- Prime fields are bounded. +instance KnownNat p => Bounded (Prime p) where + maxBound = P $ natVal (witness :: Prime p) - 1 + {-# INLINE maxBound #-} + minBound = P 0 + {-# INLINE minBound #-} + +-- Prime fields are enumerable. +instance KnownNat p => Enum (Prime p) where + fromEnum = fromIntegral + {-# INLINABLE fromEnum #-} + toEnum = fromIntegral + {-# INLINABLE toEnum #-} + +-- Prime fields are integral. +instance KnownNat p => Integral (Prime p) where + quotRem = S.quotRem + {-# INLINE quotRem #-} + toInteger = fromP + {-# INLINABLE toInteger #-} + +-- Prime fields are pretty. +instance KnownNat p => Pretty (Prime p) where + pretty (P x) = pretty $ naturalToInteger x + +-- Prime fields are random. +instance KnownNat p => Random (Prime p) where + random = randomR (P 0, P $ natVal (witness :: Prime p) - 1) + {-# INLINABLE random #-} + randomR (a, b) = first (P . naturalFromInteger) . randomR (fromP a, fromP b) + {-# INLINABLE randomR #-} + +-- Prime fields are real. +instance KnownNat p => Real (Prime p) where + toRational = fromIntegral + {-# INLINABLE toRational #-} + +------------------------------------------------------------------------------- +-- Auxiliary functions +------------------------------------------------------------------------------- + +-- | Safe convert from @Z@ to @GF(p)@. +toP :: KnownNat p => Integer -> Prime p +toP = fromInteger +{-# INLINABLE toP #-} + +-- | Unsafe convert from @Z@ to @GF(p)@. +toP' :: KnownNat p => Integer -> Prime p +toP' = P . naturalFromInteger +{-# INLINABLE toP' #-} + +------------------------------------------------------------------------------- +-- Prime arithmetic +------------------------------------------------------------------------------- + +-- Reciprocals modulo naturals. +recipModNatural :: Natural -> Natural -> Natural +recipModNatural x p = naturalFromInteger $ + recipModInteger (naturalToInteger x) (naturalToInteger p) +{-# INLINE recipModNatural #-} diff --git a/src/Data/Field/Galois/Sqrt.hs b/src/Data/Field/Galois/Sqrt.hs new file mode 100644 --- /dev/null +++ b/src/Data/Field/Galois/Sqrt.hs @@ -0,0 +1,134 @@ +module Data.Field.Galois.Sqrt + ( qnr + , qr + , quad + , rnd + , rndR + , sr + ) where + +import Protolude + +import Control.Monad.Random (MonadRandom, StdGen, getRandom, getRandomR, mkStdGen, runRand) +import GHC.Natural (Natural) + +import Data.Field.Galois.Base (GaloisField(..), pow) + +------------------------------------------------------------------------------- +-- Main functions +------------------------------------------------------------------------------- + +-- | Get randomised quadratic nonresidue. +qnr :: GaloisField k => Maybe k +qnr = getQNR +{-# INLINABLE qnr #-} + +-- | Check if quadratic residue. +qr :: GaloisField k => k -> Bool +qr = not . isQNR +{-# INLINABLE qr #-} + +-- | Solve quadratic @ax^2 + bx + c = 0@ over field. +quad :: GaloisField k => k -> k -> k -> Maybe k +quad = solveQuadratic +{-# INLINABLE quad #-} + +-- | Randomised field element. +rnd :: (GaloisField k, MonadRandom m) => m k +rnd = getRandom +{-# INLINABLE rnd #-} + +-- | Randomised field element in range. +rndR :: (GaloisField k, MonadRandom m) => (k, k) -> m k +rndR = getRandomR +{-# INLINABLE rndR #-} + +-- | Square root of field element. +sr :: GaloisField k => k -> Maybe k +sr = squareRoot +{-# INLINABLE sr #-} + +------------------------------------------------------------------------------- +-- Auxiliary functions +------------------------------------------------------------------------------- + +-- | Check if an element is a quadratic nonresidue. +isQNR :: GaloisField k => k -> Bool +isQNR n = n == 0 || char n /= 2 && pow n (shiftR (order n) 1) /= 1 +{-# INLINABLE isQNR #-} + +-- Get a random quadratic nonresidue. +getQNR :: forall k . GaloisField k => Maybe k +getQNR + | char (witness :: k) == 2 = Nothing + | otherwise = Just $ getQNR' $ runRand rnd $ mkStdGen 0 + where + getQNR' :: (k, StdGen) -> k + getQNR' (x, g) + | x /= 0 && isQNR x = x + | otherwise = getQNR' $ runRand rnd g +{-# INLINABLE getQNR #-} + +-- Factor the order @p - 1@ to get @q@ and @s@ such that @p - 1 = q2^s@. +factorOrder :: GaloisField k => k -> (Natural, Word) +factorOrder w = factorOrder' (order w - 1, 0) + where + factorOrder' :: (Natural, Word) -> (Natural, Word) + factorOrder' qs@(q, s) + | testBit q 0 = qs + | otherwise = factorOrder' (shiftR q 1, s + 1) +{-# INLINABLE factorOrder #-} + +-- Get a square root of @n@ with the Tonelli-Shanks algorithm. +squareRoot :: forall k . GaloisField k => k -> Maybe k +squareRoot 0 = Just 0 +squareRoot n + | char n == 2 = Just $ power n + | isQNR n = Nothing + | otherwise = case (factorOrder n, getQNR) of + ((q, s), Just z) -> let zq = pow z q + nq = pow n $ shiftR q 1 + nnq = n * nq + in loop s zq (nq * nnq) nnq + _ -> panic "Sqrt.squareRoot: no quadratic nonresidue." + where + power :: k -> k + power = next $ deg n + where + next :: Word -> k -> k + next 1 m = m + next i m = next (i - 1) (m * m) + loop :: Word -> k -> k -> k -> Maybe k + loop _ _ 0 _ = Just 0 + loop _ _ 1 r = Just r + loop m c t r = let i = least t 0 + b = pow c $ (bit (fromIntegral $ m - i - 1) :: Int) + b2 = b * b + in loop i b2 (t * b2) (r * b) + where + least :: k -> Word -> Word + least 1 j = j + least ti j = least (ti * ti) (j + 1) +{-# INLINABLE squareRoot #-} + +-- Solve a quadratic equation @ax^2 + bx + c = 0@. +solveQuadratic :: forall k . GaloisField k => k -> k -> k -> Maybe k +solveQuadratic 0 _ _ = Nothing +solveQuadratic _ _ 0 = Just 0 +solveQuadratic a 0 c = squareRoot $ -c / a +solveQuadratic a b c + | char a == 2 = (<$>) (* (b / a)) $ solveQuadratic' $ ac / bb + | otherwise = (<$>) ((/ (2 * a)) . subtract b) $ squareRoot $ bb - 4 * ac + where + ac = a * c + bb = b * b + solveQuadratic' :: k -> Maybe k + solveQuadratic' x + | sum xs /= 0 = Nothing + | odd m = Just $ sum h + | otherwise = panic "Base.solveQuadratic: to be implemented." + where + m = deg x + xs = take (fromIntegral m) $ iterate (join (*)) x + h = zipWith ($) (cycle [identity, const 0]) xs +{-# INLINABLE solveQuadratic #-} diff --git a/src/Data/Field/Galois/Tower.hs b/src/Data/Field/Galois/Tower.hs new file mode 100644 --- /dev/null +++ b/src/Data/Field/Galois/Tower.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE UndecidableInstances #-} + +module Data.Field.Galois.Tower + ( TowerOfFields(..) + , (*^) + ) where + +import Protolude + +import Data.Field.Galois.Base (GaloisField) +import Data.Field.Galois.Prime (Prime, fromP) +import Data.Field.Galois.Extension (Extension, IrreducibleMonic, pattern V) +import Data.Field.Galois.Binary (Binary, toB') + +------------------------------------------------------------------------------- +-- Types +------------------------------------------------------------------------------- + +-- | Tower of fields @L@ over @K@ strict partial ordering. +class (GaloisField k, GaloisField l) => TowerOfFields k l where + {-# MINIMAL embed #-} + -- | Embed @K@ into @L@ naturally. + embed :: k -> l + +------------------------------------------------------------------------------- +-- Instances +------------------------------------------------------------------------------- + +-- Prime field towers are reflexive. +instance KnownNat p => TowerOfFields (Prime p) (Prime p) where + embed = identity + {-# INLINABLE embed #-} + +-- Extension field towers are reflexive. +instance IrreducibleMonic p k => TowerOfFields (Extension p k) (Extension p k) where + embed = identity + {-# INLINABLE embed #-} + +-- Extension fields are towers of fields. +instance {-# OVERLAPPING #-} IrreducibleMonic p k => TowerOfFields k (Extension p k) where + embed = V + {-# INLINABLE embed #-} + +-- Extension field towers are transitive. +instance {-# OVERLAPPABLE #-} (TowerOfFields k l, IrreducibleMonic p l, TowerOfFields l (Extension p l)) + => TowerOfFields k (Extension p l) where + embed = embed . (embed :: k -> l) + {-# INLINABLE embed #-} + +-- Binary field towers are reflexive. +instance KnownNat p => TowerOfFields (Binary p) (Binary p) where + embed = identity + {-# INLINABLE embed #-} + +-- Binary fields are towers of fields. +instance KnownNat p => TowerOfFields (Prime 2) (Binary p) where + embed = toB' . fromP + {-# INLINABLE embed #-} + +------------------------------------------------------------------------------- +-- Functions +------------------------------------------------------------------------------- + +-- | Scalar multiplication. +infixl 7 *^ +(*^) :: TowerOfFields k l => k -> l -> l +(*^) = (*) . embed +{-# INLINE (*^) #-} diff --git a/src/Data/Field/Galois/Unity.hs b/src/Data/Field/Galois/Unity.hs new file mode 100644 --- /dev/null +++ b/src/Data/Field/Galois/Unity.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE UndecidableInstances #-} + +module Data.Field.Galois.Unity + ( CyclicSubgroup(..) + , RootsOfUnity + , cardinality + , cofactor + , isPrimitiveRootOfUnity + , isRootOfUnity + , toU + , toU' + ) where + +import Protolude hiding (natVal) + +import Control.Monad.Random (Random(..)) +import Data.Group (Group(..)) +import GHC.Natural (Natural, naturalToInteger) +import GHC.TypeNats (natVal) +import Test.Tasty.QuickCheck (Arbitrary(..), choose) +import Text.PrettyPrint.Leijen.Text (Pretty(..)) + +import Data.Field.Galois.Base (GaloisField(..)) +import Data.Field.Galois.Prime (Prime) + +------------------------------------------------------------------------------- +-- Types +------------------------------------------------------------------------------- + +-- | Cyclic subgroups of finite groups. +class Group g => CyclicSubgroup g where + {-# MINIMAL gen #-} + -- | Generator of subgroup. + gen :: g + +-- | @n@-th roots of unity of Galois fields. +newtype RootsOfUnity (n :: Nat) k = U k + deriving (Bits, Eq, Functor, Generic, NFData, Ord, Show) + +------------------------------------------------------------------------------- +-- Instances +------------------------------------------------------------------------------- + +-- Roots of unity cyclic subgroups are arbitrary. +instance (KnownNat n, GaloisField k, CyclicSubgroup (RootsOfUnity n k), + Group (RootsOfUnity n k)) => Arbitrary (RootsOfUnity n k) where + arbitrary = pow gen <$> choose (0, naturalToInteger $ order (witness :: Prime n) - 1) + {-# INLINABLE arbitrary #-} + +-- Roots of unity are groups. +instance (KnownNat n, GaloisField k) => Group (RootsOfUnity n k) where + invert (U x) = U $ recip x + {-# INLINABLE invert #-} + pow (U x) n = U $ pow x n + {-# INLINABLE pow #-} + +-- Roots of unity are monoids. +instance (KnownNat n, GaloisField k) => Monoid (RootsOfUnity n k) where + mempty = U 1 + {-# INLINABLE mempty #-} + +-- Roots of unity are pretty. +instance (KnownNat n, GaloisField k) => Pretty (RootsOfUnity n k) where + pretty (U x) = pretty x + +-- Roots of unity cyclic subgroups are random. +instance (KnownNat n, GaloisField k, CyclicSubgroup (RootsOfUnity n k), + Group (RootsOfUnity n k)) => Random (RootsOfUnity n k) where + random = first (pow gen) . randomR (0, naturalToInteger $ order (witness :: Prime n) - 1) + {-# INLINABLE random #-} + randomR = panic "Unity.randomR: not implemented." + +-- Roots of unity are semigroups. +instance (KnownNat n, GaloisField k) => Semigroup (RootsOfUnity n k) where + U x <> U y = U $ x * y + {-# INLINABLE (<>) #-} + +------------------------------------------------------------------------------- +-- Functions +------------------------------------------------------------------------------- + +-- | Cardinality of subgroup. +cardinality :: forall n k . (KnownNat n, GaloisField k) => RootsOfUnity n k -> Natural +cardinality = const $ natVal (witness :: Prime n) +{-# INLINABLE cardinality #-} + +-- | Cofactor of subgroup in group. +cofactor :: forall n k . (KnownNat n, GaloisField k) => RootsOfUnity n k -> Natural +cofactor = quot (order (witness :: k)) . cardinality +{-# INLINABLE cofactor #-} + +-- | Check if element is primitive root of unity. +isPrimitiveRootOfUnity :: (KnownNat n, GaloisField k) => RootsOfUnity n k -> Bool +isPrimitiveRootOfUnity u@(U x) = isRootOfUnity u + && not (any (isUnity x) ([1 .. cardinality u - 1] :: [Natural])) +{-# INLINABLE isPrimitiveRootOfUnity #-} + +-- | Check if element is root of unity. +isRootOfUnity :: (KnownNat n, GaloisField k) => RootsOfUnity n k -> Bool +isRootOfUnity u@(U x) = isUnity x $ cardinality u +{-# INLINABLE isRootOfUnity #-} + +-- | Check if element is unity. +isUnity :: (Integral n, GaloisField k) => k -> n -> Bool +isUnity = ((==) 1 .) . pow +{-# INLINABLE isUnity #-} + +-- | Safe convert from field to roots of unity. +toU :: forall n k . (KnownNat n, GaloisField k) => k -> RootsOfUnity n k +toU x = let u = U x :: RootsOfUnity n k in + if isRootOfUnity u then u else panic "Unity.toUnity: element is not a root of unity." +{-# INLINABLE toU #-} + +-- | Unsafe convert from field to roots of unity. +toU' :: forall n k . (KnownNat n, GaloisField k) => k -> RootsOfUnity n k +toU' = U +{-# INLINABLE toU' #-} diff --git a/src/ExtensionField.hs b/src/ExtensionField.hs deleted file mode 100644 --- a/src/ExtensionField.hs +++ /dev/null @@ -1,193 +0,0 @@ -module ExtensionField - ( ExtensionField - , PolynomialRing - , IrreducibleMonic(split) - , fromField - , toField - , pattern X - , pattern X2 - , pattern X3 - , pattern Y - ) where - -import Protolude as P hiding (Semiring, quot, quotRem, rem) - -import Control.Monad.Random (Random(..)) -import Data.Euclidean (Euclidean(..), GcdDomain(..)) -import Data.Poly.Semiring (VPoly, leading, monomial, scale, toPoly, unPoly, pattern X) -import Data.Semiring as S (Ring(..), Semiring(..)) -import Data.Vector (fromList) -import Test.Tasty.QuickCheck (Arbitrary(..), vector) -import Text.PrettyPrint.Leijen.Text (Pretty(..)) - -import GaloisField (Field(..), GaloisField(..)) - -------------------------------------------------------------------------------- --- Data types -------------------------------------------------------------------------------- - --- | Extension fields @GF(p^q)[X]/\@ for @p@ prime, @q@ positive, and --- @f(X)@ irreducible monic in @GF(p^q)[X]@. -newtype ExtensionField k im = EF (VPoly k) - deriving (Eq, Generic, Ord, Show) - --- | Polynomial rings. -type PolynomialRing = VPoly - --- | Irreducible monic splitting polynomial @f(X)@ of extension field. -class GaloisField k => IrreducibleMonic k im where - {-# MINIMAL split #-} - -- | Splitting polynomial @f(X)@. - split :: ExtensionField k im -> VPoly k - -- Splitting polynomial degree. - deg' :: ExtensionField k im -> Int - deg' = pred . fromIntegral . degree . split - {-# INLINABLE deg' #-} - --- Extension fields are Galois fields. -instance IrreducibleMonic k im => GaloisField (ExtensionField k im) where - char = const (char (witness :: k)) - {-# INLINABLE char #-} - deg = (deg (witness :: k) *) . deg' - {-# INLINABLE deg #-} - frob = pow <*> char - {-# INLINABLE frob #-} - -{-# RULES "ExtensionField/pow" - forall (k :: IrreducibleMonic k im => ExtensionField k im) n . (^) k n = pow k n - #-} - -------------------------------------------------------------------------------- --- Numeric instances -------------------------------------------------------------------------------- - --- Extension fields are fractional. -instance IrreducibleMonic k im => Fractional (ExtensionField k im) where - recip (EF x) = EF (polyInv x (split (witness :: ExtensionField k im))) - {-# INLINABLE recip #-} - fromRational (x:%y) = fromInteger x / fromInteger y - {-# INLINABLE fromRational #-} - --- Extension fields are numeric. -instance IrreducibleMonic k im => Num (ExtensionField k im) where - EF x + EF y = EF (plus x y) - {-# INLINE (+) #-} - EF x * EF y = EF (rem (times x y) (split (witness :: ExtensionField k im))) - {-# INLINABLE (*) #-} - EF x - EF y = EF (x - y) - {-# INLINE (-) #-} - negate (EF x) = EF (S.negate x) - {-# INLINE negate #-} - fromInteger = EF . fromInteger - {-# INLINABLE fromInteger #-} - abs = panic "not implemented." - signum = panic "not implemented." - -------------------------------------------------------------------------------- --- Semiring instances -------------------------------------------------------------------------------- - --- Extension fields are Euclidean domains. -instance IrreducibleMonic k im => Euclidean (ExtensionField k im) where - quotRem = (flip (,) 0 .) . (/) - {-# INLINE quotRem #-} - degree = panic "not implemented." - --- Extension fields are fields. -instance IrreducibleMonic k im => Field (ExtensionField k im) where - invert = recip - {-# INLINE invert #-} - minus = (-) - {-# INLINE minus #-} - --- Extension fields are GCD domains. -instance IrreducibleMonic k im => GcdDomain (ExtensionField k im) - --- Extension fields are rings. -instance IrreducibleMonic k im => Ring (ExtensionField k im) where - negate = P.negate - {-# INLINE negate #-} - --- Extension fields are semirings. -instance IrreducibleMonic k im => Semiring (ExtensionField k im) where - zero = 0 - {-# INLINE zero #-} - plus = (+) - {-# INLINE plus #-} - one = 1 - {-# INLINE one #-} - times = (*) - {-# INLINE times #-} - fromNatural = fromIntegral - {-# INLINABLE fromNatural #-} - -------------------------------------------------------------------------------- --- Other instances -------------------------------------------------------------------------------- - --- Extension fields are arbitrary. -instance IrreducibleMonic k im => Arbitrary (ExtensionField k im) where - arbitrary = toField <$> vector (deg' (witness :: ExtensionField k im)) - {-# INLINABLE arbitrary #-} - --- Extension fields are pretty. -instance IrreducibleMonic k im => Pretty (ExtensionField k im) where - pretty (EF x) = pretty (toList (unPoly x)) - --- Extension fields are random. -instance IrreducibleMonic k im => Random (ExtensionField k im) where - random = first toField . unfold (deg' (witness :: ExtensionField k im)) [] - where - unfold n xs g - | n <= 0 = (xs, g) - | otherwise = case random g of - (x, g') -> unfold (n - 1) (x : xs) g' - {-# INLINABLE random #-} - randomR = panic "not implemented." - -------------------------------------------------------------------------------- --- Type conversions -------------------------------------------------------------------------------- - --- | Convert from field element to list representation. -fromField :: ExtensionField k im -> [k] -fromField (EF x) = toList (unPoly x) -{-# INLINABLE fromField #-} - --- | Convert from list representation to field element. -toField :: forall k im . IrreducibleMonic k im => [k] -> ExtensionField k im -toField = EF . flip rem (split (witness :: ExtensionField k im)) . toPoly . fromList -{-# INLINABLE toField #-} - --- | Pattern for @X^2@. -pattern X2 :: GaloisField k => VPoly k -pattern X2 <- _ where X2 = toPoly (fromList [0, 0, 1]) - --- | Pattern for @X^3@. -pattern X3 :: GaloisField k => VPoly k -pattern X3 <- _ where X3 = toPoly (fromList [0, 0, 0, 1]) - --- | Pattern for descending tower of indeterminate variables. -pattern Y :: IrreducibleMonic k im => VPoly k -> VPoly (ExtensionField k im) -pattern Y <- _ where Y = monomial 0 . EF - -------------------------------------------------------------------------------- --- Polynomial arithmetic -------------------------------------------------------------------------------- - --- Polynomial inversion algorithm. -polyInv :: GaloisField k => VPoly k -> VPoly k -> VPoly k -polyInv xs ps = case first leading (polyGCD xs ps) of - (Just (0, x), ys) -> scale 0 (recip x) ys - _ -> panic "no multiplicative inverse." -{-# INLINABLE polyInv #-} - --- Polynomial extended greatest common divisor algorithm. -polyGCD :: forall k . GaloisField k => VPoly k -> VPoly k -> (VPoly k, VPoly k) -polyGCD x y = polyGCD' 0 1 y x - where - polyGCD' :: VPoly k -> VPoly k -> VPoly k -> VPoly k -> (VPoly k, VPoly k) - polyGCD' s _ r 0 = (r, s) - polyGCD' s s' r r' = case quot r r' of - q -> polyGCD' s' (s - times q s') r' (r - times q r') -{-# INLINABLE polyGCD #-} diff --git a/src/GaloisField.hs b/src/GaloisField.hs deleted file mode 100644 --- a/src/GaloisField.hs +++ /dev/null @@ -1,184 +0,0 @@ -module GaloisField - ( Field(..) - , GaloisField(..) - ) where - -import Protolude hiding ((-), one, quot) - -import Control.Monad.Random (MonadRandom, Random, StdGen, - getRandom, mkStdGen, runRand) -import Data.Euclidean (Euclidean(..)) -import Data.Semiring (Ring, (-), one) -import Test.Tasty.QuickCheck (Arbitrary) -import Text.PrettyPrint.Leijen.Text (Pretty) - -------------------------------------------------------------------------------- --- Classes -------------------------------------------------------------------------------- - --- | Fields. -class (Euclidean k, Ring k) => Field k where - - -- Operations - - -- | Division. - divide :: k -> k -> k - divide = quot - {-# INLINABLE divide #-} - - -- | Inversion. - invert :: k -> k - invert = quot one - {-# INLINABLE invert #-} - - -- | Subtraction. - minus :: k -> k -> k - minus = (-) - {-# INLINABLE minus #-} - --- | Galois fields @GF(p^q)@ for @p@ prime and @q@ non-negative. -class (Arbitrary k, Field k, Fractional k, - Generic k, Ord k, Pretty k, Random k, Show k) => GaloisField k where - {-# MINIMAL char, deg, frob #-} - - -- Characteristics - - -- | Characteristic @p@ of field and order of prime subfield. - char :: k -> Integer - - -- | Degree @q@ of field as extension field over prime subfield. - deg :: k -> Int - - -- | Order @p^q@ of field. - order :: k -> Integer - order = (^) <$> char <*> deg - {-# INLINABLE order #-} - - -- | Frobenius endomorphism @x -> x^p@ of prime subfield. - frob :: k -> k - - -- Functions - - -- | Exponentiation of field element to integer. - pow :: k -> Integer -> k - pow x n - | n < 0 = pow (recip x) (negate n) - | otherwise = pow' 1 x n - where - pow' z y m - | m == 0 = z - | m == 1 = z' - | even m = pow' z y' m' - | otherwise = pow' z' y' m' - where - z' = z * y - y' = y * y - m' = div m 2 - {-# INLINABLE pow #-} - - -- | Get randomised quadratic nonresidue. - qnr :: k - qnr = getQNR - {-# INLINABLE qnr #-} - - -- | Check if quadratic residue. - qr :: k -> Bool - qr = not . isQNR - {-# INLINABLE qr #-} - - -- | Solve quadratic @ax^2 + bx + c = 0@ over field. - quad :: k -> k -> k -> Maybe k - quad = solveQuadratic - {-# INLINABLE quad #-} - - -- | Randomised field element. - rnd :: MonadRandom m => m k - rnd = getRandom - {-# INLINABLE rnd #-} - - -- | Square root of field element. - sr :: k -> Maybe k - sr = squareRoot - {-# INLINABLE sr #-} - -------------------------------------------------------------------------------- --- Square roots -------------------------------------------------------------------------------- - --- Check if an element is a quadratic nonresidue. -isQNR :: GaloisField k => k -> Bool -isQNR n = pow n (shiftR (order n) 1) /= 1 -{-# INLINABLE isQNR #-} - --- Factor the order @p - 1@ to get @q@ and @s@ such that @p - 1 = q2^s@. -factorOrder :: GaloisField k => k -> (Integer, Int) -factorOrder w = factorOrder' (order w - 1, 0) - where - factorOrder' :: (Integer, Int) -> (Integer, Int) - factorOrder' qs@(q, s) - | testBit q 0 = qs - | otherwise = factorOrder' (shiftR q 1, s + 1) -{-# INLINABLE factorOrder #-} - --- Get a random quadratic nonresidue. -getQNR :: forall k . GaloisField k => k -getQNR = getQNR' (runRand rnd (mkStdGen 0)) - where - getQNR' :: (k, StdGen) -> k - getQNR' (x, g) - | x /= 0 && isQNR x = x - | otherwise = getQNR' (runRand rnd g) -{-# INLINABLE getQNR #-} - --- Get a square root of @n@ with the Tonelli-Shanks algorithm. -squareRoot :: forall k . GaloisField k => k -> Maybe k -squareRoot 0 = Just 0 -squareRoot n - | char n == 2 = Just (power n) - | isQNR n = Nothing - | otherwise = case (factorOrder n, getQNR) of - ((q, s), z) -> let zq = pow z q - nq = pow n (shiftR q 1) - nnq = n * nq - in loop s zq (nq * nnq) nnq - where - power :: k -> k - power = next (deg n) - where - next :: Int -> k -> k - next 1 m = m - next i m = next (i - 1) (m * m) - loop :: Int -> k -> k -> k -> Maybe k - loop _ _ 0 _ = Just 0 - loop _ _ 1 r = Just r - loop m c t r = let i = least t 0 - b = pow c (bit (m - i - 1)) - b2 = b * b - in loop i b2 (t * b2) (r * b) - where - least :: k -> Int -> Int - least 1 j = j - least ti j = least (ti * ti) (j + 1) -{-# INLINABLE squareRoot #-} - --- Solve a quadratic equation @ax^2 + bx + c = 0@. -solveQuadratic :: forall k . GaloisField k => k -> k -> k -> Maybe k -solveQuadratic 0 _ _ = Nothing -solveQuadratic _ _ 0 = Just 0 -solveQuadratic a 0 c = squareRoot (-c / a) -solveQuadratic a b c - | char a == 2 = (* (b / a)) <$> solveQuadratic' (ac / bb) - | otherwise = (/ (2 * a)) . subtract b <$> squareRoot (bb - 4 * ac) - where - ac = a * c - bb = b * b - solveQuadratic' :: k -> Maybe k - solveQuadratic' x - | sum xs /= 0 = Nothing - | odd m = Just (sum h) - | otherwise = panic "not implemented." - where - m = deg x - xs = take m (iterate (join (*)) x) - h = zipWith ($) (cycle [identity, const 0]) xs -{-# INLINABLE solveQuadratic #-} diff --git a/src/PrimeField.hs b/src/PrimeField.hs deleted file mode 100644 --- a/src/PrimeField.hs +++ /dev/null @@ -1,140 +0,0 @@ -module PrimeField - ( PrimeField - , toInt - ) where - -import Protolude as P hiding (Semiring) - -import Control.Monad.Random (Random(..)) -import Data.Euclidean (Euclidean(..), GcdDomain(..)) -import Data.Semiring (Ring(..), Semiring(..)) -import GHC.Integer.GMP.Internals (powModInteger, recipModInteger) -import Test.Tasty.QuickCheck (Arbitrary(..), choose) -import Text.PrettyPrint.Leijen.Text (Pretty(..)) - -import GaloisField (Field(..), GaloisField(..)) - -------------------------------------------------------------------------------- --- Data types -------------------------------------------------------------------------------- - --- | Prime fields @GF(p)@ for @p@ prime. -newtype PrimeField (p :: Nat) = PF Integer - deriving (Bits, Eq, Generic, Ord, Show) - --- Prime fields are Galois fields. -instance KnownNat p => GaloisField (PrimeField p) where - char = natVal - {-# INLINABLE char #-} - deg = const 1 - {-# INLINABLE deg #-} - frob = identity - {-# INLINABLE frob #-} - pow (PF x) n = PF (powModInteger x n (natVal (witness :: PrimeField p))) - {-# INLINE pow #-} - -{-# RULES "PrimeField/pow" - forall (k :: KnownNat p => PrimeField p) (n :: Integer) . (^) k n = pow k n - #-} - -------------------------------------------------------------------------------- --- Numeric instances -------------------------------------------------------------------------------- - --- Prime fields are fractional. -instance KnownNat p => Fractional (PrimeField p) where - recip (PF 0) = panic "no multiplicative inverse." - recip (PF x) = PF (recipModInteger x (natVal (witness :: PrimeField p))) - {-# INLINE recip #-} - fromRational (x:%y) = fromInteger x / fromInteger y - {-# INLINABLE fromRational #-} - --- Prime fields are numeric. -instance KnownNat p => Num (PrimeField p) where - PF x + PF y = PF (if xyp >= 0 then xyp else xy) - where - xy = x + y - xyp = xy - natVal (witness :: PrimeField p) - {-# INLINE (+) #-} - PF x * PF y = PF (P.rem (x * y) (natVal (witness :: PrimeField p))) - {-# INLINE (*) #-} - PF x - PF y = PF (if xy >= 0 then xy else xy + natVal (witness :: PrimeField p)) - where - xy = x - y - {-# INLINE (-) #-} - negate (PF 0) = PF 0 - negate (PF x) = PF (natVal (witness :: PrimeField p) - x) - {-# INLINE negate #-} - fromInteger x = PF (if y >= 0 then y else y + p) - where - y = P.rem x p - p = natVal (witness :: PrimeField p) - {-# INLINABLE fromInteger #-} - abs = panic "not implemented." - signum = panic "not implemented." - -------------------------------------------------------------------------------- --- Semiring instances -------------------------------------------------------------------------------- - --- Prime fields are Euclidean domains. -instance KnownNat p => Euclidean (PrimeField p) where - quotRem = (flip (,) 0 .) . (/) - {-# INLINE quotRem #-} - degree = panic "not implemented." - --- Prime fields are fields. -instance KnownNat p => Field (PrimeField p) where - invert = recip - {-# INLINE invert #-} - minus = (-) - {-# INLINE minus #-} - --- Prime fields are GCD domains. -instance KnownNat p => GcdDomain (PrimeField p) - --- Prime fields are rings. -instance KnownNat p => Ring (PrimeField p) where - negate = P.negate - {-# INLINE negate #-} - --- Prime fields are semirings. -instance KnownNat p => Semiring (PrimeField p) where - zero = 0 - {-# INLINE zero #-} - plus = (+) - {-# INLINE plus #-} - one = 1 - {-# INLINE one #-} - times = (*) - {-# INLINE times #-} - fromNatural = fromIntegral - {-# INLINABLE fromNatural #-} - -------------------------------------------------------------------------------- --- Other instances -------------------------------------------------------------------------------- - --- Prime fields are arbitrary. -instance KnownNat p => Arbitrary (PrimeField p) where - arbitrary = PF <$> choose (0, natVal (witness :: PrimeField p) - 1) - {-# INLINABLE arbitrary #-} - --- Prime fields are pretty. -instance KnownNat p => Pretty (PrimeField p) where - pretty (PF x) = pretty x - --- Prime fields are random. -instance KnownNat p => Random (PrimeField p) where - random = first PF . randomR (0, natVal (witness :: PrimeField p) - 1) - {-# INLINABLE random #-} - randomR = panic "not implemented." - -------------------------------------------------------------------------------- --- Type conversions -------------------------------------------------------------------------------- - --- | Embed field element to integers. -toInt :: PrimeField p -> Integer -toInt (PF x) = x -{-# INLINABLE toInt #-} diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,13 @@ +module Main where + +import Protolude + +import Test.Tasty + +import Test.Binary +import Test.Extension +import Test.Prime + +main :: IO () +main = defaultMain $ + testGroup "Tests" [testPrime, testExtension, testBinary] diff --git a/test/Test/Binary.hs b/test/Test/Binary.hs new file mode 100644 --- /dev/null +++ b/test/Test/Binary.hs @@ -0,0 +1,31 @@ +module Test.Binary where + +import Protolude + +import Data.Field.Galois +import Test.Tasty + +import Test.Galois + +type F2A = Binary 0x20000000000000000000000000201 +type F2B = Binary 0x80000000000000000000000000000010d +type F2C = Binary 0x800000000000000000000000000000000000000c9 +type F2D = Binary 0x2000000000000000000000000000000000000000000008001 +type F2E = Binary 0x20000000000000000000000000000000000000004000000000000000001 +type F2F = Binary 0x800000000000000000004000000000000000000000000000000000000001 +type F2G = Binary 0x800000000000000000000000000000000000000000000000000000000000000000010a1 +type F2H = Binary 0x2000000000000000000000000000000000000000000000000000000000000000000000000000000008000000000000000000001 +type F2I = Binary 0x80000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000425 + +testBinary :: TestTree +testBinary = testGroup "Binary fields" + [ test "F2A" (witness :: F2A) + , test "F2B" (witness :: F2B) + , test "F2C" (witness :: F2C) + , test "F2D" (witness :: F2D) + , test "F2E" (witness :: F2E) + , test "F2F" (witness :: F2F) + , test "F2G" (witness :: F2G) + , test "F2H" (witness :: F2H) + , test "F2I" (witness :: F2I) + ] diff --git a/test/Test/Extension.hs b/test/Test/Extension.hs new file mode 100644 --- /dev/null +++ b/test/Test/Extension.hs @@ -0,0 +1,107 @@ +module Test.Extension where + +import Protolude + +import Data.Field.Galois +import Test.Tasty + +import Test.Galois +import Test.Prime + +data P111 +instance IrreducibleMonic P111 FS2 where + poly _ = X2 + X + 1 +type FS4 = Extension P111 FS2 + +data P1101 +instance IrreducibleMonic P1101 FS2 where + poly _ = X3 + X + 1 +type FS8 = Extension P1101 FS2 + +data P1011 +instance IrreducibleMonic P1011 FS2 where + poly _ = X3 + X2 + 1 +type FS8' = Extension P1011 FS2 + +data P101 +instance IrreducibleMonic P101 FS3 where + poly _ = X2 + 1 +type FS9 = Extension P101 FS3 + +data P211 +instance IrreducibleMonic P211 FS3 where + poly _ = X2 + X - 1 +type FS9' = Extension P211 FS3 + +data P221 +instance IrreducibleMonic P221 FS3 where + poly _ = X2 - X - 1 +type FS9'' = Extension P221 FS3 + +instance IrreducibleMonic P101 FM0 where + poly _ = X2 + 1 +type FL0 = Extension P101 FM0 + +instance IrreducibleMonic P101 FM1 where + poly _ = X2 + 1 +type FL1 = Extension P101 FM1 + +instance IrreducibleMonic P101 FM2 where + poly _ = X2 + 1 +type FL2 = Extension P101 FM2 + +instance IrreducibleMonic P101 FM3 where + poly _ = X2 + 1 +type FL3 = Extension P101 FM3 + +instance IrreducibleMonic P101 FM4 where + poly _ = X2 + 1 +type FL4 = Extension P101 FM4 + +instance IrreducibleMonic P101 FVL where + poly _ = X2 + 17 +type FV2 = Extension P101 FVL + +instance IrreducibleMonic P101 FXL where + poly _ = X2 + 17 +type FX2 = Extension P101 FXL + +instance IrreducibleMonic P101 FZL where + poly _ = X2 + 17 +type FZ2 = Extension P101 FZL + +data PU +instance IrreducibleMonic PU Fq where + poly _ = X2 + 1 +type Fq2 = Extension PU Fq + +data PV +instance IrreducibleMonic PV Fq2 where + poly _ = X3 - 9 - Y X +type Fq6 = Extension PV Fq2 + +data PW +instance IrreducibleMonic PW Fq6 where + poly _ = X2 - Y X +type Fq12 = Extension PW Fq6 + +testExtension :: TestTree +testExtension = testGroup "Extension fields" + [ test' "FS4" (witness :: FS4 ) -- not implemented. + , test "FS8" (witness :: FS8 ) + , test "FS8'" (witness :: FS8' ) + , test "FS9" (witness :: FS9 ) + , test "FS9'" (witness :: FS9' ) + , test "FS9''" (witness :: FS9'') + , test "FL0" (witness :: FL0 ) + , test "FL1" (witness :: FL1 ) + , test "FL2" (witness :: FL2 ) + , test "FL3" (witness :: FL3 ) + , test "FL4" (witness :: FL4 ) + , test "FV2" (witness :: FV2 ) + , test "FX2" (witness :: FX2 ) + , test "FZ2" (witness :: FZ2 ) + , test "Fq2" (witness :: Fq2 ) + , test' "Fq6" (witness :: Fq6 ) -- time out. + , test' "Fq12" (witness :: Fq12 ) -- time out. + ] diff --git a/test/Test/Galois.hs b/test/Test/Galois.hs new file mode 100644 --- /dev/null +++ b/test/Test/Galois.hs @@ -0,0 +1,76 @@ +module Test.Galois where + +import Protolude + +import Data.Field.Galois hiding (recip) +import Test.Tasty +import Test.Tasty.QuickCheck + +annihilation :: Eq a => (a -> a -> a) -> a -> a -> Bool +annihilation op e x = op x e == e && op e x == e + +associativity :: Eq a => (a -> a -> a) -> a -> a -> a -> Bool +associativity op x y z = op x (op y z) == op (op x y) z + +commutativity :: Eq a => (a -> a -> a) -> a -> a -> Bool +commutativity op x y = op x y == op y x + +distributivity :: Eq a => (a -> a -> a) -> (a -> a -> a) -> a -> a -> a -> Bool +distributivity op op' x y z = op (op' x y) z == op' (op x z) (op y z) + && op x (op' y z) == op' (op x y) (op x z) + +identities :: Eq a => (a -> a -> a) -> a -> a -> Bool +identities op e x = op x e == x && op e x == x + +inverses :: Eq a => (a -> a -> a) -> (a -> a) -> a -> a -> Bool +inverses op inv e x = op x (inv x) == e && op (inv x) x == e + +groupAxioms :: forall g . (Arbitrary g, Eq g, Show g) + => (g -> g -> g) -> (g -> g) -> g -> (g -> Bool) -> [TestTree] +groupAxioms add inv id cond = + [ testProperty "associativity" $ + associativity add + , testProperty "commutativity" $ + commutativity add + , testProperty "identity" $ + identities add id + , testProperty "inverses" $ + \x -> cond x ==> inverses add inv id x + ] + +fieldAxioms :: forall k . GaloisField k => k -> TestTree +fieldAxioms _ = testGroup "Field axioms" + [ testGroup "additive group axioms" $ + groupAxioms (+) negate (0 :: k) (const True) + , testGroup "multiplicative group axioms" $ + groupAxioms (*) recip (1 :: k) (/= 0) + , testProperty "distributivity of multiplication over addition" $ + distributivity ((*) :: k -> k -> k) (+) + , testProperty "multiplicative annihilation" $ + annihilation ((*) :: k -> k -> k) 0 + ] + +frobeniusEndomorphisms :: forall k . GaloisField k => k -> TestTree +frobeniusEndomorphisms _ = testGroup "Frobenius endomorphisms" + [ testProperty "frobenius endomorphisms are characteristic powers" $ + \(x :: k) -> frob x == pow x (char (witness :: k)) + , testProperty "frobenius endomorphisms are ring homomorphisms" $ + \(x :: k) (y :: k) (z :: k) -> frob (x * y + z) == frob x * frob y + frob z + ] + +squareRoots :: forall k . GaloisField k => k -> TestTree +squareRoots _ = localOption (QuickCheckMaxRatio 100) + . localOption (QuickCheckTests 10) $ testGroup "Square roots" + [ testProperty "squares of square roots" $ + \(x :: k) -> qr x + ==> ((join (*) <$> sr x) == Just x) + , testProperty "solutions of quadratic equations" $ + \(a :: k) (b :: k) (c :: k) -> a /= 0 && isJust (quad a b c) + ==> (((\x -> (a * x + b) * x + c) <$> quad a b c) == Just 0) + ] + +test :: forall k . GaloisField k => TestName -> k -> TestTree +test s x = testGroup s [fieldAxioms x, frobeniusEndomorphisms x, squareRoots x] + +test' :: forall k . GaloisField k => TestName -> k -> TestTree +test' s x = testGroup s [fieldAxioms x, frobeniusEndomorphisms x] diff --git a/test/Test/Prime.hs b/test/Test/Prime.hs new file mode 100644 --- /dev/null +++ b/test/Test/Prime.hs @@ -0,0 +1,41 @@ +module Test.Prime where + +import Protolude + +import Data.Field.Galois +import Test.Tasty + +import Test.Galois + +type FS2 = Prime 2 +type FS3 = Prime 3 +type FS5 = Prime 5 +type FS7 = Prime 7 + +type FM0 = Prime 2147483647 +type FM1 = Prime 2305843009213693951 +type FM2 = Prime 618970019642690137449562111 +type FM3 = Prime 162259276829213363391578010288127 +type FM4 = Prime 170141183460469231731687303715884105727 + +type FVL = Prime 20988936657440586486151264256610222593863921 +type FXL = Prime 5210644015679228794060694325390955853335898483908056458352183851018372555735221 +type FZL = Prime 741640062627530801524787141901937474059940781097519023905821316144415759504705008092818711693940737 + +type Fq = Prime 21888242871839275222246405745257275088696311157297823662689037894645226208583 + +testPrime :: TestTree +testPrime = testGroup "Prime fields" + [ test "FS2" (witness :: FS2) + , test "FS3" (witness :: FS3) + , test "FS5" (witness :: FS5) + , test "FS7" (witness :: FS7) + , test "FM0" (witness :: FM0) + , test "FM1" (witness :: FM1) + , test "FM2" (witness :: FM2) + , test "FM3" (witness :: FM3) + , test "FM4" (witness :: FM4) + , test "FVL" (witness :: FVL) + , test "FXL" (witness :: FXL) + , test "FZL" (witness :: FZL) + ] diff --git a/tests/BinaryFieldTests.hs b/tests/BinaryFieldTests.hs deleted file mode 100644 --- a/tests/BinaryFieldTests.hs +++ /dev/null @@ -1,31 +0,0 @@ -module BinaryFieldTests where - -import Protolude - -import BinaryField -import Test.Tasty - -import GaloisFieldTests - -type F2A = BinaryField 0x20000000000000000000000000201 -type F2B = BinaryField 0x80000000000000000000000000000010d -type F2C = BinaryField 0x800000000000000000000000000000000000000c9 -type F2D = BinaryField 0x2000000000000000000000000000000000000000000008001 -type F2E = BinaryField 0x20000000000000000000000000000000000000004000000000000000001 -type F2F = BinaryField 0x800000000000000000004000000000000000000000000000000000000001 -type F2G = BinaryField 0x800000000000000000000000000000000000000000000000000000000000000000010a1 -type F2H = BinaryField 0x2000000000000000000000000000000000000000000000000000000000000000000000000000000008000000000000000000001 -type F2I = BinaryField 0x80000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000425 - -testBinaryField :: TestTree -testBinaryField = testGroup "Binary fields" - [ test "F2A" (witness :: F2A) - , test "F2B" (witness :: F2B) - , test "F2C" (witness :: F2C) - , test "F2D" (witness :: F2D) - , test "F2E" (witness :: F2E) - , test "F2F" (witness :: F2F) - , test "F2G" (witness :: F2G) - , test "F2H" (witness :: F2H) - , test "F2I" (witness :: F2I) - ] diff --git a/tests/ExtensionFieldTests.hs b/tests/ExtensionFieldTests.hs deleted file mode 100644 --- a/tests/ExtensionFieldTests.hs +++ /dev/null @@ -1,107 +0,0 @@ -module ExtensionFieldTests where - -import Protolude - -import ExtensionField -import Test.Tasty - -import GaloisFieldTests -import PrimeFieldTests - -data P111 -instance IrreducibleMonic FS2 P111 where - split _ = X2 + X + 1 -type FS4 = ExtensionField FS2 P111 - -data P1101 -instance IrreducibleMonic FS2 P1101 where - split _ = X3 + X + 1 -type FS8 = ExtensionField FS2 P1101 - -data P1011 -instance IrreducibleMonic FS2 P1011 where - split _ = X3 + X2 + 1 -type FS8' = ExtensionField FS2 P1011 - -data P101 -instance IrreducibleMonic FS3 P101 where - split _ = X2 + 1 -type FS9 = ExtensionField FS3 P101 - -data P211 -instance IrreducibleMonic FS3 P211 where - split _ = X2 + X - 1 -type FS9' = ExtensionField FS3 P211 - -data P221 -instance IrreducibleMonic FS3 P221 where - split _ = X2 - X - 1 -type FS9'' = ExtensionField FS3 P221 - -instance IrreducibleMonic FM0 P101 where - split _ = X2 + 1 -type FL0 = ExtensionField FM0 P101 - -instance IrreducibleMonic FM1 P101 where - split _ = X2 + 1 -type FL1 = ExtensionField FM1 P101 - -instance IrreducibleMonic FM2 P101 where - split _ = X2 + 1 -type FL2 = ExtensionField FM2 P101 - -instance IrreducibleMonic FM3 P101 where - split _ = X2 + 1 -type FL3 = ExtensionField FM3 P101 - -instance IrreducibleMonic FM4 P101 where - split _ = X2 + 1 -type FL4 = ExtensionField FM4 P101 - -instance IrreducibleMonic FVL P101 where - split _ = X2 + 17 -type FV2 = ExtensionField FVL P101 - -instance IrreducibleMonic FXL P101 where - split _ = X2 + 17 -type FX2 = ExtensionField FXL P101 - -instance IrreducibleMonic FZL P101 where - split _ = X2 + 17 -type FZ2 = ExtensionField FZL P101 - -data Pu -instance IrreducibleMonic Fq Pu where - split _ = X2 + 1 -type Fq2 = ExtensionField Fq Pu - -data Pv -instance IrreducibleMonic Fq2 Pv where - split _ = X3 - 9 - Y X -type Fq6 = ExtensionField Fq2 Pv - -data Pw -instance IrreducibleMonic Fq6 Pw where - split _ = X2 - Y X -type Fq12 = ExtensionField Fq6 Pw - -testExtensionField :: TestTree -testExtensionField = testGroup "Extension fields" - [ test' "FS4" (witness :: FS4 ) -- not implemented. - , test "FS8" (witness :: FS8 ) - , test "FS8'" (witness :: FS8' ) - , test "FS9" (witness :: FS9 ) - , test "FS9'" (witness :: FS9' ) - , test "FS9''" (witness :: FS9'') - , test "FL0" (witness :: FL0 ) - , test "FL1" (witness :: FL1 ) - , test "FL2" (witness :: FL2 ) - , test "FL3" (witness :: FL3 ) - , test "FL4" (witness :: FL4 ) - , test "FV2" (witness :: FV2 ) - , test "FX2" (witness :: FX2 ) - , test "FZ2" (witness :: FZ2 ) - , test "Fq2" (witness :: Fq2 ) - , test' "Fq6" (witness :: Fq6 ) -- time out. - , test' "Fq12" (witness :: Fq12 ) -- time out. - ] diff --git a/tests/GaloisFieldTests.hs b/tests/GaloisFieldTests.hs deleted file mode 100644 --- a/tests/GaloisFieldTests.hs +++ /dev/null @@ -1,61 +0,0 @@ -module GaloisFieldTests where - -import Protolude - -import GaloisField -import Test.Tasty -import Test.Tasty.QuickCheck - -associativity :: Eq a => (a -> a -> a) -> a -> a -> a -> Bool -associativity op x y z = op x (op y z) == op (op x y) z - -commutativity :: Eq a => (a -> a -> a) -> a -> a -> Bool -commutativity op x y = op x y == op y x - -distributivity :: Eq a => (a -> a -> a) -> (a -> a -> a) -> a -> a -> a -> Bool -distributivity op op' x y z = op (op' x y) z == op' (op x z) (op y z) - && op x (op' y z) == op' (op x y) (op x z) - -identities :: Eq a => (a -> a -> a) -> a -> a -> Bool -identities op e x = op x e == x && op e x == x - -inverses :: Eq a => (a -> a -> a) -> (a -> a) -> a -> a -> Bool -inverses op inv e x = op x (inv x) == e && op (inv x) x == e - -fieldAxioms :: forall k . GaloisField k => k -> TestTree -fieldAxioms _ = testGroup ("Field axioms") - [ testProperty "commutativity of addition" - $ commutativity ((+) :: k -> k -> k) - , testProperty "commutativity of multiplication" - $ commutativity ((*) :: k -> k -> k) - , testProperty "associativity of addition" - $ associativity ((+) :: k -> k -> k) - , testProperty "associativity of multiplication" - $ associativity ((*) :: k -> k -> k) - , testProperty "distributivity of multiplication over addition" - $ distributivity ((*) :: k -> k -> k) (+) - , testProperty "additive identity" - $ identities ((+) :: k -> k -> k) 0 - , testProperty "multiplicative identity" - $ identities ((*) :: k -> k -> k) 1 - , testProperty "additive inverses" - $ inverses ((+) :: k -> k -> k) negate 0 - , testProperty "multiplicative inverses" - $ \x -> x /= 0 ==> inverses ((*) :: k -> k -> k) recip 1 x - ] - -squareRoots :: forall k . GaloisField k => k -> TestTree -squareRoots _ = localOption (QuickCheckTests 10) $ testGroup "Square roots" - [ testProperty "squares of square roots" - $ \(x :: k) -> isJust (sr x) - ==> (((^ (2 :: Int)) <$> sr x) == Just x) - , testProperty "solutions of quadratic equations" - $ \(a :: k) (b :: k) (c :: k) -> a /= 0 && b /= 0 && isJust (quad a b c) - ==> (((\x -> a * x * x + b * x + c) <$> quad a b c) == Just 0) - ] - -test :: forall k . GaloisField k => TestName -> k -> TestTree -test s x = testGroup s [fieldAxioms x, squareRoots x] - -test' :: forall k . GaloisField k => TestName -> k -> TestTree -test' s x = testGroup s [fieldAxioms x] diff --git a/tests/Main.hs b/tests/Main.hs deleted file mode 100644 --- a/tests/Main.hs +++ /dev/null @@ -1,13 +0,0 @@ -module Main where - -import Protolude - -import Test.Tasty - -import BinaryFieldTests -import ExtensionFieldTests -import PrimeFieldTests - -main :: IO () -main = defaultMain $ - testGroup "Tests" [testPrimeField, testExtensionField, testBinaryField] diff --git a/tests/PrimeFieldTests.hs b/tests/PrimeFieldTests.hs deleted file mode 100644 --- a/tests/PrimeFieldTests.hs +++ /dev/null @@ -1,41 +0,0 @@ -module PrimeFieldTests where - -import Protolude - -import PrimeField -import Test.Tasty - -import GaloisFieldTests - -type FS2 = PrimeField 2 -type FS3 = PrimeField 3 -type FS5 = PrimeField 5 -type FS7 = PrimeField 7 - -type FM0 = PrimeField 2147483647 -type FM1 = PrimeField 2305843009213693951 -type FM2 = PrimeField 618970019642690137449562111 -type FM3 = PrimeField 162259276829213363391578010288127 -type FM4 = PrimeField 170141183460469231731687303715884105727 - -type FVL = PrimeField 20988936657440586486151264256610222593863921 -type FXL = PrimeField 5210644015679228794060694325390955853335898483908056458352183851018372555735221 -type FZL = PrimeField 741640062627530801524787141901937474059940781097519023905821316144415759504705008092818711693940737 - -type Fq = PrimeField 21888242871839275222246405745257275088696311157297823662689037894645226208583 - -testPrimeField :: TestTree -testPrimeField = testGroup "Prime fields" - [ test "FS2" (witness :: FS2) - , test "FS3" (witness :: FS3) - , test "FS5" (witness :: FS5) - , test "FS7" (witness :: FS7) - , test "FM0" (witness :: FM0) - , test "FM1" (witness :: FM1) - , test "FM2" (witness :: FM2) - , test "FM3" (witness :: FM3) - , test "FM4" (witness :: FM4) - , test "FVL" (witness :: FVL) - , test "FXL" (witness :: FXL) - , test "FZL" (witness :: FZL) - ]