diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,6 +1,15 @@ Changelog for lol project ================================ +0.3.0.0 +----- + * Support for protocol-buffers + * Support for reifying Factored types + * Support for reals (RR) mod q + * Replaced C backend with C++ backend + * Renamed LatticePrelude -> Prelude + * Added monad argument to CRTrans + 0.2.0.0 ----- * Added benchmarks diff --git a/Crypto/Lol.hs b/Crypto/Lol.hs --- a/Crypto/Lol.hs +++ b/Crypto/Lol.hs @@ -1,21 +1,16 @@ -- | Re-exports primary interfaces. -module Crypto.Lol -( module Crypto.Lol.Cyclotomic.Cyc -, module Crypto.Lol.Gadget -, module Crypto.Lol.LatticePrelude - -, module Crypto.Lol.Types.ZqBasic -, module Crypto.Lol.Cyclotomic.Tensor.CTensor -, module Crypto.Lol.Cyclotomic.Tensor.RepaTensor -, module Crypto.Lol.Types.IrreducibleChar2) where +module Crypto.Lol +( module X +) where -import Crypto.Lol.Cyclotomic.Cyc -import Crypto.Lol.Gadget -import Crypto.Lol.LatticePrelude +import Crypto.Lol.Cyclotomic.Cyc as X +import Crypto.Lol.Gadget as X +import Crypto.Lol.Prelude as X -import Crypto.Lol.Types.ZqBasic -import Crypto.Lol.Cyclotomic.Tensor.CTensor -import Crypto.Lol.Cyclotomic.Tensor.RepaTensor -import Crypto.Lol.Types.IrreducibleChar2 +import Crypto.Lol.Cyclotomic.Tensor.CTensor as X +import Crypto.Lol.Cyclotomic.Tensor.RepaTensor as X +import Crypto.Lol.Types.IrreducibleChar2 as X () +import Crypto.Lol.Types.RRq as X +import Crypto.Lol.Types.ZqBasic as X diff --git a/Crypto/Lol/CRTrans.hs b/Crypto/Lol/CRTrans.hs --- a/Crypto/Lol/CRTrans.hs +++ b/Crypto/Lol/CRTrans.hs @@ -1,5 +1,10 @@ -{-# LANGUAGE FlexibleContexts, FlexibleInstances, RebindableSyntax, - ScopedTypeVariables, TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} -- | Classes and helper methods for the Chinese remainder transform -- and ring extensions. @@ -7,15 +12,12 @@ module Crypto.Lol.CRTrans ( CRTrans(..), CRTEmbed(..) , CRTInfo -, crtInfoFact, crtInfoPPow, crtInfoPrime -, gEmbPPow, gEmbPrime ) where -import Crypto.Lol.LatticePrelude +import Crypto.Lol.Prelude +import Crypto.Lol.Reflects import Control.Arrow -import Data.Singletons -import Data.Singletons.Prelude -- | Information that characterizes the (invertible) Chinese remainder -- transformation over a ring @r@, namely: @@ -32,17 +34,15 @@ -- | The values of 'crtInfo' for different indices @m@ should be -- consistent, in the sense that if @omega@, @omega'@ are respectively --- the values returned for @m@, @m'@ where @m'@ divides @m@, then it --- should be the case that @omega^(m/m')=omega'@. +-- the roots of unity used for @m@, @m'@ where @m@ divides @m'@, then +-- it should be the case that @omega'^(m'/m)=omega@. -class Ring r => CRTrans r where +class (Monad mon, Ring r) => CRTrans mon r where -- | 'CRTInfo' for a given index @m@. The method itself may be -- slow, but the function it returns should be fast, e.g., via - -- internal memoization. The default implementation returns - -- 'Nothing'. - crtInfo :: Int -> Maybe (CRTInfo r) - crtInfo = const Nothing + -- internal memoization. + crtInfo :: Reflects m Int => TaggedT m mon (CRTInfo r) -- | A ring with a ring embedding into some ring @CRTExt r@ that has -- an invertible CRT transformation for /every/ positive index @m@. @@ -54,83 +54,68 @@ -- | Projects from @CRTExt r@ to @r@ fromExt :: CRTExt r -> r --- CRTrans instance for product rings -instance (CRTrans a, CRTrans b) => CRTrans (a,b) where - crtInfo i = do - (apow, aiInv) <- crtInfo i - (bpow, biInv) <- crtInfo i - return (apow &&& bpow, (aiInv, biInv)) +-- | Product ring +instance (CRTrans mon a, CRTrans mon b) => CRTrans mon (a,b) where + crtInfo = do + (fa, inva) <- crtInfo + (fb, invb) <- crtInfo + return (fa &&& fb, (inva, invb)) --- CRTEmbed instance for product rings +-- | Product ring instance (CRTEmbed a, CRTEmbed b) => CRTEmbed (a,b) where type CRTExt (a,b) = (CRTExt a, CRTExt b) toExt = toExt *** toExt fromExt = fromExt *** fromExt -omegaPowC :: (Transcendental a) => Int -> Int -> Complex a -omegaPowC m i = cis (2*pi*fromIntegral i / fromIntegral m) - --- | 'crtInfo' wrapper for 'Fact' types. -crtInfoFact :: (Fact m, CRTrans r) => TaggedT m Maybe (CRTInfo r) -crtInfoFact = (tagT . crtInfo) =<< pureT valueFact - --- | 'crtInfo' wrapper for 'PPow' types. -crtInfoPPow :: (PPow pp, CRTrans r) => TaggedT pp Maybe (CRTInfo r) -crtInfoPPow = (tagT . crtInfo) =<< pureT valuePPow - --- | 'crtInfo' wrapper for 'Prime' types. -crtInfoPrime :: (Prim p, CRTrans r) => TaggedT p Maybe (CRTInfo r) -crtInfoPrime = (tagT . crtInfo) =<< pureT valuePrime - --- | A function that returns the 'i'th embedding of @g_{p^e} = g_p@ for --- @i@ in @Z*_{p^e}@. -gEmbPPow :: forall pp r . (PPow pp, CRTrans r) => TaggedT pp Maybe (Int -> r) -gEmbPPow = tagT $ case (sing :: SPrimePower pp) of - (SPP (STuple2 sp _)) -> withWitnessT gEmbPrime sp +-- | Complex numbers have 'CRTrans' for any index @m@ +instance (Monad mon, Transcendental a) => CRTrans mon (Complex a) where + crtInfo = crtInfoC --- | A function that returns the @i@th embedding of @g_p@ for @i@ in @Z*_p@, --- i.e., @1-omega_p^i@. -gEmbPrime :: (Prim p, CRTrans r) => TaggedT p Maybe (Int -> r) -gEmbPrime = do - (f, _) <- crtInfoPrime - return $ \i -> one - f i -- not checking that i /= 0 (mod p) +crtInfoC :: forall mon m a . (Monad mon, Reflects m Int, Transcendental a) + => TaggedT m mon (CRTInfo (Complex a)) +crtInfoC = let mval = proxy value (Proxy::Proxy m) + mhat = valueHat mval + in return (omegaPowC mval, recip $ fromIntegral mhat) --- the complex numbers have roots of unity of any order -instance (Transcendental a) => CRTrans (Complex a) where - crtInfo m = Just (omegaPowC m, recip $ fromIntegral $ valueHat m) +omegaPowC :: (Transcendental a) => Int -> Int -> Complex a +omegaPowC m i = cis (2*pi*fromIntegral i / fromIntegral m) --- trivial CRTEmbed instance for complex numbers +-- | Self-embed instance (Transcendental a) => CRTEmbed (Complex a) where type CRTExt (Complex a) = Complex a toExt = id fromExt = id --- Default CRTrans instances for real and integer types, which do --- not have roots of unity (except in trivial cases). These are needed --- to use FastCyc with these integer types. -instance CRTrans Double -instance CRTrans Int -instance CRTrans Int64 -instance CRTrans Integer +-- | Returns 'Nothing' +instance CRTrans Maybe Double where crtInfo = tagT Nothing +-- | Returns 'Nothing' +instance CRTrans Maybe Int where crtInfo = tagT Nothing +-- | Returns 'Nothing' +instance CRTrans Maybe Int64 where crtInfo = tagT Nothing +-- | Returns 'Nothing' +instance CRTrans Maybe Integer where crtInfo = tagT Nothing -- can also do for Int8, Int16, Int32 etc. --- CRTEmbed instances for real and integer types, embedding into --- Complex. These are needed to use FastCyc with these integer types. +-- | Embeds into complex numbers instance CRTEmbed Double where type CRTExt Double = Complex Double toExt = fromReal . realToField fromExt = realToField . real +-- | Embeds into complex numbers instance CRTEmbed Int where type CRTExt Int = Complex Double toExt = fromIntegral fromExt = fst . roundComplex +-- | Embeds into complex numbers instance CRTEmbed Int64 where type CRTExt Int64 = Complex Double toExt = fromIntegral fromExt = fst . roundComplex +-- | Embeds into complex numbers. (May not have sufficient +-- precision.) instance CRTEmbed Integer where -- CJP: sufficient precision? Not in general. type CRTExt Integer = Complex Double diff --git a/Crypto/Lol/Cyclotomic/CRTSentinel.hs b/Crypto/Lol/Cyclotomic/CRTSentinel.hs new file mode 100644 --- /dev/null +++ b/Crypto/Lol/Cyclotomic/CRTSentinel.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +-- | Safely exposes a "sentinel" indicating usage of either CRT basis +-- over a base ring, or over its extension ring. Exactly one of +-- 'CSentinel' or 'ESentinel' has an externally exposed value. + +module Crypto.Lol.Cyclotomic.CRTSentinel +( CSentinel, ESentinel +, crtSentinel, crtCSentinel, crtESentinel +, scalarCRTCS, crtCS, crtInvCS, mulGCRTCS, divGCRTCS +, embedCRTCS, twaceCRTCS +) where + +import Data.Functor.Trans.Tagged +import Data.Maybe +import Data.Proxy + +import Crypto.Lol.CRTrans +import Crypto.Lol.Cyclotomic.Tensor +import Crypto.Lol.Factored + +data CSentinel t m r = CSentinel +data ESentinel t m r = ESentinel + +crtSentinel :: (Tensor t, Fact m, CRTrans Maybe r, TElt t r) + => Either (ESentinel t m r) (CSentinel t m r) +crtSentinel = fromMaybe (Left ESentinel) (Right <$> crtCSentinel) +{-# INLINABLE crtSentinel #-} + +crtCSentinel :: forall t m r . + (Tensor t, Fact m, CRTrans Maybe r, TElt t r) + => Maybe (CSentinel t m r) +crtCSentinel = proxyT hasCRTFuncs (Proxy::Proxy (t m r)) *> + pure CSentinel +{-# INLINABLE crtCSentinel #-} + +crtESentinel :: (Tensor t, Fact m, CRTrans Maybe r, TElt t r) + => Maybe (ESentinel t m r) +crtESentinel = case crtSentinel of + Left s -> Just s + Right _ -> Nothing +{-# INLINABLE crtESentinel #-} + +scalarCRTCS :: (Tensor t, Fact m, CRTrans Maybe r, TElt t r) + => CSentinel t m r -> r -> t m r +scalarCRTCS _ = fromJust scalarCRT +{-# INLINABLE scalarCRTCS #-} + +crtCS, crtInvCS, mulGCRTCS, divGCRTCS :: + (Tensor t, Fact m, CRTrans Maybe r, TElt t r) + => CSentinel t m r -> t m r -> t m r + +crtCS _ = fromJust crt +crtInvCS _ = fromJust crtInv +mulGCRTCS _ = fromJust mulGCRT +divGCRTCS _ = fromJust divGCRT + +{-# INLINABLE crtCS #-} +{-# INLINABLE crtInvCS #-} +{-# INLINABLE mulGCRTCS #-} +{-# INLINABLE divGCRTCS #-} + +embedCRTCS :: (Tensor t, m `Divides` m', CRTrans Maybe r, TElt t r) + => CSentinel t m r -> CSentinel t m' r -> t m r -> t m' r +embedCRTCS _ _ = fromJust embedCRT +{-# INLINABLE embedCRTCS #-} + +twaceCRTCS :: (Tensor t, m `Divides` m', CRTrans Maybe r, TElt t r) + => CSentinel t m' r -> CSentinel t m r -> t m' r -> t m r +twaceCRTCS _ _ = fromJust twaceCRT +{-# INLINABLE twaceCRTCS #-} + diff --git a/Crypto/Lol/Cyclotomic/Cyc.hs b/Crypto/Lol/Cyclotomic/Cyc.hs --- a/Crypto/Lol/Cyclotomic/Cyc.hs +++ b/Crypto/Lol/Cyclotomic/Cyc.hs @@ -1,7 +1,16 @@ -{-# LANGUAGE ConstraintKinds, DataKinds, FlexibleContexts, - FlexibleInstances, GADTs, MultiParamTypeClasses, - NoImplicitPrelude, PolyKinds, RankNTypes, ScopedTypeVariables, - TypeFamilies, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} -- | An implementation of cyclotomic rings that hides the -- internal representations of ring elements (e.g., the choice of @@ -24,8 +33,9 @@ -- * Data type and constraints Cyc, CElt, U.NFElt -- * Constructors/deconstructors -, cycPow, cycDec, cycCRT, scalarCyc -, uncycPow, uncycDec, uncycCRT, unzipCyc, unzipCElt +, scalarCyc +, cycPow, cycDec, cycCRT, cycCRTC, cycCRTE, cycPC, cycPE +, uncycPow, uncycDec, uncycCRT, unzipCyc -- * Core cyclotomic operations , mulG, divG, gSqNorm, liftCyc, liftPow, liftDec -- * Representation advice @@ -33,7 +43,7 @@ -- * Error sampling , tGaussian, errorRounded, errorCoset -- * Sub/extension rings -, embed, twace, coeffsCyc, powBasis, crtSet +, embed, twace, coeffsCyc, coeffsPow, coeffsDec, powBasis, crtSet -- * Rescaling cyclotomic elements , R.RescaleCyc(..), R.Basis(..) ) where @@ -45,27 +55,29 @@ import Crypto.Lol.Cyclotomic.UCyc hiding (coeffsDec, coeffsPow, crtSet, divG, errorCoset, errorRounded, gSqNorm, - mulG, powBasis, tGaussian, unzipCyc) + mulG, powBasis, tGaussian) import Crypto.Lol.CRTrans import qualified Crypto.Lol.Cyclotomic.RescaleCyc as R -import Crypto.Lol.Cyclotomic.Tensor (CRTElt, TElt, Tensor) +import Crypto.Lol.Cyclotomic.Tensor (TElt, Tensor) import qualified Crypto.Lol.Cyclotomic.UCyc as U import Crypto.Lol.Gadget -import Crypto.Lol.LatticePrelude as LP +import Crypto.Lol.Prelude as LP import Crypto.Lol.Types.FiniteField +import Crypto.Lol.Types.Proto import Crypto.Lol.Types.ZPP import Control.Applicative hiding ((*>)) import Control.Arrow import Control.DeepSeq -import Control.Monad.Identity -- needed for coerce +import Control.Monad.Identity -- GHC warning is wrong: https://ghc.haskell.org/trac/ghc/ticket/12067 import Control.Monad.Random import Data.Coerce import Data.Traversable import Test.QuickCheck + -- | Represents a cyclotomic ring such as @Z[zeta]@, -- @Zq[zeta]@, and @Q(zeta)@ in an explicit representation: @t@ is the -- 'Tensor' type for storing coefficient tensors; @m@ is the @@ -74,15 +86,15 @@ data Cyc t m r where Pow :: !(UCyc t m P r) -> Cyc t m r Dec :: !(UCyc t m D r) -> Cyc t m r - CRT :: !(UCyc t m C r) -> Cyc t m r + CRT :: !(UCycEC t m r) -> Cyc t m r -- super-optimized storage of scalars Scalar :: !r -> Cyc t m r -- optimized storage of subring elements Sub :: (l `Divides` m) => !(Cyc t l r) -> Cyc t m r -- CJP: someday try to merge the above two --- | Constraints needed for many operations involving 'Cyc' data. -type CElt t r = UCElt t r +-- | Constraints needed for most operations involving 'Cyc' data. +type CElt t r = (UCRTElt t r, ZeroTestable r) ---------- Constructors / deconstructors ---------- @@ -96,11 +108,31 @@ cycDec = Dec {-# INLINABLE cycDec #-} --- | Wrap a 'UCyc' as a 'Cyc'. -cycCRT :: UCyc t m C r -> Cyc t m r +-- | Wrap a 'UCycEC' as a 'Cyc'. +cycCRT :: UCycEC t m r -> Cyc t m r cycCRT = CRT {-# INLINABLE cycCRT #-} +-- | Wrap a 'UCyc' as a 'Cyc'. +cycCRTC :: UCyc t m C r -> Cyc t m r +cycCRTC = CRT . Right +{-# INLINABLE cycCRTC #-} + +-- | Wrap a 'UCyc' as a 'Cyc'. +cycCRTE :: UCyc t m E r -> Cyc t m r +cycCRTE = CRT . Left +{-# INLINABLE cycCRTE #-} + +-- | Convenience wrapper. +cycPC :: Either (UCyc t m P r) (UCyc t m C r) -> Cyc t m r +cycPC = either Pow (CRT . Right) +{-# INLINABLE cycPC #-} + +-- | Convenience wrapper. +cycPE :: Either (UCyc t m P r) (UCyc t m E r) -> Cyc t m r +cycPE = either Pow (CRT . Left) +{-# INLINABLE cycPE #-} + -- | Embed a scalar from the base ring as a cyclotomic element. scalarCyc :: r -> Cyc t m r scalarCyc = Scalar @@ -116,8 +148,8 @@ {-# INLINABLE uncycDec #-} uncycDec c = let (Dec u) = toDec' c in u --- | Unwrap a 'Cyc' as a 'UCyc' in CRT-basis representation. -uncycCRT :: (Fact m, CElt t r) => Cyc t m r -> UCyc t m C r +-- | Unwrap a 'Cyc' as a 'UCyc' in a CRT-basis representation. +uncycCRT :: (Fact m, CElt t r) => Cyc t m r -> UCycEC t m r {-# INLINABLE uncycCRT #-} uncycCRT c = let (CRT u) = toCRT' c in u @@ -126,7 +158,8 @@ instance (Fact m, CElt t r) => ZeroTestable.C (Cyc t m r) where isZero (Pow u) = isZero u isZero (Dec u) = isZero u - isZero (CRT u) = isZero u + isZero (CRT (Right u)) = isZero u + isZero c@(CRT _) = isZero $ toPow' c isZero (Scalar c) = isZero c isZero (Sub c) = isZero c {-# INLINABLE isZero #-} @@ -136,19 +169,18 @@ (Scalar c1) == (Scalar c2) = c1 == c2 (Pow u1) == (Pow u2) = u1 == u2 (Dec u1) == (Dec u2) = u1 == u2 - (CRT u1) == (CRT u2) = u1 == u2 + (CRT (Right u1)) == (CRT (Right u2)) = u1 == u2 -- compare Subs in compositum + -- EAC: would like to convert c2 to basis of c1 before embedding (Sub (c1 :: Cyc t l1 r)) == (Sub (c2 :: Cyc t l2 r)) = (embed' c1 :: Cyc t (FLCM l1 l2) r) == embed' c2 \\ lcmDivides (Proxy::Proxy l1) (Proxy::Proxy l2) -- some other relatively efficient comparisons (Scalar c1) == (Pow u2) = scalarPow c1 == u2 - -- (Scalar c1) == (Dec u2) = scalarDec c1 == u2 (Pow u1) == (Scalar c2) = u1 == scalarPow c2 - -- (Dec u1) == (Scalar c2) = u1 == scalarDec c2 - -- default: compare in powerful basis + -- otherwise: compare in powerful basis c1 == c2 = toPow' c1 == toPow' c2 {-# INLINABLE (==) #-} @@ -168,6 +200,7 @@ (Dec u1) + (Dec u2) = Dec $ u1 + u2 (CRT u1) + (CRT u2) = CRT $ u1 + u2 -- Sub plus Sub: work in compositum + -- EAC: would like to convert c2 to basis of c1 before embedding (Sub (c1 :: Cyc t m1 r)) + (Sub (c2 :: Cyc t m2 r)) = (Sub $ (embed' c1 :: Cyc t (FLCM m1 m2) r) + embed' c2) \\ lcm2Divides (Proxy::Proxy m1) (Proxy::Proxy m2) (Proxy::Proxy m) @@ -185,6 +218,7 @@ (Sub c1) + (Scalar c2) = Sub $ c1 + Scalar c2 -- SUB PLUS NON-SUB, NON-SCALAR: work in full ring + -- EAC: would like to convert sub to basis of other before embedding (Sub c1) + c2 = embed' c1 + c2 c1 + (Sub c2) = c1 + embed' c2 @@ -218,8 +252,8 @@ v1@(Scalar c1) * _ | isZero c1 = v1 _ * v2@(Scalar c2) | isZero c2 = v2 - -- both CRT - (CRT u1) * (CRT u2) = CRT $ u1*u2 + -- both CRT: if over C, then convert result to pow for precision reasons + (CRT u1) * (CRT u2) = either (Pow . toPow) (CRT . Right) $ u1*u2 -- at least one Scalar (Scalar c1) * (Scalar c2) = Scalar $ c1*c2 @@ -242,6 +276,9 @@ -- ELSE: work in appropriate CRT rep c1 * c2 = toCRT' c1 * toCRT' c2 +-- | @Rp@ is an @F_{p^d}@-module when @d@ divides @phi(m)@, by +-- applying @d@-dimensional @Fp@-linear transform on @d@-dim chunks of +-- powerful basis coeffs instance (GFCtx fp d, Fact m, CElt t fp) => Module.C (GF fp d) (Cyc t m fp) where -- CJP: optimize for Scalar if we can: r *> (Scalar c) is the tensor -- that has the coeffs of (r*c), followed by zeros. (This assumes @@ -277,27 +314,25 @@ {-# INLINABLE mulG #-} mulG (Pow u) = Pow $ U.mulG u mulG (Dec u) = Dec $ U.mulG u -mulG (CRT u) = CRT $ U.mulG u -mulG (Scalar r) = CRT $ U.mulG $ scalarCRT r +mulG (CRT u) = CRT $ either (Left . U.mulG) (Right . U.mulG) u +mulG c@(Scalar _) = mulG $ toCRT' c mulG (Sub c) = mulG $ embed' c -- must go to full ring -- | Divide by @g@, returning 'Nothing' if not evenly divisible. -- WARNING: this implementation is not a constant-time algorithm, so -- information about the argument may be leaked through a timing -- channel. -divG :: (Fact m, CElt t r) => Cyc t m r -> Maybe (Cyc t m r) +divG :: (Fact m, CElt t r, IntegralDomain r) + => Cyc t m r -> Maybe (Cyc t m r) {-# INLINABLE divG #-} divG (Pow u) = Pow <$> U.divG u divG (Dec u) = Dec <$> U.divG u -divG (CRT u) = CRT <$> U.divG u -divG (Scalar r) = CRT <$> U.divG (scalarCRT r) +divG (CRT u) = CRT <$> either (fmap Left . U.divG) (fmap Right . U.divG) u +divG c@(Scalar _) = divG $ toCRT' c divG (Sub c) = divG $ embed' c -- must go to full ring -- | Sample from the "tweaked" Gaussian error distribution @t*D@ in --- the decoding basis, where @D@ has scaled variance @v@. (Note: This --- implementation uses Double precision to generate the Gaussian --- sample, which may not be sufficient for rigorous proof-based --- security.) +-- the decoding basis, where @D@ has scaled variance @v@. tGaussian :: (Fact m, OrdFloat q, Random q, Tensor t, TElt t q, ToRational v, MonadRandom rnd) => v -> rnd (Cyc t m q) @@ -309,16 +344,15 @@ -- @\hat{m}^{ -1 } \cdot || \sigma(g_m \cdot e) ||^2@ . gSqNorm :: forall t m r . (Fact m, CElt t r) => Cyc t m r -> r {-# INLINABLE gSqNorm #-} -gSqNorm (Pow u) = U.gSqNorm $ toDec u gSqNorm (Dec u) = U.gSqNorm u -gSqNorm (CRT u) = U.gSqNorm $ toDec u --- CJP: this is suboptimal (gSqNorm of scalar 1 is known) --- also workaround scalarDec -gSqNorm (Scalar u) = U.gSqNorm (toDec $ scalarPow u :: UCyc t m D r) -gSqNorm (Sub c) = U.gSqNorm (U.embedDec $ uncycDec c :: UCyc t m D r) +gSqNorm c = gSqNorm $ toDec' c -- | Generate an LWE error term with given scaled variance, -- deterministically rounded with respect to the decoding basis. +-- (Note: This +-- implementation uses Double precision to generate the Gaussian +-- sample, which may not be sufficient for rigorous proof-based +-- security.) errorRounded :: (ToInteger z, Tensor t, Fact m, TElt t z, ToRational v, MonadRandom rnd) => v -> rnd (Cyc t m z) {-# INLINABLE errorRounded #-} @@ -326,7 +360,10 @@ -- | Generate an LWE error term with given scaled variance @* p^2@ over -- the given coset, deterministically rounded with respect to the --- decoding basis. +-- decoding basis. (Note: This +-- implementation uses Double precision to generate the Gaussian +-- sample, which may not be sufficient for rigorous proof-based +-- security.) errorCoset :: (Mod zp, z ~ ModRep zp, Lift zp z, Fact m, CElt t zp, TElt t z, ToRational v, MonadRandom rnd) @@ -349,7 +386,7 @@ {-# INLINE embed' #-} embed' (Pow u) = Pow $ embedPow u embed' (Dec u) = Dec $ embedDec u -embed' (CRT u) = either Pow CRT $ embedCRT u +embed' (CRT u) = either (cycPE . embedCRTE) (cycPC . embedCRTC) u embed' (Scalar c) = Scalar c embed' (Sub (c :: Cyc t k r)) = embed' c \\ transDivides (Proxy::Proxy k) (Proxy::Proxy l) (Proxy::Proxy m) @@ -362,19 +399,27 @@ {-# INLINABLE twace #-} twace (Pow u) = Pow $ U.twacePow u twace (Dec u) = Dec $ U.twaceDec u -twace (CRT u) = either Pow CRT $ twaceCRT u +twace (CRT u) = either (cycPE . twaceCRTE) (cycPC . twaceCRTC) u twace (Scalar u) = Scalar u twace (Sub (c :: Cyc t l r)) = Sub (twace c :: Cyc t (FGCD l m) r) \\ gcdDivides (Proxy::Proxy l) (Proxy::Proxy m) -- | Return the given element's coefficient vector with respect to -- the (relative) powerful/decoding basis of the cyclotomic --- extension @O_m' / O_m@. +-- extension @O_m' / O_m@. See also 'coeffsPow', 'coeffsDec'. coeffsCyc :: (m `Divides` m', CElt t r) => R.Basis -> Cyc t m' r -> [Cyc t m r] {-# INLINABLE coeffsCyc #-} coeffsCyc R.Pow c' = Pow <$> U.coeffsPow (uncycPow c') coeffsCyc R.Dec c' = Dec <$> U.coeffsDec (uncycDec c') +coeffsPow, coeffsDec :: (m `Divides` m', CElt t r) => Cyc t m' r -> [Cyc t m r] +{-# INLINABLE coeffsPow #-} +{-# INLINABLE coeffsDec #-} +-- | Specialized version of @coeffsCyc@ for powerful basis. +coeffsPow = coeffsCyc R.Pow +-- | Specialized version of @coeffsCyc@ for decoding basis. +coeffsDec = coeffsCyc R.Dec + -- | The relative powerful basis of @O_m' / O_m@. powBasis :: (m `Divides` m', CElt t r) => Tagged m [Cyc t m' r] powBasis = (Pow <$>) <$> U.powBasis @@ -395,7 +440,7 @@ {-# INLINABLE reduce #-} reduce (Pow u) = Pow $ reduce u reduce (Dec u) = Dec $ reduce u - reduce (CRT u) = Pow $ reduce $ toPow u + reduce (CRT u) = Pow $ reduce $ either toPow toPow u reduce (Scalar c) = Scalar $ reduce c reduce (Sub (c :: Cyc t l a)) = Sub (reduce c :: Cyc t l b) @@ -417,40 +462,27 @@ -- | Lift using the powerful basis. liftPow (Pow u) = Pow $ lift u liftPow (Dec u) = Pow $ lift $ toPow u -liftPow (CRT u) = Pow $ lift $ toPow u +liftPow (CRT u) = Pow $ lift $ either toPow toPow u -- optimized for subrings; these are correct for powerful basis but -- not for decoding liftPow (Scalar c) = Scalar $ lift c liftPow (Sub c) = Sub $ liftPow c -- | Lift using the decoding basis. -liftDec (Pow u) = Dec $ lift $ toDec u -liftDec (Dec u) = Dec $ lift u -liftDec (CRT u) = Dec $ lift $ toDec u -liftDec (Scalar c) = Dec $ lift $ toDec $ scalarPow c -- workaround scalarDec -liftDec (Sub c) = liftDec $ embed' c +liftDec c = Dec $ lift $ uncycDec c --- | Unzip for unrestricted types. -unzipCyc :: (Tensor t, Fact m) => Cyc t m (a,b) -> (Cyc t m a, Cyc t m b) +-- | Unzip for a pair base ring. +unzipCyc :: (Tensor t, Fact m, CElt t (a,b), CElt t a, CElt t b) + => Cyc t m (a,b) -> (Cyc t m a, Cyc t m b) {-# INLINABLE unzipCyc #-} -unzipCyc (Pow u) = Pow *** Pow $ U.unzipCyc u -unzipCyc (Dec u) = Dec *** Dec $ U.unzipCyc u -unzipCyc (CRT u) = CRT *** CRT $ U.unzipCyc u +unzipCyc (Pow u) = Pow *** Pow $ U.unzipPow u +unzipCyc (Dec u) = Dec *** Dec $ U.unzipDec u +unzipCyc (CRT u) = either ((cycPE *** cycPE) . unzipCRTE) + ((cycPC *** cycPC) . unzipCRTC) u unzipCyc (Scalar c) = Scalar *** Scalar $ c unzipCyc (Sub c) = Sub *** Sub $ unzipCyc c --- | Type-restricted (and potentially more efficient) unzip. -unzipCElt :: (Tensor t, Fact m, CElt t (a,b), CElt t a, CElt t b) - => Cyc t m (a,b) -> (Cyc t m a, Cyc t m b) -{-# INLINABLE unzipCElt #-} -unzipCElt (Pow u) = Pow *** Pow $ U.unzipUCElt u -unzipCElt (Dec u) = Dec *** Dec $ U.unzipUCElt u -unzipCElt (CRT u) = CRT *** CRT $ U.unzipUCElt u -unzipCElt (Scalar c) = Scalar *** Scalar $ c -unzipCElt (Sub c) = Sub *** Sub $ unzipCElt c - --- generic RescaleCyc instance - +-- | generic instance instance {-# OVERLAPS #-} (Rescale a b, CElt t a, TElt t b) => R.RescaleCyc (Cyc t) a b where @@ -464,7 +496,8 @@ rescaleCyc R.Dec c = Dec $ fmapDec rescale $ uncycDec c {-# INLINABLE rescaleCyc #-} --- specialized instance for product rings: ~2x faster algorithm +-- | specialized instance for product rings of @Zq@s: ~2x faster +-- algorithm instance (Mod a, Field b, Lift a (ModRep a), Reduce (LiftOf a) b, CElt t (a,b), CElt t a, CElt t b, CElt t (LiftOf a)) => R.RescaleCyc (Cyc t) (a,b) b where @@ -475,20 +508,19 @@ rescaleCyc R.Pow (Sub c) = Sub $ R.rescalePow c rescaleCyc bas c = let aval = proxy modulus (Proxy::Proxy a) - (a,b) = unzipCElt c + (a,b) = unzipCyc c z = liftCyc bas a in Scalar (recip (reduce aval)) * (b - reduce z) {-# INLINABLE rescaleCyc #-} - +-- | promoted from base ring instance (Gadget gad zq, Fact m, CElt t zq) => Gadget gad (Cyc t m zq) where gadget = (scalarCyc <$>) <$> gadget - -- specialization fo 'encode', done efficiently - encode s = ((* adviseCRT s) <$>) <$> gadget {-# INLINABLE gadget #-} - {-# INLINABLE encode #-} --- promote Decompose, using the powerful basis + -- CJP: default 'encode' works because mul-by-Scalar is fast + +-- | promoted from base ring, using the powerful basis for best geometry instance (Decompose gad zq, Fact m, CElt t zq, CElt t (DecompOf zq)) => Decompose gad (Cyc t m zq) where @@ -511,12 +543,12 @@ fromZL :: TaggedT s ZipList a -> Tagged s [a] fromZL = coerce --- promote Correct, using the decoding basis +-- | promoted from base ring, using the decoding basis for best geometry instance (Correct gad zq, Fact m, CElt t zq) => Correct gad (Cyc t m zq) where -- sequence: Monad [] and Traversable (UCyc t m D) -- sequenceA: Applicative (UCyc t m D) and Traversable (TaggedT gad []) correct bs = Dec *** (Dec <$>) $ - second sequence $ U.unzipCyc $ (correct . pasteT) <$> + second sequence $ fmap fst &&& fmap snd $ (correct . pasteT) <$> sequenceA (uncycDec <$> peelT bs) {-# INLINABLE correct #-} @@ -530,28 +562,28 @@ -- | Force to powerful-basis representation (for internal use only). toPow' c@(Pow _) = c toPow' (Dec u) = Pow $ toPow u -toPow' (CRT u) = Pow $ toPow u +toPow' (CRT u) = Pow $ either toPow toPow u toPow' (Scalar c) = Pow $ scalarPow c toPow' (Sub c) = toPow' $ embed' c -- | Force to decoding-basis representation (for internal use only). toDec' (Pow u) = Dec $ toDec u toDec' c@(Dec _) = c -toDec' (CRT u) = Dec $ toDec u -toDec' (Scalar c) = Dec $ toDec $ scalarPow c -- workaround scalarDec +toDec' (CRT u) = Dec $ either toDec toDec u +toDec' (Scalar c) = Dec $ toDec $ scalarPow c toDec' (Sub c) = toDec' $ embed' c --- | Force to CRT representation (for internal use only). +-- | Force to a CRT representation (for internal use only). toCRT' (Pow u) = CRT $ toCRT u toCRT' (Dec u) = CRT $ toCRT u toCRT' c@(CRT _) = c toCRT' (Scalar c) = CRT $ scalarCRT c --- CJP: below is the fastest algorithm for when both source and target --- have the same CRTr/CRTe choice. It is not the fastest when the --- choices are different (it will do an unnecessary CRT if input is --- non-CRT), but this is an unusual case. Note: both toCRT' are --- necessary in generaly, because embed' may not preserve CRT --- representation! +-- CJP: the following is the fastest algorithm for when both source +-- and target have the same CRTr/CRTe choice. It is not the fastest +-- when the choices are different (it will do an unnecessary CRT if +-- input is non-CRT), but this is an unusual case. Note: both calls +-- to toCRT' are necessary in general, because embed' may not preserve +-- CRT representation! toCRT' (Sub c) = toCRT' $ embed' $ toCRT' c ---------- Utility instances ---------- @@ -564,9 +596,9 @@ rnf (Scalar u) = rnf u rnf (Sub c) = rnf c -instance (Random r, Tensor t, Fact m, CRTElt t r) => Random (Cyc t m r) where +instance (Random r, Tensor t, Fact m, UCRTElt t r) => Random (Cyc t m r) where random g = let (u,g') = random g - in (either Pow CRT u, g') + in (either Pow (CRT . Right) u, g') {-# INLINABLE random #-} randomR _ = error "randomR non-sensical for Cyc" @@ -575,9 +607,9 @@ arbitrary = Pow <$> arbitrary shrink = shrinkNothing -instance (Show r, Show (CRTExt r), Tensor t, Fact m, TElt t r, TElt t (CRTExt r)) => Show (Cyc t m r) where - show (Scalar c) = "Cyc Scalar: " ++ show c - show (Pow u) = "Cyc: " ++ show u - show (Dec u) = "Cyc: " ++ show u - show (CRT u) = "Cyc: " ++ show u - show (Sub c) = "Cyc Sub: " ++ show c +instance (Fact m, CElt t r, Protoable (UCyc t m D r)) + => Protoable (Cyc t m r) where + type ProtoType (Cyc t m r) = ProtoType (UCyc t m D r) + toProto (Dec uc) = toProto uc + toProto x = toProto $ toDec' x + fromProto x = Dec <$> fromProto x diff --git a/Crypto/Lol/Cyclotomic/Linear.hs b/Crypto/Lol/Cyclotomic/Linear.hs --- a/Crypto/Lol/Cyclotomic/Linear.hs +++ b/Crypto/Lol/Cyclotomic/Linear.hs @@ -1,8 +1,16 @@ -{-# LANGUAGE ConstraintKinds, DataKinds, FlexibleContexts, - GeneralizedNewtypeDeriving, KindSignatures, - MultiParamTypeClasses, NoImplicitPrelude, RoleAnnotations, - ScopedTypeVariables, StandaloneDeriving, TypeFamilies, - TypeOperators, UndecidableInstances #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} -- | Functions from one cyclotomic ring to another that are linear -- over a common subring. @@ -13,7 +21,7 @@ ) where import Crypto.Lol.Cyclotomic.Cyc -import Crypto.Lol.LatticePrelude +import Crypto.Lol.Prelude import Algebra.Additive as Additive (C) @@ -66,6 +74,7 @@ type instance LiftOf (Linear t zp e r s) = Linear t (LiftOf zp) e r s +-- | lifts with respect to powerful basis, for best geometry instance (CElt t zp, CElt t z, z ~ LiftOf zp, Lift zp z, Fact s) => Lift' (Linear t zp e r s) where lift (RD ys) = RD $ liftCyc Pow <$> ys diff --git a/Crypto/Lol/Cyclotomic/RescaleCyc.hs b/Crypto/Lol/Cyclotomic/RescaleCyc.hs --- a/Crypto/Lol/Cyclotomic/RescaleCyc.hs +++ b/Crypto/Lol/Cyclotomic/RescaleCyc.hs @@ -1,15 +1,17 @@ {-# LANGUAGE MultiParamTypeClasses #-} +-- | A class and helper functions for rescaling cycltomic ring elements. + module Crypto.Lol.Cyclotomic.RescaleCyc where import Crypto.Lol.Factored +-- | Represents the basis used to rescale a cyclotomic ring element. data Basis = Pow | Dec -- | Represents cyclotomic rings that are rescalable over their base -- rings. (This is a class because it allows for more efficient -- specialized implementations.) - class RescaleCyc c a b where -- | Rescale in the given basis. rescaleCyc :: Fact m => Basis -> c m a -> c m b diff --git a/Crypto/Lol/Cyclotomic/Tensor.hs b/Crypto/Lol/Cyclotomic/Tensor.hs --- a/Crypto/Lol/Cyclotomic/Tensor.hs +++ b/Crypto/Lol/Cyclotomic/Tensor.hs @@ -1,18 +1,27 @@ -{-# LANGUAGE ConstraintKinds, DataKinds, FlexibleContexts, - NoImplicitPrelude, PolyKinds, RankNTypes, ScopedTypeVariables, - TupleSections, TypeFamilies, TypeOperators, - UndecidableInstances #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} -- | Interface for cyclotomic tensors, and helper functions for tensor -- indexing. module Crypto.Lol.Cyclotomic.Tensor -( Tensor(..), CRTElt +( Tensor(..) -- * Top-level CRT functions , hasCRTFuncs , scalarCRT, mulGCRT, divGCRT, crt, crtInv, twaceCRT, embedCRT +-- * Special vectors/matrices +, Matrix, indexM, gCRTM, gInvCRTM, twCRTs -- * Tensor indexing -, Matrix, indexM, twCRTs , zmsToIndexFact , indexInfo , extIndicesPowDec, extIndicesCRT, extIndicesCoeffs @@ -22,7 +31,7 @@ where import Crypto.Lol.CRTrans -import Crypto.Lol.LatticePrelude as LP hiding (lift, (*>)) +import Crypto.Lol.Prelude as LP hiding (lift, (*>)) import Crypto.Lol.Types.FiniteField import Control.Applicative @@ -31,12 +40,9 @@ import Data.Constraint import Data.Singletons.Prelude hiding ((:-)) import Data.Traversable -import Data.Tuple (swap) -import qualified Data.Vector as V -import qualified Data.Vector.Unboxed as U - --- | Synonym for constraints required for CRT-related functions. -type CRTElt t r = (ZeroTestable r, IntegralDomain r, CRTrans r, TElt t r) +import Data.Tuple (swap) +import qualified Data.Vector as V +import qualified Data.Vector.Unboxed as U -- | 'Tensor' encapsulates all the core linear transformations needed -- for cyclotomic ring arithmetic. @@ -58,8 +64,7 @@ -- inputs for each method is determined by the linear transform it -- implements. -class (TElt t Double, TElt t (Complex Double)) - => Tensor (t :: Factored -> * -> *) where +class (TElt t Double, TElt t (Complex Double)) => Tensor t where -- | Constraints needed by @t@ to hold type @r@. type TElt t r :: Constraint @@ -67,7 +72,7 @@ -- | Properties that hold for any index. Use with '\\'. entailIndexT :: Tagged (t m r) (Fact m :- (Applicative (t m), Traversable (t m))) - + -- | Properties that hold for any (legal) fully-applied tensor. Use -- with '\\'. entailEqT :: Tagged (t m r) @@ -79,19 +84,13 @@ entailRandomT :: Tagged (t m r) ((Random r, Fact m, TElt t r) :- Random (t m r)) entailShowT :: Tagged (t m r) - ((Show r, Fact m, TElt t r) :- (Show (t m r))) + ((Show r, Fact m, TElt t r) :- Show (t m r)) entailModuleT :: Tagged (GF fp d, t m fp) ((GFCtx fp d, Fact m, TElt t fp) :- Module (GF fp d) (t m fp)) -- | Convert a scalar to a tensor in the powerful basis. scalarPow :: (Additive r, Fact m, TElt t r) => r -> t m r - {- CJP: suppressed to do annoyingly complicated algorithm - - -- | Convert a scalar to a tensor in the decoding basis. - scalarDec :: (Additive r, Fact m, TElt t r) => r -> t m r - -} - -- | 'l' converts from decoding-basis representation to -- powerful-basis representation; 'lInv' is its inverse. l, lInv :: (Additive r, Fact m, TElt t r) => t m r -> t m r @@ -110,12 +109,12 @@ -- use this method directly, but instead call the corresponding -- top-level functions: the elements of the tuple correpond to the -- functions 'scalarCRT', 'mulGCRT', 'divGCRT', 'crt', 'crtInv'. - crtFuncs :: (Fact m, CRTElt t r) => - Maybe ( r -> t m r, -- scalarCRT - t m r -> t m r, -- mulGCRT - t m r -> t m r, -- divGCRT - t m r -> t m r, -- crt - t m r -> t m r) -- crtInv + crtFuncs :: (CRTrans mon r, Fact m, TElt t r) => + mon ( r -> t m r, -- scalarCRT + t m r -> t m r, -- mulGCRT + t m r -> t m r, -- divGCRT + t m r -> t m r, -- crt + t m r -> t m r) -- crtInv -- | Sample from the "tweaked" Gaussian error distribution @t*D@ -- in the decoding basis, where @D@ has scaled variance @v@. @@ -143,9 +142,9 @@ -- method directly, but instead call the corresponding top-level -- functions: the elements of the tuple correpond to the functions -- 'twaceCRT', 'embedCRT'. - crtExtFuncs :: (m `Divides` m', CRTElt t r) => - Maybe (t m' r -> t m r, -- twaceCRT - t m r -> t m' r) -- embedCRT + crtExtFuncs :: (CRTrans mon r, m `Divides` m', TElt t r) => + mon (t m' r -> t m r, -- twaceCRT + t m r -> t m' r) -- embedCRT -- | Map a tensor in the powerful\/decoding\/CRT basis, representing -- an @O_m'@ element, to a vector of tensors representing @O_m@ @@ -161,26 +160,30 @@ TElt t fp) => Tagged m [t m' fp] - -- | Potentially optimized version of 'fmap' when the input and - -- output element types satisfy 'TElt'. + -- | Potentially optimized version of 'fmap' for types that satisfy + -- 'TElt'. fmapT :: (Fact m, TElt t a, TElt t b) => (a -> b) -> t m a -> t m b -- | Potentially optimized monadic 'fmap'. fmapTM :: (Monad mon, Fact m, TElt t a, TElt t b) => (a -> mon b) -> t m a -> mon (t m b) - -- | Potentially optimized 'zipWith'. + -- | Potentially optimized zipWith for types that satisfy 'TElt'. zipWithT :: (Fact m, TElt t a, TElt t b, TElt t c) => (a -> b -> c) -> t m a -> t m b -> t m c - -- | Unzip for types that satisfy 'TElt'. - unzipTElt :: (Fact m, TElt t (a,b), TElt t a, TElt t b) - => t m (a,b) -> (t m a, t m b) + -- | Potentially optimized unzip for types that satisfy 'TElt'. + unzipT :: (Fact m, TElt t (a,b), TElt t a, TElt t b) + => t m (a,b) -> (t m a, t m b) + + {- CJP: suppressed, apparently not needed + -- | Unzip for arbitrary types. - unzipT :: (Fact m) => t m (a,b) -> (t m a, t m b) + unzipTUnrestricted :: (Fact m) => t m (a,b) -> (t m a, t m b) + -} -- | Convenience value indicating whether 'crtFuncs' exists. -hasCRTFuncs :: forall t m r . (Tensor t, Fact m, CRTElt t r) - => TaggedT (t m r) Maybe () +hasCRTFuncs :: forall t m mon r . (CRTrans mon r, Tensor t, Fact m, TElt t r) + => TaggedT (t m r) mon () {-# INLINABLE hasCRTFuncs #-} hasCRTFuncs = tagT $ do (_ :: r -> t m r,_,_,_,_) <- crtFuncs @@ -188,13 +191,12 @@ -- | Yield a tensor for a scalar in the CRT basis. (This function is -- simply an appropriate entry from 'crtFuncs'.) -scalarCRT :: (Tensor t, Fact m, CRTElt t r) => Maybe (r -> t m r) +scalarCRT :: (CRTrans mon r, Tensor t, Fact m, TElt t r) => mon (r -> t m r) {-# INLINABLE scalarCRT #-} scalarCRT = (\(f,_,_,_,_) -> f) <$> crtFuncs - mulGCRT, divGCRT, crt, crtInv :: - (Tensor t, Fact m, CRTElt t r) => Maybe (t m r -> t m r) + (CRTrans mon r, Tensor t, Fact m, TElt t r) => mon (t m r -> t m r) {-# INLINABLE mulGCRT #-} {-# INLINABLE divGCRT #-} {-# INLINABLE crt #-} @@ -217,8 +219,8 @@ -- For cyclotomic indices m | m', -- @Tw(x) = (mhat\/m\'hat) * Tr(g\'\/g * x)@. -- (This function is simply an appropriate entry from 'crtExtFuncs'.) -twaceCRT :: forall t r m m' . (Tensor t, m `Divides` m', CRTElt t r) - => Maybe (t m' r -> t m r) +twaceCRT :: forall t m m' mon r . (CRTrans mon r, Tensor t, m `Divides` m', TElt t r) + => mon (t m' r -> t m r) twaceCRT = proxyT hasCRTFuncs (Proxy::Proxy (t m' r)) *> proxyT hasCRTFuncs (Proxy::Proxy (t m r)) *> (fst <$> crtExtFuncs) @@ -226,8 +228,8 @@ -- | Embed a tensor with index @m@ in the CRT basis to a tensor with -- index @m'@ in the CRT basis. -- (This function is simply an appropriate entry from 'crtExtFuncs'.) -embedCRT :: forall t r m m' . (Tensor t, m `Divides` m', CRTElt t r) - => Maybe (t m r -> t m' r) +embedCRT :: forall t m m' mon r . (CRTrans mon r, Tensor t, m `Divides` m', TElt t r) + => mon (t m r -> t m' r) embedCRT = proxyT hasCRTFuncs (Proxy::Proxy (t m' r)) *> proxyT hasCRTFuncs (Proxy::Proxy (t m r)) *> (snd <$> crtExtFuncs) @@ -244,46 +246,89 @@ mat' <- withWitnessT mat spp return $ MKron rest' mat' +-- | For a prime power @p^e@, converts any matrix @M@ for +-- prime @p@ to @1_(p^{e-1}) \otimes M@, where @1@ denotes the all-1s +-- vector. +ppMatrix :: forall pp r mon . (PPow pp, Monad mon, Ring r) + => (forall p . (Prime p) => TaggedT p mon (MatrixC r)) + -> TaggedT pp mon (MatrixC r) +ppMatrix mat = tagT $ case (sing :: SPrimePower pp) of + pp@(SPP (STuple2 sp _)) -> do + (MC h w f) <- withWitnessT mat sp + let d = withWitness valuePPow pp `div` withWitness valuePrime sp + return $ MC (h*d) w (f . (`mod` h)) + -- deeply embedded DSL for Kronecker products of matrices -data MatrixC r = - MC (Int -> Int -> r) -- yields element i,j - Int Int -- dims +data MatrixC r = + MC Int Int -- dims + (Int -> Int -> r) -- yields element i,j -- | A Kronecker product of zero of more matrices over @r@. -data Matrix r = MNil | MKron (Matrix r) (MatrixC r) +data Matrix r = MNil | MKron (Matrix r) (MatrixC r) -- snoc list -- | Extract the @(i,j)@ element of a 'Matrix'. indexM :: Ring r => Matrix r -> Int -> Int -> r indexM MNil 0 0 = LP.one -indexM (MKron m (MC mc r c)) i j = +indexM (MKron m (MC r c mc)) i j = let (iq,ir) = i `divMod` r (jq,jr) = j `divMod` c in indexM m iq jq * mc ir jr +gCRTM, gInvCRTM :: (Fact m, CRTrans mon r) => TaggedT m mon (Matrix r) +-- | A @tot(m)@-by-1 matrix of the CRT coefficients of @g_m@, for @m@th +-- cyclotomic. +gCRTM = fMatrix gCRTPPow +-- | A @tot(m)@-by-1 matrix of the inverse CRT coefficients of @g_m@, for @m@th +-- cyclotomic. +gInvCRTM = fMatrix gInvCRTPPow + -- | The "tweaked" CRT^* matrix: @CRT^* . diag(sigma(g_m))@. -twCRTs :: (Fact m, CRTrans r) => TaggedT m Maybe (Matrix r) +twCRTs :: (Fact m, CRTrans mon r) => TaggedT m mon (Matrix r) twCRTs = fMatrix twCRTsPPow -- | The "tweaked" CRT^* matrix (for prime powers): @CRT^* * diag(sigma(g_p))@. -twCRTsPPow :: (PPow pp, CRTrans r) => TaggedT pp Maybe (MatrixC r) +twCRTsPPow :: (PPow pp, CRTrans mon r) => TaggedT pp mon (MatrixC r) twCRTsPPow = do phi <- pureT totientPPow iToZms <- pureT indexToZmsPPow jToPow <- pureT indexToPowPPow - (wPow, _) <- crtInfoPPow - gEmb <- gEmbPPow + (wPow, _) <- crtInfo + (MC _ _ gCRT) <- gCRTPPow - return $ MC (\j i -> let i' = iToZms i - in wPow (jToPow j * negate i') * gEmb i') phi phi + return $ MC phi phi (\j i -> wPow (jToPow j * negate (iToZms i)) * gCRT i 0) +gCRTPPow, gInvCRTPPow :: (PPow pp, CRTrans mon r) => TaggedT pp mon (MatrixC r) +gCRTPPow = ppMatrix gCRTPrime +gInvCRTPPow = ppMatrix gInvCRTPrime + +gCRTPrime, gInvCRTPrime :: (Prime p, CRTrans mon r) => TaggedT p mon (MatrixC r) + +-- | A @(p-1)@-by-1 matrix of the CRT coefficients of @g_p@, for @p@th +-- cyclotomic. +gCRTPrime = do + p <- pureT valuePrime + (wPow, _) <- crtInfo + return $ MC (p-1) 1 $ if p == 2 then const $ const one + else (\i _ -> one - wPow (i+1)) + +-- | A @(p-1)@-by-1 matrix of the inverse CRT coefficients of @g_p@, +-- for the @p@th cyclotomic. +gInvCRTPrime = do + p <- pureT valuePrime + (wPow, phatinv) <- crtInfo + return $ MC (p-1) 1 $ + if p == 2 then const $ const one + else (\i -> const $ phatinv * + sum [fromIntegral j * wPow ((i+1)*(p-1-j)) | j <- [1..p-1]]) + -- Reindexing functions -- | Base-p digit reversal; input and output are in @[p^e]@. digitRev :: PP -> Int -> Int digitRev (_,0) 0 = 0 -- CJP: use accumulator to avoid multiple exponentiations? -digitRev (p,e) j +digitRev (p,e) j | e >= 1 = let (q,r) = j `divMod` p in r * (p^(e-1)) + digitRev (p,e-1) q @@ -306,13 +351,13 @@ -- element i in @Z_{p^e}^*@. indexToZms :: PP -> Int -> Int indexToZms (p,_) i = let (i1,i0) = i `divMod` (p-1) - in p*i1 + i0 + 1 + in p*i1 + i0 + 1 -- | Convert a Z_m^* index to a linear tensor index. zmsToIndex :: [PP] -> Int -> Int zmsToIndex [] _ = 0 zmsToIndex (pp:rest) i = zmsToIndexPP pp (i `mod` valuePP pp) - + (totientPP pp) * zmsToIndex rest i + + totientPP pp * zmsToIndex rest i -- | Inverse of 'indexToZms'. zmsToIndexPP :: PP -> Int -> Int diff --git a/Crypto/Lol/Cyclotomic/Tensor/CTensor.hs b/Crypto/Lol/Cyclotomic/Tensor/CTensor.hs --- a/Crypto/Lol/Cyclotomic/Tensor/CTensor.hs +++ b/Crypto/Lol/Cyclotomic/Tensor/CTensor.hs @@ -1,12 +1,12 @@ -{-# LANGUAGE ConstraintKinds, DataKinds, GADTs, - FlexibleContexts, FlexibleInstances, TypeOperators, PolyKinds, - GeneralizedNewtypeDeriving, InstanceSigs, RoleAnnotations, - MultiParamTypeClasses, NoImplicitPrelude, StandaloneDeriving, - ScopedTypeVariables, TupleSections, TypeFamilies, RankNTypes, - TypeSynonymInstances, UndecidableInstances, - RebindableSyntax #-} +{-# LANGUAGE ConstraintKinds, DataKinds, FlexibleContexts, + FlexibleInstances, GADTs, GeneralizedNewtypeDeriving, + InstanceSigs, MultiParamTypeClasses, NoImplicitPrelude, + PolyKinds, RankNTypes, RebindableSyntax, RoleAnnotations, + ScopedTypeVariables, StandaloneDeriving, TupleSections, + TypeFamilies, TypeOperators, TypeSynonymInstances, + UndecidableInstances #-} --- | Wrapper for a C implementation of the 'Tensor' interface. +-- | Wrapper for a C++ implementation of the 'Tensor' interface. module Crypto.Lol.Cyclotomic.Tensor.CTensor ( CT ) where @@ -15,48 +15,57 @@ import Algebra.Module as Module (C) import Algebra.ZeroTestable as ZeroTestable (C) -import Control.Applicative hiding ((*>)) -import Control.Arrow ((***)) +import Control.Applicative hiding ((*>)) +import Control.Arrow ((***)) import Control.DeepSeq -import Control.Monad (liftM) -import Control.Monad.Identity (Identity(..), runIdentity) +import Control.Monad.Except +import Control.Monad.Identity (Identity (..), runIdentity) import Control.Monad.Random -import Control.Monad.Trans (lift) +import Control.Monad.Trans as T (lift) import Data.Coerce -import Data.Constraint hiding ((***)) -import Data.Foldable as F +import Data.Constraint hiding ((***)) import Data.Int import Data.Maybe -import Data.Traversable as T -import Data.Vector.Generic as V (zip, unzip, fromList, toList) -import Data.Vector.Storable as SV (Vector, (!), replicate, replicateM, thaw, convert, foldl', - unsafeSlice, mapM, fromList, toList, - generate, foldl1', - unsafeWith, zipWith, map, length, unsafeFreeze, thaw) -import Data.Vector.Storable.Internal (getPtr) -import Data.Vector.Storable.Mutable as SM hiding (replicate) +import Data.Traversable as T +import Data.Vector.Generic as V (fromList, toList, unzip) +import Data.Vector.Storable as SV (Vector, convert, foldl', + foldl1', fromList, generate, + length, map, mapM, replicate, + replicateM, thaw, thaw, toList, + unsafeFreeze, unsafeSlice, + unsafeWith, zipWith, (!)) +import Data.Vector.Storable.Mutable as SM hiding (replicate) import Foreign.Marshal.Utils (with) import Foreign.Ptr -import Foreign.Storable (Storable (..)) -import Test.QuickCheck hiding (generate) +import Test.QuickCheck hiding (generate) import Crypto.Lol.CRTrans import Crypto.Lol.Cyclotomic.Tensor import Crypto.Lol.Cyclotomic.Tensor.CTensor.Backend import Crypto.Lol.Cyclotomic.Tensor.CTensor.Extension import Crypto.Lol.GaussRandom -import Crypto.Lol.LatticePrelude as LP hiding (replicate, unzip, zip, lift) +import Crypto.Lol.Prelude as LP hiding + (replicate, + unzip, zip) import Crypto.Lol.Reflects import Crypto.Lol.Types.FiniteField import Crypto.Lol.Types.IZipVector +import Crypto.Lol.Types.Proto +import Crypto.Lol.Types.RRq import Crypto.Lol.Types.ZqBasic +import Crypto.Proto.RLWE.Kq +import Crypto.Proto.RLWE.Rq + +import Data.Foldable as F +import Data.Sequence as S (fromList) + import System.IO.Unsafe (unsafePerformIO) -- | Newtype wrapper around a Vector. -newtype CT' (m :: Factored) r = CT' { unCT :: Vector r } +newtype CT' (m :: Factored) r = CT' { unCT :: Vector r } deriving (Show, Eq, NFData) -- the first argument, though phantom, affects representation @@ -65,19 +74,65 @@ -- GADT wrapper that distinguishes between Unbox and unrestricted -- element types --- | An implementation of 'Tensor' backed by C code. -data CT (m :: Factored) r where +-- | An implementation of 'Tensor' backed by C++ code. +data CT (m :: Factored) r where CT :: Storable r => CT' m r -> CT m r ZV :: IZipVector m r -> CT m r +deriving instance Show r => Show (CT m r) + instance Eq r => Eq (CT m r) where (ZV x) == (ZV y) = x == y (CT x) == (CT y) = x == y x@(CT _) == y = x == toCT y y == x@(CT _) = x == toCT y -deriving instance Show r => Show (CT m r) +instance (Fact m, Reflects q Int64) => Protoable (CT m (ZqBasic q Int64)) where + type ProtoType (CT m (ZqBasic q Int64)) = Rq + toProto (CT (CT' xs)) = + let m = fromIntegral $ proxy valueFact (Proxy::Proxy m) + q = proxy value (Proxy::Proxy q) :: Int64 + in Rq m (fromIntegral q) $ S.fromList $ SV.toList $ SV.map LP.lift xs + toProto x@(ZV _) = toProto $ toCT x + + fromProto (Rq m' q' xs) = + let m = proxy valueFact (Proxy::Proxy m) :: Int + q = proxy value (Proxy::Proxy q) :: Int64 + n = proxy totientFact (Proxy::Proxy m) + xs' = SV.fromList $ F.toList xs + len = F.length xs + in if m == fromIntegral m' && len == n && fromIntegral q == q' + then return $ CT $ CT' $ SV.map reduce xs' + else throwError $ + "An error occurred while reading the proto type for CT.\n\ + \Expected m=" ++ show m ++ ", got " ++ show m' ++ "\n\ + \Expected n=" ++ show n ++ ", got " ++ show len ++ "\n\ + \Expected q=" ++ show q ++ ", got " ++ show q' ++ "." + +instance (Fact m, Reflects q Double) => Protoable (CT m (RRq q Double)) where + type ProtoType (CT m (RRq q Double)) = Kq + + toProto (CT (CT' xs)) = + let m = fromIntegral $ proxy valueFact (Proxy::Proxy m) + q = proxy value (Proxy::Proxy q) :: Double + in Kq m q $ S.fromList $ SV.toList $ SV.map LP.lift xs + toProto x@(ZV _) = toProto $ toCT x + + fromProto (Kq m' q' xs) = + let m = proxy valueFact (Proxy::Proxy m) :: Int + q = proxy value (Proxy::Proxy q) :: Double + n = proxy totientFact (Proxy::Proxy m) + xs' = SV.fromList $ F.toList xs + len = F.length xs + in if m == fromIntegral m' && len == n && q == q' + then return $ CT $ CT' $ SV.map reduce xs' + else throwError $ + "An error occurred while reading the proto type for CT.\n\ + \Expected m=" ++ show m ++ ", got " ++ show m' ++ "\n\ + \Expected n=" ++ show n ++ ", got " ++ show len ++ "\n\ + \Expected q=" ++ show (round q :: Int64) ++ ", got " ++ show q' ++ "." + toCT :: (Storable r) => CT m r -> CT m r toCT v@(CT _) = v toCT (ZV v) = CT $ zvToCT' v @@ -113,12 +168,11 @@ -- CJP: Additive, Ring are not necessary when we use zipWithT -- EAC: This has performance implications for the CT backend, --- which used a C function for zipWith (*) - +-- which used a (very fast) C function for (*) and (+) instance (Additive r, Storable r, Fact m, Dispatch r) => Additive.C (CT m r) where - (CT a@(CT' _)) + (CT b@(CT' _)) = CT $ (untag $ cZipDispatch dadd) a b - a + b = (toCT a) + (toCT b) + (CT (CT' a)) + (CT (CT' b)) = CT $ CT' $ SV.zipWith (+) a b + a + b = toCT a + toCT b negate (CT (CT' a)) = CT $ CT' $ SV.map negate a -- EAC: This probably should be converted to C code negate a = negate $ toCT a @@ -134,7 +188,7 @@ instance (ZeroTestable r, Storable r, Fact m) => ZeroTestable.C (CT m r) where - --{-# INLINABLE isZero #-} + --{-# INLINABLE isZero #-} isZero (CT (CT' a)) = SV.foldl' (\ b x -> b && isZero x) True a isZero (ZV v) = isZero v @@ -191,11 +245,11 @@ divGDec = wrapM $ Just . untag (basicDispatch dginvdec) crtFuncs = (,,,,) <$> - Just (CT . repl) <*> - (wrap <$> untag (cZipDispatch dmul) <$> untagT gCoeffsCRT) <*> - (wrap <$> untag (cZipDispatch dmul) <$> untagT gInvCoeffsCRT) <*> + return (CT . repl) <*> + (wrap . untag (cZipDispatch dmul) <$> gCRT) <*> + (wrap . untag (cZipDispatch dmul) <$> gInvCRT) <*> (wrap <$> untagT ctCRT) <*> - (wrap <$> untagT ctCRTInv) + (wrap <$> untagT ctCRTInv) twacePowDec = wrap $ runIdentity $ coerceTw twacePowDec' embedPow = wrap $ runIdentity $ coerceEm embedPow' @@ -226,11 +280,8 @@ zipWithT f (CT (CT' v1)) (CT (CT' v2)) = CT $ CT' $ SV.zipWith f v1 v2 zipWithT f v1 v2 = zipWithT f (toCT v1) (toCT v2) - unzipTElt (CT (CT' v)) = (CT . CT') *** (CT . CT') $ unzip v - unzipTElt v = unzipTElt $ toCT v - - unzipT v@(CT _) = unzipT $ toZV v - unzipT (ZV v) = ZV *** ZV $ unzipIZV v + unzipT (CT (CT' v)) = (CT . CT') *** (CT . CT') $ unzip v + unzipT v = unzipT $ toCT v {-# INLINABLE entailIndexT #-} {-# INLINABLE entailEqT #-} @@ -258,7 +309,6 @@ {-# INLINABLE fmapT #-} {-# INLINABLE fmapTM #-} {-# INLINABLE zipWithT #-} - {-# INLINABLE unzipTElt #-} {-# INLINABLE unzipT #-} @@ -270,13 +320,13 @@ -- | Useful coersion for defining @coeffs@ in the @Tensor@ -- interface. Using 'coerce' alone is insufficient for type inference. -coerceCoeffs :: (Fact m, Fact m') +coerceCoeffs :: (Fact m, Fact m') => Tagged '(m,m') (Vector r -> [Vector r]) -> CT' m' r -> [CT' m r] coerceCoeffs = coerce -- | Useful coersion for defining @powBasisPow@ and @crtSetDec@ in the @Tensor@ -- interface. Using 'coerce' alone is insufficient for type inference. -coerceBasis :: +coerceBasis :: (Fact m, Fact m') => Tagged '(m,m') [Vector r] -> Tagged m [CT' m' r] coerceBasis = coerce @@ -284,11 +334,12 @@ mulGPow' :: (TElt CT r, Fact m, Additive r) => CT' m r -> CT' m r mulGPow' = untag $ basicDispatch dmulgpow -divGPow' :: forall m r . (TElt CT r, Fact m, IntegralDomain r, ZeroTestable r) => CT' m r -> Maybe (CT' m r) +divGPow' :: (TElt CT r, Fact m, IntegralDomain r, ZeroTestable r) + => CT' m r -> Maybe (CT' m r) divGPow' = untag $ checkDiv $ basicDispatch dginvpow -withBasicArgs :: forall m r . (Fact m, Storable r) - => (Ptr r -> Int64 -> Ptr CPP -> Int16 -> IO ()) +withBasicArgs :: forall m r . (Fact m, Storable r) + => (Ptr r -> Int64 -> Ptr CPP -> Int16 -> IO ()) -> CT' m r -> IO (CT' m r) withBasicArgs f = let factors = proxy (marshalFactors <$> ppsFact) (Proxy::Proxy m) @@ -301,43 +352,37 @@ f pout totm pfac numFacts)) CT' <$> unsafeFreeze yout -basicDispatch :: forall m r . - (Storable r, Fact m, Additive r) - => (Ptr r -> Int64 -> Ptr CPP -> Int16 -> IO ()) - -> Tagged m (CT' m r -> CT' m r) +basicDispatch :: (Storable r, Fact m, Additive r) + => (Ptr r -> Int64 -> Ptr CPP -> Int16 -> IO ()) + -> Tagged m (CT' m r -> CT' m r) basicDispatch f = return $ unsafePerformIO . withBasicArgs f -gSqNormDec' :: forall m r . - (Storable r, Fact m, Additive r, Dispatch r) - => Tagged m (CT' m r -> r) +gSqNormDec' :: (Storable r, Fact m, Additive r, Dispatch r) + => Tagged m (CT' m r -> r) gSqNormDec' = return $ (!0) . unCT . unsafePerformIO . withBasicArgs dnorm -ctCRT :: forall m r . (Storable r, CRTrans r, Dispatch r, - Fact m) - => TaggedT m Maybe (CT' m r -> CT' m r) -ctCRT = do -- in TaggedT m Maybe +ctCRT :: (Storable r, CRTrans mon r, Dispatch r, Fact m) + => TaggedT m mon (CT' m r -> CT' m r) +ctCRT = do ru' <- ru - return $ \x -> unsafePerformIO $ + return $ \x -> unsafePerformIO $ withPtrArray ru' (flip withBasicArgs x . dcrt) -- CTensor CRT^(-1) functions take inverse rus -ctCRTInv :: (Storable r, CRTrans r, Dispatch r, - Fact m) - => TaggedT m Maybe (CT' m r -> CT' m r) -ctCRTInv = do -- in Maybe - mhatInv <- snd <$> crtInfoFact +ctCRTInv :: (Storable r, CRTrans mon r, Dispatch r, Fact m) + => TaggedT m mon (CT' m r -> CT' m r) +ctCRTInv = do + mhatInv <- snd <$> crtInfo ruinv' <- ruInv - return $ \x -> unsafePerformIO $ + return $ \x -> unsafePerformIO $ withPtrArray ruinv' (\ruptr -> with mhatInv (flip withBasicArgs x . dcrtinv ruptr)) -checkDiv :: forall m r . - (IntegralDomain r, Storable r, ZeroTestable r, - Fact m) +checkDiv :: (Storable r, IntegralDomain r, ZeroTestable r, Fact m) => Tagged m (CT' m r -> CT' m r) -> Tagged m (CT' m r -> Maybe (CT' m r)) checkDiv f = do f' <- f oddRad' <- fromIntegral <$> oddRadicalFact - return $ \x -> + return $ \x -> let (CT' y) = f' x in CT' <$> SV.mapM (`divIfDivis` oddRad') y @@ -367,8 +412,8 @@ totm <- pureT totientFact m <- pureT valueFact rad <- pureT radicalFact - yin <- lift $ realGaussians (var * fromIntegral (m `div` rad)) totm - return $ unsafePerformIO $ + yin <- T.lift $ realGaussians (var * fromIntegral (m `div` rad)) totm + return $ unsafePerformIO $ withPtrArray ruinv' (\ruptr -> withBasicArgs (dgaussdec ruptr) (CT' yin)) instance (Arbitrary r, Fact m, Storable r) => Arbitrary (CT' m r) where @@ -398,25 +443,22 @@ repl = let n = proxy totientFact (Proxy::Proxy m) in coerce . SV.replicate n -replM :: forall m r mon . (Fact m, Storable r, Monad mon) +replM :: forall m r mon . (Fact m, Storable r, Monad mon) => mon r -> mon (CT' m r) replM = let n = proxy totientFact (Proxy::Proxy m) in fmap coerce . SV.replicateM n ---{-# INLINE scalarPow' #-} scalarPow' :: forall m r . (Fact m, Additive r, Storable r) => r -> CT' m r -- constant-term coefficient is first entry wrt powerful basis -scalarPow' = +scalarPow' = let n = proxy totientFact (Proxy::Proxy m) in \r -> CT' $ generate n (\i -> if i == 0 then r else zero) -ru, ruInv :: forall r m . - (CRTrans r, Fact m, Storable r) - => TaggedT m Maybe [Vector r] ---{-# INLINE ru #-} +ru, ruInv :: (CRTrans mon r, Fact m, Storable r) + => TaggedT m mon [Vector r] ru = do mval <- pureT valueFact - wPow <- fst <$> crtInfoFact + wPow <- fst <$> crtInfo LP.map (\(p,e) -> do let pp = p^e @@ -424,10 +466,9 @@ generate pp (wPow . (*pow))) <$> pureT ppsFact ---{-# INLINE ruInv #-} ruInv = do mval <- pureT valueFact - wPow <- fst <$> crtInfoFact + wPow <- fst <$> crtInfo LP.map (\(p,e) -> do let pp = p^e @@ -435,33 +476,29 @@ generate pp (\i -> wPow $ -i*pow)) <$> pureT ppsFact -gCoeffsCRT, gInvCoeffsCRT :: (TElt CT r, CRTrans r, Fact m, ZeroTestable r, IntegralDomain r) - => TaggedT m Maybe (CT' m r) -gCoeffsCRT = ctCRT <*> return (mulGPow' $ scalarPow' LP.one) --- It's necessary to call 'fromJust' here: otherwise --- sequencing functions in 'crtFuncs' relies on 'divGPow' having an --- implementation in C, which is not true for all types which have a C --- implementation of, e.g. 'crt'. In particular, 'Complex Double' has C support --- for 'crt', but not for 'divGPow'. --- This really breaks the contract of Tensor, so it's probably a bad idea. --- Someone can get the "crt" and can even pull the function "divGCRT" from Tensor, --- but it will fail when they try to apply it. --- As an implementation note if I ever do fix this: the division by rad(m) can be --- tricky for Double/Complex Doubles, so be careful! This is why we have a custom --- Complex wrapper around NP.Complex. -gInvCoeffsCRT = ($ fromJust $ divGPow' $ scalarPow' LP.one) <$> ctCRT +wrapVector :: forall mon m r . (Monad mon, Fact m, Ring r, Storable r) + => TaggedT m mon (Matrix r) -> mon (CT' m r) +wrapVector v = do + vmat <- proxyT v (Proxy::Proxy m) + let n = proxy totientFact (Proxy::Proxy m) + return $ CT' $ generate n (flip (indexM vmat) 0) --- we can't put this in Extension with the rest of the twace/embed fucntions because it needs access to --- the C backend -twaceCRT' :: forall m m' r . - (TElt CT r, CRTrans r, m `Divides` m', ZeroTestable r, IntegralDomain r) - => TaggedT '(m, m') Maybe (Vector r -> Vector r) -twaceCRT' = tagT $ do -- Maybe monad - (CT' g') <- proxyT gCoeffsCRT (Proxy::Proxy m') - (CT' gInv) <- proxyT gInvCoeffsCRT (Proxy::Proxy m) +gCRT, gInvCRT :: (Storable r, CRTrans mon r, Fact m) + => mon (CT' m r) +gCRT = wrapVector gCRTM +gInvCRT = wrapVector gInvCRTM + +-- we can't put this in Extension with the rest of the twace/embed +-- functions because it needs access to the C backend +twaceCRT' :: forall mon m m' r . + (TElt CT r, CRTrans mon r, m `Divides` m') + => TaggedT '(m, m') mon (Vector r -> Vector r) +twaceCRT' = tagT $ do + (CT' g') :: CT' m' r <- gCRT + (CT' gInv) :: CT' m r <- gInvCRT embed <- proxyT embedCRT' (Proxy::Proxy '(m,m')) indices <- pure $ proxy extIndicesCRT (Proxy::Proxy '(m,m')) - (_, m'hatinv) <- proxyT crtInfoFact (Proxy::Proxy m') + (_, m'hatinv) <- proxyT crtInfo (Proxy::Proxy m') let phi = proxy totientFact (Proxy::Proxy m) phi' = proxy totientFact (Proxy::Proxy m') mhat = fromIntegral $ proxy valueHatFact (Proxy::Proxy m) diff --git a/Crypto/Lol/Cyclotomic/Tensor/CTensor/Backend.hs b/Crypto/Lol/Cyclotomic/Tensor/CTensor/Backend.hs --- a/Crypto/Lol/Cyclotomic/Tensor/CTensor/Backend.hs +++ b/Crypto/Lol/Cyclotomic/Tensor/CTensor/Backend.hs @@ -1,51 +1,51 @@ -{-# LANGUAGE ConstraintKinds, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, - PolyKinds, ScopedTypeVariables, TypeFamilies, UndecidableInstances #-} +{-# LANGUAGE ConstraintKinds, FlexibleContexts, FlexibleInstances, + MultiParamTypeClasses, PolyKinds, ScopedTypeVariables, + TypeFamilies, UndecidableInstances #-} +-- | This module contains the functions to transform Haskell types into their +-- C counterpart, and to transform polymorphic Haskell functions into C funtion +-- calls in a type-safe way. + module Crypto.Lol.Cyclotomic.Tensor.CTensor.Backend -(Dispatch -,dcrt -,dcrtinv -,dgaussdec -,dl -,dlinv -,dnorm -,dmulgpow -,dmulgdec -,dginvpow -,dginvdec -,dadd -,dmul -,marshalFactors -,CPP -,withArray -,withPtrArray +( Dispatch +, dcrt, dcrtinv +, dgaussdec +, dl, dlinv +, dnorm +, dmulgpow, dmulgdec +, dginvpow, dginvdec +, dmul +, marshalFactors +, CPP +, withArray, withPtrArray ) where import Control.Applicative -import Control.Monad -import Crypto.Lol.LatticePrelude as LP (Complex, Proxy(..), proxy, (++), map, mapM_, PP, Tagged, tag) +import Crypto.Lol.Prelude as LP (Complex, PP, Proxy (..), Tagged, + map, mapM_, proxy, tag, (++)) import Crypto.Lol.Reflects +import Crypto.Lol.Types.RRq import Crypto.Lol.Types.ZqBasic import Data.Int -import Data.Vector.Storable as SV (Vector, (!), replicate, replicateM, thaw, convert, foldl', - unsafeToForeignPtr0, unsafeSlice, mapM, fromList, - generate, foldl1', - unsafeWith, zipWith, map, length, unsafeFreeze, thaw) +import Data.Vector.Storable as SV (Vector, fromList, + unsafeToForeignPtr0) import Data.Vector.Storable.Internal (getPtr) -import Foreign.ForeignPtr (touchForeignPtr) -import Foreign.Marshal.Array (withArray) -import Foreign.Marshal.Utils (with) -import Foreign.Ptr (plusPtr, castPtr, Ptr) +import Foreign.ForeignPtr (touchForeignPtr) +import Foreign.Marshal.Array (withArray) +import Foreign.Marshal.Utils (with) +import Foreign.Ptr (Ptr, castPtr, plusPtr) import Foreign.Storable (Storable (..)) import qualified Foreign.Storable.Record as Store +-- | Convert a list of prime powers to a suitable C representation. marshalFactors :: [PP] -> Vector CPP marshalFactors = SV.fromList . LP.map (\(p,e) -> CPP (fromIntegral p) (fromIntegral e)) -- http://stackoverflow.com/questions/6517387/vector-vector-foo-ptr-ptr-foo-io-a-io-a +-- | Evaluates a C function that takes a @a** ptr@ on a list of Vectors. withPtrArray :: (Storable a) => [Vector a] -> (Ptr (Ptr a) -> IO b) -> IO b withPtrArray v f = do let vs = LP.map SV.unsafeToForeignPtr0 v @@ -54,6 +54,7 @@ LP.mapM_ (\(fp,_) -> touchForeignPtr fp) vs return res +-- | C representation of a prime power. data CPP = CPP {p' :: !Int32, e' :: !Int16} -- stolen from http://hackage.haskell.org/packages/archive/numeric-prelude/0.4.0.3/doc/html/src/Number-Complex.html#T -- the NumericPrelude Storable instance for complex numbers @@ -73,11 +74,11 @@ show (CPP p e) = "(" LP.++ show p LP.++ "," LP.++ show e LP.++ ")" instance (Storable a, Storable b, - CTypeOf a ~ CTypeOf b) - -- enforces right associativity and that each type of + CTypeOf a ~ CTypeOf b) + -- enforces right associativity and that each type of -- the tuple has the same C repr, so using an array repr is safe => Storable (a,b) where - sizeOf _ = (sizeOf (undefined :: a)) + (sizeOf (undefined :: b)) + sizeOf _ = sizeOf (undefined :: a) + sizeOf (undefined :: b) alignment _ = max (alignment (undefined :: a)) (alignment (undefined :: b)) peek p = do a <- peek (castPtr p :: Ptr a) @@ -95,6 +96,7 @@ data ComplexD data DoubleD data Int64D +data RRqD type family CTypeOf x where CTypeOf (a,b) = CTypeOf a @@ -102,6 +104,7 @@ CTypeOf Double = DoubleD CTypeOf Int64 = Int64D CTypeOf (Complex Double) = ComplexD + CTypeOf (RRq (q :: k) Double) = RRqD -- returns the modulus as a nested list of moduli class (Tuple a) => ZqTuple a where @@ -112,9 +115,13 @@ type ModPairs (ZqBasic q Int64) = Int64 getModuli = tag $ proxy value (Proxy::Proxy q) +instance (Reflects q r, RealFrac r) => ZqTuple (RRq q r) where + type ModPairs (RRq q r) = Int64 + getModuli = tag $ round (proxy value (Proxy::Proxy q) :: r) + instance (ZqTuple a, ZqTuple b) => ZqTuple (a, b) where type ModPairs (a,b) = (ModPairs a, ModPairs b) - getModuli = + getModuli = let as = proxy getModuli (Proxy::Proxy a) bs = proxy getModuli (Proxy :: Proxy b) in tag (as,bs) @@ -127,31 +134,53 @@ numComponents = tag 1 instance (Tuple a, Tuple b) => Tuple (a,b) where - numComponents = tag $ (proxy numComponents (Proxy::Proxy a)) + (proxy numComponents (Proxy::Proxy b)) + numComponents = tag $ proxy numComponents (Proxy::Proxy a) + proxy numComponents (Proxy::Proxy b) +-- | Single-argument synonym for @Dispatch'@. type Dispatch r = (Dispatch' (CTypeOf r) r) -- | Class to safely match Haskell types with the appropriate C function. class (repr ~ CTypeOf r) => Dispatch' repr r where + -- | Equivalent to 'Tensor's @crt@. dcrt :: Ptr (Ptr r) -> Ptr r -> Int64 -> Ptr CPP -> Int16 -> IO () + -- | Equivalent to 'Tensor's @crtInv@. dcrtinv :: Ptr (Ptr r) -> Ptr r -> Ptr r -> Int64 -> Ptr CPP -> Int16 -> IO () + -- | Equivalent to 'Tensor's @tGaussianDec@. dgaussdec :: Ptr (Ptr (Complex r)) -> Ptr r -> Int64 -> Ptr CPP -> Int16 -> IO () - + -- | Equivalent to 'Tensor's @l@. dl :: Ptr r -> Int64 -> Ptr CPP -> Int16 -> IO () + -- | Equivalent to 'Tensor's @lInv@. dlinv :: Ptr r -> Int64 -> Ptr CPP -> Int16 -> IO () + -- | Equivalent to 'Tensor's @gSqNormDec@. dnorm :: Ptr r -> Int64 -> Ptr CPP -> Int16 -> IO () + -- | Equivalent to 'Tensor's @mulGPow@. dmulgpow :: Ptr r -> Int64 -> Ptr CPP -> Int16 -> IO () + -- | Equivalent to 'Tensor's @mulGDec@. dmulgdec :: Ptr r -> Int64 -> Ptr CPP -> Int16 -> IO () + -- | Equivalent to 'Tensor's @divGPow@. dginvpow :: Ptr r -> Int64 -> Ptr CPP -> Int16 -> IO () + -- | Equivalent to 'Tensor's @divGDec@. dginvdec :: Ptr r -> Int64 -> Ptr CPP -> Int16 -> IO () - - dadd :: Ptr r -> Ptr r -> Int64 -> IO () + -- | Equivalent to @zipWith (*)@ dmul :: Ptr r -> Ptr r -> Int64 -> IO () -instance (ZqTuple r, Storable (ModPairs r), - CTypeOf r ~ ZqB64D) +instance (ZqTuple r, Storable (ModPairs r), CTypeOf r ~ RRqD) + => Dispatch' RRqD r where + dcrt = error "cannot call CT CRT on type RRq" + dcrtinv = error "cannot call CT CRTInv on type RRq" + dl = error "cannot call CT L on type RRq (though you probably should be able to)" + dlinv = error "cannot call CT LInv on type RRq (though you probably should be able to)" + dnorm = error "cannto call CT normSq on type RRq" + dmulgpow = error "cannot call CT mulGPow on type RRq" + dmulgdec = error "cannot call CT mulGDec on type RRq" + dginvpow = error "cannot call CT divGPow on type RRq" + dginvdec = error "cannot call CT divGDec on type RRq" + dmul = error "cannot call CT mul on type RRq" + dgaussdec = error "cannot call CT gaussianDec on type RRq" + +instance (ZqTuple r, Storable (ModPairs r), CTypeOf r ~ ZqB64D) => Dispatch' ZqB64D r where - dcrt ruptr pout totm pfac numFacts = + dcrt ruptr pout totm pfac numFacts = let qs = proxy getModuli (Proxy::Proxy r) numPairs = proxy numComponents (Proxy::Proxy r) in with qs $ \qsptr -> @@ -161,12 +190,12 @@ numPairs = proxy numComponents (Proxy::Proxy r) in with qs $ \qsptr -> tensorCRTInvRq numPairs (castPtr pout) totm pfac numFacts (castPtr ruptr) (castPtr minv) (castPtr qsptr) - dl pout totm pfac numFacts = + dl pout totm pfac numFacts = let qs = proxy getModuli (Proxy::Proxy r) numPairs = proxy numComponents (Proxy::Proxy r) in with qs $ \qsptr -> tensorLRq numPairs (castPtr pout) totm pfac numFacts (castPtr qsptr) - dlinv pout totm pfac numFacts = + dlinv pout totm pfac numFacts = let qs = proxy getModuli (Proxy::Proxy r) numPairs = proxy numComponents (Proxy::Proxy r) in with qs $ \qsptr -> @@ -192,12 +221,7 @@ numPairs = proxy numComponents (Proxy::Proxy r) in with qs $ \qsptr -> tensorGInvDecRq numPairs (castPtr pout) totm pfac numFacts (castPtr qsptr) - dadd aout bout totm = - let qs = proxy getModuli (Proxy::Proxy r) - numPairs = proxy numComponents (Proxy::Proxy r) - in with qs $ \qsptr -> - addRq numPairs (castPtr aout) (castPtr bout) totm (castPtr qsptr) - dmul aout bout totm = + dmul aout bout totm = let qs = proxy getModuli (Proxy::Proxy r) numPairs = proxy numComponents (Proxy::Proxy r) in with qs $ \qsptr -> @@ -205,64 +229,58 @@ dgaussdec = error "cannot call CT gaussianDec on type ZqBasic" instance (Tuple r, CTypeOf r ~ ComplexD) => Dispatch' ComplexD r where - dcrt ruptr pout totm pfac numFacts = + dcrt ruptr pout totm pfac numFacts = tensorCRTC (proxy numComponents (Proxy::Proxy r)) (castPtr pout) totm pfac numFacts (castPtr ruptr) - dcrtinv ruptr minv pout totm pfac numFacts = + dcrtinv ruptr minv pout totm pfac numFacts = tensorCRTInvC (proxy numComponents (Proxy::Proxy r)) (castPtr pout) totm pfac numFacts (castPtr ruptr) (castPtr minv) - dl pout = + dl pout = tensorLC (proxy numComponents (Proxy::Proxy r)) (castPtr pout) - dlinv pout = + dlinv pout = tensorLInvC (proxy numComponents (Proxy::Proxy r)) (castPtr pout) dnorm = error "cannot call CT normSq on type Complex Double" - dmulgpow pout = + dmulgpow pout = tensorGPowC (proxy numComponents (Proxy::Proxy r)) (castPtr pout) dmulgdec = error "cannot call CT mulGDec on type Complex Double" - dginvpow pout = + dginvpow pout = tensorGInvPowC (proxy numComponents (Proxy::Proxy r)) (castPtr pout) dginvdec = error "cannot call CT divGDec on type Complex Double" - dadd aout bout = - addC (proxy numComponents (Proxy::Proxy r)) (castPtr aout) (castPtr bout) - dmul aout bout = + dmul aout bout = mulC (proxy numComponents (Proxy::Proxy r)) (castPtr aout) (castPtr bout) dgaussdec = error "cannot call CT gaussianDec on type Comple Double" instance (Tuple r, CTypeOf r ~ DoubleD) => Dispatch' DoubleD r where dcrt = error "cannot call CT Crt on type Double" dcrtinv = error "cannot call CT CrtInv on type Double" - dl pout = + dl pout = tensorLDouble (proxy numComponents (Proxy::Proxy r)) (castPtr pout) - dlinv pout = + dlinv pout = tensorLInvDouble (proxy numComponents (Proxy::Proxy r)) (castPtr pout) - dnorm = error "cannot call CT normSq on type Double" + dnorm pout = tensorNormSqD (proxy numComponents (Proxy::Proxy r)) (castPtr pout) dmulgpow = error "cannot call CT mulGPow on type Double" dmulgdec = error "cannot call CT mulGDec on type Double" dginvpow = error "cannot call CT divGPow on type Double" dginvdec = error "cannot call CT divGDec on type Double" - dadd aout bout = - addD (proxy numComponents (Proxy::Proxy r)) (castPtr aout) (castPtr bout) dmul = error "cannot call CT (*) on type Double" - dgaussdec ruptr pout totm pfac numFacts = + dgaussdec ruptr pout totm pfac numFacts = tensorGaussianDec (proxy numComponents (Proxy::Proxy r)) (castPtr pout) totm pfac numFacts (castPtr ruptr) instance (Tuple r, CTypeOf r ~ Int64D) => Dispatch' Int64D r where dcrt = error "cannot call CT Crt on type Int64" dcrtinv = error "cannot call CT CrtInv on type Int64" - dl pout = + dl pout = tensorLR (proxy numComponents (Proxy::Proxy r)) (castPtr pout) - dlinv pout = + dlinv pout = tensorLInvR (proxy numComponents (Proxy::Proxy r)) (castPtr pout) - dnorm pout = + dnorm pout = tensorNormSqR (proxy numComponents (Proxy::Proxy r)) (castPtr pout) - dmulgpow pout = + dmulgpow pout = tensorGPowR (proxy numComponents (Proxy::Proxy r)) (castPtr pout) - dmulgdec pout = + dmulgdec pout = tensorGDecR (proxy numComponents (Proxy::Proxy r)) (castPtr pout) - dginvpow pout = + dginvpow pout = tensorGInvPowR (proxy numComponents (Proxy::Proxy r)) (castPtr pout) - dginvdec pout = + dginvdec pout = tensorGInvDecR (proxy numComponents (Proxy::Proxy r)) (castPtr pout) - dadd aout bout = - addR (proxy numComponents (Proxy::Proxy r)) (castPtr aout) (castPtr bout) dmul = error "cannot call CT (*) on type Int64" dgaussdec = error "cannot call CT gaussianDec on type Int64" @@ -276,6 +294,7 @@ foreign import ccall unsafe "tensorLInvC" tensorLInvC :: Int16 -> Ptr (Complex Double) -> Int64 -> Ptr CPP -> Int16 -> IO () foreign import ccall unsafe "tensorNormSqR" tensorNormSqR :: Int16 -> Ptr Int64 -> Int64 -> Ptr CPP -> Int16 -> IO () +foreign import ccall unsafe "tensorNormSqD" tensorNormSqD :: Int16 -> Ptr Double -> Int64 -> Ptr CPP -> Int16 -> IO () foreign import ccall unsafe "tensorGPowR" tensorGPowR :: Int16 -> Ptr Int64 -> Int64 -> Ptr CPP -> Int16 -> IO () foreign import ccall unsafe "tensorGPowRq" tensorGPowRq :: Int16 -> Ptr (ZqBasic q Int64) -> Int64 -> Ptr CPP -> Int16 -> Ptr Int64 -> IO () @@ -297,8 +316,3 @@ foreign import ccall unsafe "mulRq" mulRq :: Int16 -> Ptr (ZqBasic q Int64) -> Ptr (ZqBasic q Int64) -> Int64 -> Ptr Int64 -> IO () foreign import ccall unsafe "mulC" mulC :: Int16 -> Ptr (Complex Double) -> Ptr (Complex Double) -> Int64 -> IO () - -foreign import ccall unsafe "addRq" addRq :: Int16 -> Ptr (ZqBasic q Int64) -> Ptr (ZqBasic q Int64) -> Int64 -> Ptr Int64 -> IO () -foreign import ccall unsafe "addR" addR :: Int16 -> Ptr Int64 -> Ptr Int64 -> Int64 -> IO () -foreign import ccall unsafe "addC" addC :: Int16 -> Ptr (Complex Double) -> Ptr (Complex Double) -> Int64 -> IO () -foreign import ccall unsafe "addD" addD :: Int16 -> Ptr Double -> Ptr Double -> Int64 -> IO () diff --git a/Crypto/Lol/Cyclotomic/Tensor/CTensor/Extension.hs b/Crypto/Lol/Cyclotomic/Tensor/CTensor/Extension.hs --- a/Crypto/Lol/Cyclotomic/Tensor/CTensor/Extension.hs +++ b/Crypto/Lol/Cyclotomic/Tensor/CTensor/Extension.hs @@ -1,6 +1,7 @@ -{-# LANGUAGE ConstraintKinds, DataKinds, FlexibleContexts, NoImplicitPrelude, - PolyKinds, RebindableSyntax, ScopedTypeVariables, - TypeFamilies, TypeOperators #-} +{-# LANGUAGE ConstraintKinds, DataKinds, FlexibleContexts, + MultiParamTypeClasses, NoImplicitPrelude, PolyKinds, + RebindableSyntax, ScopedTypeVariables, TypeFamilies, + TypeOperators #-} -- | CT-specific functions for embedding/twacing in various bases @@ -13,21 +14,21 @@ ) where import Crypto.Lol.CRTrans -import Crypto.Lol.LatticePrelude as LP hiding (null, lift) import Crypto.Lol.Cyclotomic.Tensor as T +import Crypto.Lol.Prelude as LP hiding (lift, null) import Crypto.Lol.Types.FiniteField import Crypto.Lol.Types.ZmStar -import Crypto.Lol.Reflects + import Control.Applicative hiding (empty) import Control.Monad.Trans (lift) import Data.Maybe -import Data.Reflection (reify) -import qualified Data.Vector as V -import Data.Vector.Generic as G (generate, Vector, (!), length) -import qualified Data.Vector.Unboxed as U +import Data.Reflection (reify) +import qualified Data.Vector as V +import Data.Vector.Generic as G (Vector, generate, length, (!)) import qualified Data.Vector.Storable as SV +import qualified Data.Vector.Unboxed as U -- | /O(n)/ Yield the vector obtained by replacing each element @i@ of the @@ -46,7 +47,7 @@ => Tagged '(m, m') (v r -> v r) -- | Embeds an vector in the powerful basis of the the mth cyclotomic ring -- to an vector in the powerful basis of the m'th cyclotomic ring when @m | m'@ -embedPow' = (\indices arr -> generate (U.length indices) $ \idx -> +embedPow' = (\indices arr -> generate (U.length indices) $ \idx -> let (j0,j1) = indices ! idx in if j0 == 0 then arr ! j1 @@ -60,10 +61,10 @@ -- | Embeds an vector in the CRT basis of the the mth cyclotomic ring -- to an vector in the CRT basis of the m'th cyclotomic ring when @m | m'@ -embedCRT' :: forall m m' v r . (CRTrans r, Vector v r, m `Divides` m') - => TaggedT '(m, m') Maybe (v r -> v r) -embedCRT' = - (lift (proxyT crtInfoFact (Proxy::Proxy m') :: Maybe (CRTInfo r))) >> +embedCRT' :: forall mon m m' v r . (CRTrans mon r, Vector v r, m `Divides` m') + => TaggedT '(m, m') mon (v r -> v r) +embedCRT' = + (lift (proxyT crtInfo (Proxy::Proxy m') :: mon (CRTInfo r))) >> (pureT $ backpermute' <$> baseIndicesCRT) -- | maps a vector in the powerful/decoding basis, representing an @@ -75,7 +76,7 @@ <$> extIndicesCoeffs -- | The "tweaked trace" function in either the powerful or decoding --- basis of the m'th cyclotomic ring to the mth cyclotomic ring when +-- basis of the m'th cyclotomic ring to the mth cyclotomic ring when -- @m | m'@. twacePowDec' :: forall m m' r v . (Vector v r, m `Divides` m') => Tagged '(m, m') (v r -> v r) @@ -92,7 +93,7 @@ powBasisPow' = do (_, phi, phi', _) <- indexInfo idxs <- baseIndicesPow - return $ LP.map (\k -> generate phi' $ \j -> + return $ LP.map (\k -> generate phi' $ \j -> let (j0,j1) = idxs U.! j in if j0==k && j1==0 then one else zero) [0..phi' `div` phi - 1] diff --git a/Crypto/Lol/Cyclotomic/Tensor/CTensor/basic.c b/Crypto/Lol/Cyclotomic/Tensor/CTensor/basic.c deleted file mode 100644 --- a/Crypto/Lol/Cyclotomic/Tensor/CTensor/basic.c +++ /dev/null @@ -1,175 +0,0 @@ -#include "tensorTypes.h" -#ifdef CINTRIN -#include -#endif - -#ifdef STATS -int mulCtr = 0; -struct timespec mulTime = {0,0}; - -int addCtr = 0; -struct timespec addTime = {0,0}; -#endif - -//a = zipWith (*) a b -void mulRq (hShort_t tupSize, hInt_t* a, hInt_t* b, hDim_t totm, hInt_t* qs) { -#ifdef STATS - mulCtr++; - struct timespec s1,t1; - clock_gettime(CLOCK_REALTIME, &s1); -#endif - for(int tupIdx = 0; tupIdx < tupSize; tupIdx++) { - hInt_t q = qs[tupIdx]; - for(int i = 0; i < totm; i++) { - a[i*tupSize+tupIdx] = (a[i*tupSize+tupIdx]*b[i*tupSize+tupIdx])%q; - } - } -#ifdef STATS - clock_gettime(CLOCK_REALTIME, &t1); - mulTime = tsAdd(mulTime, tsSubtract(t1,s1)); -#endif -} -/* -void mulMq (hShort_t tupSize, hInt_t* a, const hInt_t* b, const hDim_t totm, const hByte_t logr, const hInt_t k, const hInt_t q) { -#ifdef STATS - mulCtr++; - struct timespec s1,t1; - clock_gettime(CLOCK_REALTIME, &s1); -#endif - hInt_t mask = (1<>logr; - } - -#ifdef STATS - clock_gettime(CLOCK_REALTIME, &t1); - mulTime = tsAdd(mulTime, tsSubtract(t1,s1)); -#endif -} -*/ -void mulC (hShort_t tupSize, complex_t* a, complex_t* b, hDim_t totm) { -#ifdef STATS - mulCtr++; - struct timespec s1,t1; - clock_gettime(CLOCK_REALTIME, &s1); -#endif - for(int i = 0; i < totm*tupSize; i++) - { - CMPLX_IMUL(a[i],b[i]); - } -#ifdef STATS - clock_gettime(CLOCK_REALTIME, &t1); - mulTime = tsAdd(mulTime, tsSubtract(t1,s1)); -#endif -} - -//a = zipWith (+) a b -void addRq (hShort_t tupSize, hInt_t* a, const hInt_t* b, const hDim_t totm, const hInt_t* qs) { -#ifdef STATS - addCtr++; - struct timespec s1,t1; - clock_gettime(CLOCK_REALTIME, &s1); -#endif -/* -need to check this code more carefully when tupSize > 1 -#ifdef CINTRIN - - for(int tupIdx = 0; tupIdx < tupSize; tupIdx++) { - hInt_t q = qs[tupIdx]; - __m128i qss = _mm_set1_epi64x(q); - for(int i = 0; i < totm; i+=2) { - __m128i xs = _mm_load_si128((const __m128i*)(a+(i*tupSize+tupIdx))); - __m128i ys = _mm_load_si128((const __m128i*)(b+(i*tupSize+tupIdx))); - __m128i zs = _mm_add_epi64(xs,ys); - zs = _mm_rem_epi64(zs,qss); - _mm_store_si128((__m128i*)(a+(i*tupSize+tupIdx)),zs); - } - } -#else -*/ - for(int tupIdx = 0; tupIdx < tupSize; tupIdx++) { - hInt_t q = qs[tupIdx]; - for(int i = 0; i < totm; i++) { - hInt_t temp = a[i*tupSize+tupIdx]+b[i*tupSize+tupIdx]; - if (temp >= q) a[i*tupSize+tupIdx]=temp-q; - else a[i*tupSize+tupIdx] = temp; - } - } -//#endif -#ifdef STATS - clock_gettime(CLOCK_REALTIME, &t1); - addTime = tsAdd(addTime, tsSubtract(t1,s1)); -#endif -} -/* -void addMq (hInt_t* a, const hInt_t* b, const hDim_t totm, const hByte_t logr, const hInt_t k, const hInt_t q) { -#ifdef STATS - addCtr++; - struct timespec s1,t1; - clock_gettime(CLOCK_REALTIME, &s1); -#endif - hInt_t twoq = q<<1; - for(int i = 0; i < totm; i++) { - hInt_t temp = (a[i]+b[i]); - if (temp >= twoq) a[i]=temp-twoq; - else a[i] = temp; - } - -#ifdef STATS - clock_gettime(CLOCK_REALTIME, &t1); - addTime = tsAdd(addTime, tsSubtract(t1,s1)); -#endif -} -*/ -//a = zipWith (+) a b -void addR (hShort_t tupSize, hInt_t* a, hInt_t* b, hDim_t totm) { -#ifdef STATS - addCtr++; - struct timespec s1,t1; - clock_gettime(CLOCK_REALTIME, &s1); -#endif - for(int i = 0; i < totm*tupSize; i++) { - a[i] += b[i]; - } -#ifdef STATS - clock_gettime(CLOCK_REALTIME, &t1); - addTime = tsAdd(addTime, tsSubtract(t1,s1)); -#endif -} - -void addC (hShort_t tupSize, complex_t* a, complex_t* b, hDim_t totm) { -#ifdef STATS - addCtr++; - struct timespec s1,t1; - clock_gettime(CLOCK_REALTIME, &s1); -#endif - for(int i = 0; i < totm*tupSize; i++) - { - CMPLX_IADD(a[i],b[i]); - } -#ifdef STATS - clock_gettime(CLOCK_REALTIME, &t1); - addTime = tsAdd(addTime, tsSubtract(t1,s1)); -#endif -} - -void addD (hShort_t tupSize, double* a, double* b, hDim_t totm) { -#ifdef STATS - addCtr++; - struct timespec s1,t1; - clock_gettime(CLOCK_REALTIME, &s1); -#endif - for(int i = 0; i < totm*tupSize; i++) - { - a[i]+=b[i]; - } -#ifdef STATS - clock_gettime(CLOCK_REALTIME, &t1); - addTime = tsAdd(addTime, tsSubtract(t1,s1)); -#endif -} - diff --git a/Crypto/Lol/Cyclotomic/Tensor/CTensor/common.cpp b/Crypto/Lol/Cyclotomic/Tensor/CTensor/common.cpp new file mode 100644 --- /dev/null +++ b/Crypto/Lol/Cyclotomic/Tensor/CTensor/common.cpp @@ -0,0 +1,18 @@ +#include "types.h" + +hInt_t Zq::q; // should be in zq.cpp; here due to GHC #12152 + +hDim_t ipow(hDim_t base, hShort_t exp) +{ + hDim_t result = 1; + while (exp) { + if (exp & 1) { + result *= base; + } + exp >>= 1; + base *= base; + } + return result; +} + + diff --git a/Crypto/Lol/Cyclotomic/Tensor/CTensor/common.h b/Crypto/Lol/Cyclotomic/Tensor/CTensor/common.h new file mode 100644 --- /dev/null +++ b/Crypto/Lol/Cyclotomic/Tensor/CTensor/common.h @@ -0,0 +1,18 @@ +#ifndef COMMON_H_ +#define COMMON_H_ + +#include +#include +#include "types.h" + +#define ASSERT(EXP) { \ + if (!(EXP)) { \ + fprintf (stderr, "Assertion in file '%s' line %d : " #EXP " is false\n", __FILE__, __LINE__); \ + exit(-1); \ + } \ +} + +// calculates base ** exp +hDim_t ipow(hDim_t base, hShort_t exp); + +#endif /* COMMON_H_ */ diff --git a/Crypto/Lol/Cyclotomic/Tensor/CTensor/crt.c b/Crypto/Lol/Cyclotomic/Tensor/CTensor/crt.c deleted file mode 100644 --- a/Crypto/Lol/Cyclotomic/Tensor/CTensor/crt.c +++ /dev/null @@ -1,1386 +0,0 @@ -#include "tensorTypes.h" -#include -#include - -// there should be a special cases that do NOT require temp space to be allocated for all primes *smaller* than DFTP_GENERIC_SIZE -#define DFTP_GENERIC_SIZE 11 - -#ifdef STATS -int crtRqCtr = 0; -int crtInvRqCtr = 0; -int crtCCtr = 0; -int crtInvCCtr = 0; - -struct timespec crttime1 = {0,0}; -struct timespec crttime2 = {0,0}; -struct timespec crttime3 = {0,0}; -struct timespec crttime4 = {0,0}; - -struct timespec crtInvRqTime = {0,0}; -struct timespec crtCTime = {0,0}; -struct timespec crtInvCTime = {0,0}; -#endif - -hDim_t bitrev (PrimeExponent pe, hDim_t j) { - hShort_t e; - hDim_t p = pe.prime; - hDim_t tempj = j; - hDim_t acc = 0; - - for(e = pe.exponent-1; e >= 0; e--) { - div_t qr = div(tempj,p); - acc += qr.rem * ipow(p,e); - tempj = qr.quot; - } - return acc; -} - -void crtTwiddleRq (hInt_t* y, hShort_t tupSize, hDim_t lts, hDim_t rts, - PrimeExponent pe, hInt_t* ru, hInt_t q) -{ - hDim_t p = pe.prime; - hShort_t e = pe.exponent; - -#ifdef DEBUG_MODE - ASSERT(e != 0); -#endif - pe.exponent -= 1; // used for an argument to bitrev - - if(p == 2) - { - hDim_t mprime = 1<<(e-1); - hDim_t blockDim = rts*mprime; // size of block in block diagonal tensor matrix - - for(hDim_t i0 = 1; i0 < mprime; i0++) // loops over i/(p-1) for i = 0..(m'-1), we can skip i0 = 0 - { - hDim_t temp2 = i0*rts; - hInt_t twid = ru[bitrev(pe, i0)*tupSize]; - - for(hDim_t blockIdx = 0; blockIdx < lts; blockIdx++) - { - hDim_t temp3 = blockIdx*blockDim + temp2; - for(hDim_t modOffset = 0; modOffset < rts; modOffset++) - { - hDim_t idx = (temp3 + modOffset)*tupSize; - y[idx] = (y[idx]*twid) % q; - } - } - } - } - else // This loop is faster, probably due to the division in the loop above. - // cilk also slows it down - { - hDim_t mprime = ipow(p,e-1); - hDim_t blockDim = rts*(p-1)*mprime; // size of block in block diagonal tensor matrix - - for(hDim_t i0 = 1; i0 < mprime; i0++) // loops over i/(p-1) for i = 0..(m'-1), we can skip i0 = 0 - { - hDim_t temp1 = i0*(p-1); - for(hDim_t i1 = 0; i1 < (p-1); i1++) // loops over i%(p-1) for i = 0..(m'-1) - { - hDim_t temp2 = (temp1+i1)*rts; - hInt_t twid = ru[bitrev(pe, i0)*(i1+1)*tupSize]; - - for(hDim_t blockIdx = 0; blockIdx < lts; blockIdx++) - { - hDim_t temp3 = blockIdx*blockDim + temp2; - for(hDim_t modOffset = 0; modOffset < rts; modOffset++) - { - hDim_t idx = (temp3 + modOffset)*tupSize; - y[idx] = (y[idx]*twid) % q; - } - } - } - } - } -} - -// dim is power of p -void dftptwidRq (hInt_t* y, hShort_t tupSize, hDim_t lts, hDim_t rts, - PrimeExponent pe, hDim_t dim, hDim_t rustride, hInt_t* ru, hInt_t q) -{ - hDim_t idx; - hDim_t p = pe.prime; - - pe.exponent -= 1; // used for an argument to bitrev - - if(p == 2) { - hDim_t mprime = dim>>1; // divides evenly - hDim_t temp1 = rts*dim; // for use in computing [modified] tensorOffset - for(hDim_t i0 = 1; i0 < mprime; i0++) // loops over i/p for i = 0..(dim-1), but we skip i0=0 - { - hDim_t temp3 = rts*(i0*p+1); - hInt_t twid = ru[bitrev(pe,i0)*rustride*tupSize]; - - for(hDim_t blockOffset = 0; blockOffset < lts; blockOffset++) - { - hDim_t temp2 = blockOffset*temp1 + temp3; - for(hDim_t modOffset = 0; modOffset < rts; modOffset++) - { - idx = (temp2 + modOffset)*tupSize; - y[idx] = (y[idx]*twid) % q; - } - } - } - } - else - { - hDim_t mprime = dim/p; // divides evenly - hDim_t temp1 = rts*dim; // for use in computing [modified] tensorOffset - for(hDim_t i0 = 1; i0 < mprime; i0++) // loops over i/p for i = 0..(dim-1), but we skip i0=0 - { - for(hDim_t i1 = 1; i1 < p; i1++) // loops over i%p for i = 0..(dim-1), but we skip i1=0 - { - hDim_t temp3 = rts*(i0*p+i1); - hInt_t twid = ru[bitrev(pe,i0)*i1*rustride*tupSize]; - - for(hDim_t blockOffset = 0; blockOffset < lts; blockOffset++) - { - hDim_t temp2 = blockOffset*temp1 + temp3; - for(hDim_t modOffset = 0; modOffset < rts; modOffset++) - { - idx = (temp2 + modOffset)*tupSize; - y[idx] = (y[idx]*twid) % q; - } - } - } - } - } -} - -//implied length of ru is rustride*p -//implied length of tempSpace is p, if p is not a special case -// temp is allowed to be NULL if p < DFTP_GENERIC_SIZE -void dftpRq (hInt_t* y, hShort_t tupSize, hDim_t lts, hDim_t rts, - hDim_t p, hDim_t rustride, hInt_t* ru, hInt_t* tempSpace, hInt_t q) -{ - hDim_t tensorOffset; - - if(p == 2) - { - hDim_t temp1 = rts<<1; - - for(hDim_t blockOffset = 0; blockOffset < lts; blockOffset++) - { - hDim_t temp2 = blockOffset*temp1; - for(hDim_t modOffset = 0; modOffset < rts; modOffset++) - { - tensorOffset = temp2 + modOffset; - hInt_t u = y[tensorOffset*tupSize]; - hInt_t t = y[(tensorOffset+rts)*tupSize]; - y[tensorOffset*tupSize] = (u + t) % q; - y[(tensorOffset+rts)*tupSize] = (u - t) % q; - } - } - } - else if(p == 3) - { - hInt_t ru1 = ru[rustride*tupSize]; - hInt_t ru2 = ru[(rustride<<1)*tupSize]; - hDim_t temp1 = rts*3; - - for(hDim_t blockOffset = 0; blockOffset < lts; blockOffset++) - { - hDim_t temp2 = blockOffset*temp1; - for(hDim_t modOffset = 0; modOffset < rts; modOffset++) - { - tensorOffset = temp2 + modOffset; - hInt_t y1, y2, y3; - y1 = y[tensorOffset*tupSize]; - y2 = y[(tensorOffset+rts)*tupSize]; - y3 = y[(tensorOffset+(rts<<1))*tupSize]; - //q is <32 bits, so we can do 3 additions without overflow - y[tensorOffset*tupSize] = (y1 + y2 + y3) % q; - y[(tensorOffset+rts)*tupSize] = (y1 + ((ru1*y2) % q) + ((ru2*y3) % q)) % q; - y[(tensorOffset+(rts<<1))*tupSize] = (y1 + ((ru2*y2) % q) + ((ru1*y3) % q)) % q; - } - } - - } - else if(p == 5) - { - hDim_t temp1 = rts*5; - hInt_t ru1 = ru[rustride*tupSize]; - hInt_t ru2 = ru[(rustride<<1)*tupSize]; - hInt_t ru3 = ru[(rustride*3)*tupSize]; - hInt_t ru4 = ru[(rustride<<2)*tupSize]; - - for(hDim_t blockOffset = 0; blockOffset < lts; blockOffset++) - { - hDim_t temp2 = blockOffset*temp1; - for(hDim_t modOffset = 0; modOffset < rts; modOffset++) - { - tensorOffset = temp2 + modOffset; - hInt_t y1, y2, y3, y4, y5; - y1 = y[tensorOffset*tupSize]; - y2 = y[(tensorOffset+rts)*tupSize]; - y3 = y[(tensorOffset+(rts<<1))*tupSize]; - y4 = y[(tensorOffset+3*rts)*tupSize]; - y5 = y[(tensorOffset+(rts<<2))*tupSize]; - y[tensorOffset*tupSize] = (y1 + y2 + y3 + y4 + y5) % q; - y[(tensorOffset+rts)*tupSize] = (y1 + ((ru1*y2) % q) + ((ru2*y3) % q) + ((ru3*y4) % q) + ((ru4*y5) % q)) % q; - y[(tensorOffset+(rts<<1))*tupSize] = (y1 + ((ru2*y2) % q) + ((ru4*y3) % q) + ((ru1*y4) % q) + ((ru3*y5) % q)) % q; - y[(tensorOffset+rts*3)*tupSize] = (y1 + ((ru3*y2) % q) + ((ru1*y3) % q) + ((ru4*y4) % q) + ((ru2*y5) % q)) % q; - y[(tensorOffset+(rts<<2))*tupSize] = (y1 + ((ru4*y2) % q) + ((ru3*y3) % q) + ((ru2*y4) % q) + ((ru1*y5) % q)) % q; - } - } - } - else if(p == 7) - { - hDim_t temp1 = rts*7; - hInt_t ru1 = ru[rustride*tupSize]; - hInt_t ru2 = ru[(rustride<<1)*tupSize]; - hInt_t ru3 = ru[(rustride*3)*tupSize]; - hInt_t ru4 = ru[(rustride<<2)*tupSize]; - hInt_t ru5 = ru[(rustride*5)*tupSize]; - hInt_t ru6 = ru[(rustride*6)*tupSize]; - - for(hDim_t blockOffset = 0; blockOffset < lts; blockOffset++) - { - hDim_t temp2 = blockOffset*temp1; - for(hDim_t modOffset = 0; modOffset < rts; modOffset++) - { - tensorOffset = temp2 + modOffset; - hInt_t y1, y2, y3, y4, y5, y6, y7; - y1 = y[tensorOffset*tupSize]; - y2 = y[(tensorOffset+rts)*tupSize]; - y3 = y[(tensorOffset+(rts<<1))*tupSize]; - y4 = y[(tensorOffset+3*rts)*tupSize]; - y5 = y[(tensorOffset+(rts<<2))*tupSize]; - y6 = y[(tensorOffset+rts*5)*tupSize]; - y7 = y[(tensorOffset+rts*6)*tupSize]; - y[tensorOffset*tupSize] = (y1 + y2 + y3 + y4 + y5 + y6 + y7) % q; - y[(tensorOffset+rts)*tupSize] = (y1 + ((ru1*y2) % q) + ((ru2*y3) % q) + ((ru3*y4) % q) + ((ru4*y5) % q) + ((ru5*y6) % q) + ((ru6*y7) % q)) % q; - y[(tensorOffset+(rts<<1))*tupSize] = (y1 + ((ru2*y2) % q) + ((ru4*y3) % q) + ((ru6*y4) % q) + ((ru1*y5) % q) + ((ru3*y6) % q) + ((ru5*y7) % q)) % q; - y[(tensorOffset+rts*3)*tupSize] = (y1 + ((ru3*y2) % q) + ((ru6*y3) % q) + ((ru2*y4) % q) + ((ru5*y5) % q) + ((ru1*y6) % q) + ((ru4*y7) % q)) % q; - y[(tensorOffset+(rts<<2))*tupSize] = (y1 + ((ru4*y2) % q) + ((ru1*y3) % q) + ((ru5*y4) % q) + ((ru2*y5) % q) + ((ru6*y6) % q) + ((ru3*y7) % q)) % q; - y[(tensorOffset+rts*5)*tupSize] = (y1 + ((ru5*y2) % q) + ((ru3*y3) % q) + ((ru1*y4) % q) + ((ru6*y5) % q) + ((ru4*y6) % q) + ((ru2*y7) % q)) % q; - y[(tensorOffset+rts*6)*tupSize] = (y1 + ((ru6*y2) % q) + ((ru5*y3) % q) + ((ru4*y4) % q) + ((ru3*y5) % q) + ((ru2*y6) % q) + ((ru1*y7) % q)) % q; - } - } - } - else - { - hDim_t temp1 = rts*p; - for(hDim_t blockOffset = 0; blockOffset < lts; blockOffset++) - { - hDim_t temp2 = blockOffset*temp1; - for(hDim_t modOffset = 0; modOffset < rts; modOffset++) - { - tensorOffset = temp2 + modOffset; - for(hDim_t row = 0; row < p; row++) - { - hInt_t acc = 0; - //p is small (<< 30 bits), so we can do p additions of mod-q values without overflow - for(hDim_t col = 0; col < p; col++) - { - acc += ((y[(tensorOffset+col*rts)*tupSize]*ru[((col*row) % p)*rustride*tupSize])%q); - } - tempSpace[row] = acc % q; - } - - for(hDim_t row = 0; row < p; row++) - { - y[(tensorOffset+rts*row)*tupSize] = tempSpace[row]; - } - } - } - } -} - -void crtpRq (hInt_t* y, hShort_t tupSize, hDim_t lts, hDim_t rts, - hDim_t p, hDim_t rustride, hInt_t* ru, hInt_t q) -{ - hDim_t tensorOffset; - if(p == 2) - { - return; - } - else if(p == 3) - { - hDim_t temp1 = rts*2; - hInt_t ru1 = ru[rustride*tupSize]; - hInt_t ru2 = ru[(rustride<<1)*tupSize]; - - for(hDim_t blockOffset = 0; blockOffset < lts; blockOffset++) - { - hDim_t temp2 = blockOffset*temp1; - for(hDim_t modOffset = 0; modOffset < rts; modOffset++) - { - tensorOffset = temp2 + modOffset; - hInt_t y1, y2; - y1 = y[tensorOffset*tupSize]; - y2 = y[(tensorOffset+rts)*tupSize]; - y[tensorOffset*tupSize] = (y1 + ((ru1*y2)%q)) % q; - y[(tensorOffset+rts)*tupSize] = (y1 + ((ru2*y2)%q)) % q; - } - } - } - else if(p == 5) - { - hDim_t temp1 = rts*4; - hInt_t ru1 = ru[rustride*tupSize]; - hInt_t ru2 = ru[(rustride<<1)*tupSize]; - hInt_t ru3 = ru[(rustride*3)*tupSize]; - hInt_t ru4 = ru[(rustride<<2)*tupSize]; - - for(hDim_t blockOffset = 0; blockOffset < lts; blockOffset++) - { - hDim_t temp2 = blockOffset*temp1; - for(hDim_t modOffset = 0; modOffset < rts; modOffset++) - { - tensorOffset = temp2 + modOffset; - hInt_t y1, y2, y3, y4; - y1 = y[tensorOffset*tupSize]; - y2 = y[(tensorOffset+rts)*tupSize]; - y3 = y[(tensorOffset+(rts<<1))*tupSize]; - y4 = y[(tensorOffset+3*rts)*tupSize]; - - y[tensorOffset*tupSize] = (y1 + ((ru1*y2) % q) + ((ru2*y3) % q) + ((ru3*y4) % q)) % q; - y[(tensorOffset+rts)*tupSize] = (y1 + ((ru2*y2) % q) + ((ru4*y3) % q) + ((ru1*y4) % q)) % q; - y[(tensorOffset+(rts<<1))*tupSize] = (y1 + ((ru3*y2) % q) + ((ru1*y3) % q) + ((ru4*y4) % q)) % q; - y[(tensorOffset+rts*3)*tupSize] = (y1 + ((ru4*y2) % q) + ((ru3*y3) % q) + ((ru2*y4) % q)) % q; - } - } - } - else if(p == 7) - { - hDim_t temp1 = rts*6; - hInt_t ru1 = ru[rustride*tupSize]; - hInt_t ru2 = ru[(rustride<<1)*tupSize]; - hInt_t ru3 = ru[(rustride*3)*tupSize]; - hInt_t ru4 = ru[(rustride<<2)*tupSize]; - hInt_t ru5 = ru[(rustride*5)*tupSize]; - hInt_t ru6 = ru[(rustride*6)*tupSize]; - for(hDim_t blockOffset = 0; blockOffset < lts; blockOffset++) - { - hDim_t temp2 = blockOffset*temp1; - for(hDim_t modOffset = 0; modOffset < rts; modOffset++) - { - tensorOffset = temp2 + modOffset; - hInt_t y1, y2, y3, y4, y5, y6; - y1 = y[tensorOffset*tupSize]; - y2 = y[(tensorOffset+rts)*tupSize]; - y3 = y[(tensorOffset+(rts<<1))*tupSize]; - y4 = y[(tensorOffset+3*rts)*tupSize]; - y5 = y[(tensorOffset+(rts<<2))*tupSize]; - y6 = y[(tensorOffset+rts*5)*tupSize]; - y[tensorOffset*tupSize] = (y1 + ((ru1*y2) % q) + ((ru2*y3) % q) + ((ru3*y4) % q) + ((ru4*y5) % q) + ((ru5*y6) % q)) % q; - y[(tensorOffset+rts)*tupSize] = (y1 + ((ru2*y2) % q) + ((ru4*y3) % q) + ((ru6*y4) % q) + ((ru1*y5) % q) + ((ru3*y6) % q)) % q; - y[(tensorOffset+(rts<<1))*tupSize] = (y1 + ((ru3*y2) % q) + ((ru6*y3) % q) + ((ru2*y4) % q) + ((ru5*y5) % q) + ((ru1*y6) % q)) % q; - y[(tensorOffset+rts*3)*tupSize] = (y1 + ((ru4*y2) % q) + ((ru1*y3) % q) + ((ru5*y4) % q) + ((ru2*y5) % q) + ((ru6*y6) % q)) % q; - y[(tensorOffset+(rts<<2))*tupSize] = (y1 + ((ru5*y2) % q) + ((ru3*y3) % q) + ((ru1*y4) % q) + ((ru6*y5) % q) + ((ru4*y6) % q)) % q; - y[(tensorOffset+rts*5)*tupSize] = (y1 + ((ru6*y2) % q) + ((ru5*y3) % q) + ((ru4*y4) % q) + ((ru3*y5) % q) + ((ru2*y6) % q)) % q; - } - } - } - else - { - hInt_t* tempSpace = (hInt_t*)malloc((p-1)*sizeof(hInt_t)); - hDim_t temp1 = rts*(p-1); - for(hDim_t blockOffset = 0; blockOffset < lts; blockOffset++) - { - hDim_t temp2 = blockOffset*temp1; - for(hDim_t modOffset = 0; modOffset < rts; modOffset++) - { - tensorOffset = temp2 + modOffset; - - for(hDim_t row = 1; row < p; row++) - { - hInt_t acc = 0; - for(hDim_t col = 0; col < p-1; col++) - { - acc += ((y[(tensorOffset+col*rts)*tupSize]*ru[((col*row) % p)*rustride*tupSize]) % q); - } - tempSpace[row-1] = acc % q; - } - - for(hDim_t row = 0; row < p-1; row++) - { - y[(tensorOffset+rts*row)*tupSize] = tempSpace[row]; - } - } - } - free(tempSpace); - } -} - -//takes inverse rus -void crtpinvRq (hInt_t* y, hShort_t tupSize, hDim_t lts, hDim_t rts, - hDim_t p, hDim_t rustride, hInt_t* ruinv, hInt_t q) -{ - if(p ==2) - { - // need this case so that we can divide overall by mhat^(-1) - return; - } - else - { - hDim_t tensorOffset,i; - hInt_t* tempSpace = (hInt_t*)malloc((p-1)*sizeof(hInt_t)); - hDim_t temp1 = rts*(p-1); - for(hDim_t blockOffset = 0; blockOffset < lts; blockOffset++) - { - hDim_t temp2 = blockOffset*temp1; - for(hDim_t modOffset = 0; modOffset < rts; modOffset++) - { - tensorOffset = temp2 + modOffset; - - for(i = 0; i < p-1; i++) - { - hInt_t sum = 0; - int j; - for(j = 0; j < p-1; j++) - { - int ruIdx = ((j+1)*i) % p; - sum += ((y[(tensorOffset+j*rts)*tupSize] * ruinv[ruIdx*rustride*tupSize]) % q); - } - tempSpace[i] = sum % q; - } - - hInt_t shift = 0; - for(i = 0; i < p-1; i++) - { - // we were given the inverse rus, so we need to negate the indices - shift += ((y[(tensorOffset+i*rts)*tupSize] * ruinv[rustride*(p-(i+1))*tupSize]) % q); - } - - for(i = 0; i < p-1; i++) - { - y[(tensorOffset+i*rts)*tupSize] = (tempSpace[i] - shift) % q; - } - } - } - } -} - -void ppDFTRq (hInt_t* y, hShort_t tupSize, hDim_t lts, hDim_t rts, - PrimeExponent pe, hDim_t rustride, hInt_t* ru, hInt_t q, hInt_t* temp) -{ - hDim_t p = pe.prime; - hShort_t e = pe.exponent; - - if(e == 0) - { - return; - } - - hDim_t primeRuStride = rustride*ipow(p,e-1); - - hShort_t i; - - hDim_t ltsScale = ipow(p,e-1); - hDim_t rtsScale = 1; - hDim_t twidRuStride = rustride; - for(i = 0; i < e; i++) - { - hDim_t rtsDim = rts*rtsScale; - dftpRq (y, tupSize, lts*ltsScale, rtsDim, p, primeRuStride, ru, temp, q); - dftptwidRq (y, tupSize, lts, rtsDim, pe, ltsScale*p, twidRuStride, ru, q); - - ltsScale /= p; - rtsScale *= p; - twidRuStride *= p; - pe.exponent -= 1; - } -} - -void ppDFTInvRq (hInt_t* y, hShort_t tupSize, hDim_t lts, hDim_t rts, - PrimeExponent pe, hDim_t rustride, hInt_t* ru, hInt_t q, hInt_t* temp) -{ - hDim_t p = pe.prime; - hShort_t e = pe.exponent; - - if(e == 0) - { - return; - } - hDim_t primeRuStride = rustride*ipow(p,e-1); - - hShort_t i; - - hDim_t ltsScale = 1; - hDim_t rtsScale = ipow(p,e-1); - hDim_t twidRuStride = primeRuStride; - pe.exponent = 1; - for(i = 0; i < e; i++) - { - hDim_t rtsDim = rts*rtsScale; - hDim_t ltsScaleP = ltsScale*p; - dftptwidRq (y, tupSize, lts, rtsDim, pe, ltsScaleP, twidRuStride, ru, q); - dftpRq (y, tupSize, lts*ltsScale, rtsDim, p, primeRuStride, ru, temp, q); - - ltsScale = ltsScaleP; - rtsScale /= p; - twidRuStride /= p; - pe.exponent += 1; - } -} - -void ppcrtRq (void* y, hShort_t tupSize, hDim_t lts, hDim_t rts, - PrimeExponent pe, void* ru, hInt_t* qs) -{ - hDim_t p = pe.prime; - hDim_t e = pe.exponent; -#ifdef DEBUG_MODE - ASSERT(e != 0); -#endif - hDim_t mprime = ipow(p,e-1); - -#ifdef DEBUG_MODE - printf("lts is %" PRId32 "\trts is %" PRId32 "\n", lts, rts); - printf("rus for p=%" PRId32 ", e=%" PRId16 "\t[", pe.prime, pe.exponent); - hDim_t i; - for(i = 0; i < ipow(p,e); i++) { - printf("%" PRId64 ",", ((hInt_t*)ru)[i*tupSize+tupIdx]); - } - printf("]\n"); -#endif - - hInt_t* temp = 0; - if(p >= DFTP_GENERIC_SIZE) - { - temp = (hInt_t*)malloc(p*sizeof(hInt_t)); - } - for(int tupIdx = 0; tupIdx < tupSize; tupIdx++) { - hInt_t* z = ((hInt_t*)y)+tupIdx; - hInt_t q = qs[tupIdx]; - hInt_t* ruOffset = ((hInt_t*)ru)+tupIdx; - crtpRq (z, tupSize, lts*mprime, rts, p, mprime, ruOffset, q); - crtTwiddleRq (z, tupSize, lts, rts, pe, ruOffset, q); - pe.exponent -= 1; - ppDFTRq (z, tupSize, lts, rts*(p-1), pe, p, ruOffset, q, temp); - pe.exponent += 1; - } - - if(p >= DFTP_GENERIC_SIZE) - { - free(temp); - } -} - -void ppcrtinvRq (void* y, hShort_t tupSize, hDim_t lts, hDim_t rts, - PrimeExponent pe, void* ru, hInt_t* qs) -{ - hDim_t p = pe.prime; - hDim_t e = pe.exponent; -#ifdef DEBUG_MODE - ASSERT(e != 0); -#endif - hDim_t mprime = ipow(p,e-1); -#ifdef DEBUG_MODE - printf("lts is %" PRId32 "\trts is %" PRId32 "\n", lts, rts); - printf("rus for p=%" PRId32 ", e=%" PRId16 "\t[", pe.prime, pe.exponent); - hDim_t i; - for(i = 0; i < ipow(p,e); i++) { - printf("%" PRId64 ",", ((hInt_t*)ru)[i*tupSize+tupIdx]); - } - printf("]\n"); -#endif - - hInt_t* temp = 0; - if(p >= DFTP_GENERIC_SIZE) - { - temp = (hInt_t*)malloc(p*sizeof(hInt_t)); - } - for(int tupIdx = 0; tupIdx < tupSize; tupIdx++) { - hInt_t* z = ((hInt_t*)y)+tupIdx; - hInt_t q = qs[tupIdx]; - hInt_t* ruOffset = ((hInt_t*)ru)+tupIdx; - - pe.exponent -= 1; - ppDFTInvRq (z, tupSize, lts, rts*(p-1), pe, p, ruOffset, q, temp); - pe.exponent += 1; - crtTwiddleRq (z, tupSize, lts, rts, pe, ruOffset, q); - crtpinvRq (z, tupSize, lts*mprime, rts, p, mprime, ruOffset, q); - } - - if(p >= DFTP_GENERIC_SIZE) - { - free(temp); - } -} - -// EAC: Somebody who knows C/C++ should find a better way to handle pointers-to-pointers in a generic way -void tensorCRTRq (hShort_t tupSize, hInt_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, hInt_t** ru, hInt_t* qs) -{ - hDim_t i; -#ifdef STATS - struct timespec s1,s2,s3,s4,t1,t2,t3,t4; - - crtRqCtr++; - - clock_gettime(CLOCK_REALTIME, &s1); - clock_gettime(CLOCK_MONOTONIC, &s2); - clock_gettime(CLOCK_PROCESS_CPUTIME_ID, &s3); - clock_gettime(CLOCK_THREAD_CPUTIME_ID, &s4); -#endif -#ifdef DEBUG_MODE - printf("\n\nEntered tensorCRTRq\ttotm=%" PRId32 "\tnumFacts=%" PRId16 "\ttupSize=%" PRId16 "\n[", totm, sizeOfPE,tupSize); - for(i = 0; i < tupSize; i++) { - printf("%" PRId64 ",", qs[i]); - } - printf("]\n["); - for(i = 0; i < totm*tupSize; i++) { - printf("%" PRId64 ",", y[i]); - } - printf("]\n["); - for(i = 0; i < sizeOfPE; i++) { - printf("(%" PRId32 ",%" PRId16 "),", peArr[i].prime, peArr[i].exponent); - } - printf("]\n"); -#endif - - void** rus = (void**)malloc(sizeOfPE*sizeof(void*)); - for(i = 0; i < sizeOfPE; i++) - { - rus[i] = (void*) (ru[i]); - } - - tensorFuserCRT (y, tupSize, ppcrtRq, totm, peArr, sizeOfPE, rus, qs); - - for(i = 0; i < tupSize; i++) { - hInt_t q = qs[i]; - for(hDim_t j = 0; j < totm; j++) - { - if(y[j*tupSize+i]<0) - { - y[j*tupSize+i]+=q; - } -#ifdef DEBUG_MODE - if(y[j*tupSize+i]<0) - { - printf("TENSOR CRT^T INV\n"); - } -#endif - } - } - - free(rus); -#ifdef STATS - clock_gettime(CLOCK_REALTIME, &t1); - clock_gettime(CLOCK_MONOTONIC, &t2); - clock_gettime(CLOCK_PROCESS_CPUTIME_ID, &t3); - clock_gettime(CLOCK_THREAD_CPUTIME_ID, &t4); - - crttime1 = tsAdd(crttime1, tsSubtract(t1,s1)); - crttime2 = tsAdd(crttime2, tsSubtract(t2,s2)); - crttime3 = tsAdd(crttime3, tsSubtract(t3,s3)); - crttime4 = tsAdd(crttime4, tsSubtract(t4,s4)); -#endif -} - -//takes inverse rus -void tensorCRTInvRq (hShort_t tupSize, hInt_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, - hInt_t** ruinv, hInt_t* mhatInv, hInt_t* qs) -{ - hDim_t i; -#ifdef STATS - struct timespec s1,t1; - crtInvRqCtr++; - clock_gettime(CLOCK_REALTIME, &s1); -#endif -#ifdef DEBUG_MODE - printf("\n\nEntered tensorCRTInvRq\ttotm=%" PRId32 "\tnumFacts=%" PRId16 "\ttupSize=%" PRId16 "\nqs[", totm, sizeOfPE, tupSize); - for(i = 0; i < tupSize; i++) { - printf("%" PRId64 ",", qs[i]); - } - printf("]\nmhatInv["); - for(i = 0; i < tupSize; i++) { - printf("%" PRId64 ",", mhatInv[i]); - } - printf("]\ny["); - for(i = 0; i < totm*tupSize; i++) { - printf("%" PRId64 ",", y[i]); - } - printf("]\npps["); - for(i = 0; i < sizeOfPE; i++) { - printf("(%" PRId32 ",%" PRId16 "),", peArr[i].prime, peArr[i].exponent); - } - printf("]\n"); -#endif - - void** rus = (void**)malloc(sizeOfPE*sizeof(void*)); - for(i = 0; i < sizeOfPE; i++) - { - rus[i] = (void*) (ruinv[i]); - } - tensorFuserCRT (y, tupSize, ppcrtinvRq, totm, peArr, sizeOfPE, rus, qs); - - for (i = 0; i < tupSize; i++) { - hInt_t q = qs[i]; - for (hDim_t j = 0; j < totm; j++) - { - y[j*tupSize+i] = (y[j*tupSize+i]*mhatInv[i])%q; - if(y[j*tupSize+i] < 0) - { - y[j*tupSize+i] +=q; - } -#ifdef DEBUG_MODE - if(y[j*tupSize+i]<0) - { - printf("TENSOR CRT INV\n"); - } -#endif - } - } - - free(rus); -#ifdef STATS - clock_gettime(CLOCK_REALTIME, &t1); - crtInvRqTime = tsAdd(crtInvRqTime, tsSubtract(t1,s1)); -#endif -} - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -void crtTwiddleC (complex_t* y, hShort_t tupSize, hDim_t lts, hDim_t rts, PrimeExponent pe, complex_t* ru) -{ - hDim_t idx; - hDim_t p = pe.prime; - hShort_t e = pe.exponent; - -#ifdef DEBUG_MODE - ASSERT(e != 0); -#endif - - pe.exponent -= 1; // used for an argument to bitrev - - if(p == 2) - { - hDim_t mprime = 1<<(e-1); - hDim_t blockDim = rts*mprime; // size of block in block diagonal tensor matrix - - for(hDim_t i0 = 1; i0 < mprime; i0++) // loops over i/(p-1) for i = 0..(m'-1), we can skip i0 = 0 - { - hDim_t temp2 = i0*rts; - complex_t twid = ru[bitrev(pe,i0)*tupSize]; - - for(hDim_t blockIdx = 0; blockIdx < lts; blockIdx++) - { - hDim_t temp3 = blockIdx*blockDim + temp2; - for(hDim_t modOffset = 0; modOffset < rts; modOffset++) - { - idx = temp3 + modOffset; - CMPLX_IMUL(y[idx*tupSize],twid); - } - } - } - } - else - { - hDim_t mprime = ipow(p,e-1); - hDim_t blockDim = rts*(p-1)*mprime; // size of block in block diagonal tensor matrix - - for(hDim_t i0 = 1; i0 < mprime; i0++) // loops over i/(p-1) for i = 0..(m'-1), we can skip i0 = 0 - { - hDim_t temp1 = i0*(p-1); - for(hDim_t i1 = 0; i1 < (p-1); i1++) // loops over i%(p-1) for i = 0..(m'-1) - { - hDim_t temp2 = (temp1+i1)*rts; - complex_t twid = ru[bitrev(pe,i0)*(i1+1)*tupSize]; - - for(hDim_t blockIdx = 0; blockIdx < lts; blockIdx++) - { - hDim_t temp3 = blockIdx*blockDim + temp2; - for(hDim_t modOffset = 0; modOffset < rts; modOffset++) - { - idx = temp3 + modOffset; - CMPLX_IMUL(y[idx*tupSize],twid); - } - } - } - } - } -} - -// dim is power of p -void dftptwidC (complex_t* y, hShort_t tupSize, hDim_t lts, hDim_t rts, PrimeExponent pe, hDim_t dim, hDim_t rustride, complex_t* ru) -{ - hDim_t idx; - hDim_t p = pe.prime; - pe.exponent -= 1; // used for an argument to bitrev - - if(p == 2) - { - hDim_t mprime = dim>>1; // divides evenly - hDim_t temp1 = rts*dim; // for use in computing [modified] tensorOffset - for(hDim_t i0 = 1; i0 < mprime; i0++) // loops over i/p for i = 0..(dim-1), but we skip i0=0 - { - hDim_t temp3 = rts*(i0*p+1); - complex_t twid = ru[bitrev(pe,i0)*rustride*tupSize]; - - for(hDim_t blockOffset = 0; blockOffset < lts; blockOffset++) - { - hDim_t temp2 = blockOffset*temp1 + temp3; - for(hDim_t modOffset = 0; modOffset < rts; modOffset++) - { - idx = temp2 + modOffset; - CMPLX_IMUL(y[idx*tupSize],twid); - } - } - } - } - else - { - hDim_t mprime = dim/p; // divides evenly - hDim_t temp1 = rts*dim; // for use in computing [modified] tensorOffset - for(hDim_t i0 = 1; i0 < mprime; i0++) // loops over i/p for i = 0..(dim-1), but we skip i0=0 - { - for(hDim_t i1 = 1; i1 < p; i1++) // loops over i%p for i = 0..(dim-1), but we skip i1=0 - { - hDim_t temp3 = rts*(i0*p+i1); - complex_t twid = ru[bitrev(pe,i0)*i1*rustride*tupSize]; - - for(hDim_t blockOffset = 0; blockOffset < lts; blockOffset++) - { - hDim_t temp2 = blockOffset*temp1 + temp3; - for(hDim_t modOffset = 0; modOffset < rts; modOffset++) - { - idx = temp2 + modOffset; - CMPLX_IMUL(y[idx*tupSize],twid); - } - } - } - } - } -} - -//implied length of ru is rustride*p -//implied length of tempSpace is p, if p is not a special case -void dftpC (complex_t* y, hShort_t tupSize, hDim_t lts, hDim_t rts, hDim_t p, hDim_t rustride, complex_t* ru, complex_t* tempSpace) -{ - hDim_t blockOffset, modOffset, tensorOffset; - - if(p == 2) - { - hDim_t temp1 = rts<<1; - for(blockOffset = 0; blockOffset < lts; blockOffset++) - { - hDim_t temp2 = blockOffset*temp1; - for(modOffset = 0; modOffset < rts; modOffset++) - { - tensorOffset = temp2 + modOffset; - complex_t u = y[tensorOffset*tupSize]; - complex_t t = y[(tensorOffset+rts)*tupSize]; - y[tensorOffset*tupSize] = CMPLX_ADD(u,t); - y[(tensorOffset+rts)*tupSize] = CMPLX_SUB(u,t); - } - } - } - else if(p == 3) - { - hDim_t temp1 = rts*3; - complex_t ru1 = ru[rustride*tupSize]; - complex_t ru2 = ru[(rustride<<1)*tupSize]; - - for(blockOffset = 0; blockOffset < lts; blockOffset++) - { - hDim_t temp2 = blockOffset*temp1; - for(modOffset = 0; modOffset < rts; modOffset++) - { - tensorOffset = temp2 + modOffset; - complex_t y1, y2, y3; - y1 = y[tensorOffset*tupSize]; - y2 = y[(tensorOffset+rts)*tupSize]; - y3 = y[(tensorOffset+(rts<<1))*tupSize]; - y[tensorOffset*tupSize] = CMPLX_ADD3(y1, y2, y3); - y[(tensorOffset+rts)*tupSize] = CMPLX_ADD3(y1, CMPLX_MUL(ru1,y2), CMPLX_MUL(ru2,y3)); - y[(tensorOffset+(rts<<1))*tupSize] = CMPLX_ADD3(y1, CMPLX_MUL(ru2,y2), CMPLX_MUL(ru1,y3)); - } - } - } - else if(p == 5) - { - hDim_t temp1 = rts*5; - complex_t ru1 = ru[rustride*tupSize]; - complex_t ru2 = ru[(rustride<<1)*tupSize]; - complex_t ru3 = ru[(rustride*3)*tupSize]; - complex_t ru4 = ru[(rustride<<2)*tupSize]; - - for(blockOffset = 0; blockOffset < lts; blockOffset++) - { - hDim_t temp2 = blockOffset*temp1; - for(modOffset = 0; modOffset < rts; modOffset++) - { - tensorOffset = temp2 + modOffset; - complex_t y1, y2, y3, y4, y5; - y1 = y[tensorOffset*tupSize]; - y2 = y[(tensorOffset+rts)*tupSize]; - y3 = y[(tensorOffset+(rts<<1))*tupSize]; - y4 = y[(tensorOffset+3*rts)*tupSize]; - y5 = y[(tensorOffset+(rts<<2))*tupSize]; - y[tensorOffset*tupSize] = CMPLX_ADD5(y1, y2, y3, y4, y5); - y[(tensorOffset+rts)*tupSize] = CMPLX_ADD5(y1, CMPLX_MUL(ru1,y2), CMPLX_MUL(ru2,y3), CMPLX_MUL(ru3,y4), CMPLX_MUL(ru4,y5)); - y[(tensorOffset+(rts<<1))*tupSize] = CMPLX_ADD5(y1, CMPLX_MUL(ru2,y2), CMPLX_MUL(ru4,y3), CMPLX_MUL(ru1,y4), CMPLX_MUL(ru3,y5)); - y[(tensorOffset+rts*3)*tupSize] = CMPLX_ADD5(y1, CMPLX_MUL(ru3,y2), CMPLX_MUL(ru1,y3), CMPLX_MUL(ru4,y4), CMPLX_MUL(ru2,y5)); - y[(tensorOffset+(rts<<2))*tupSize] = CMPLX_ADD5(y1, CMPLX_MUL(ru4,y2), CMPLX_MUL(ru3,y3), CMPLX_MUL(ru2,y4), CMPLX_MUL(ru1,y5)); - } - } - } - else if(p == 7) - { - hDim_t temp1 = rts*7; - complex_t ru1 = ru[rustride*tupSize]; - complex_t ru2 = ru[(rustride<<1)*tupSize]; - complex_t ru3 = ru[(rustride*3)*tupSize]; - complex_t ru4 = ru[(rustride<<2)*tupSize]; - complex_t ru5 = ru[(rustride*5)*tupSize]; - complex_t ru6 = ru[(rustride*6)*tupSize]; - - for(blockOffset = 0; blockOffset < lts; blockOffset++) - { - hDim_t temp2 = blockOffset*temp1; - for(modOffset = 0; modOffset < rts; modOffset++) - { - tensorOffset = temp2 + modOffset; - complex_t y1, y2, y3, y4, y5, y6, y7; - y1 = y[tensorOffset*tupSize]; - y2 = y[(tensorOffset+rts)*tupSize]; - y3 = y[(tensorOffset+(rts<<1))*tupSize]; - y4 = y[(tensorOffset+3*rts)*tupSize]; - y5 = y[(tensorOffset+(rts<<2))*tupSize]; - y6 = y[(tensorOffset+rts*5)*tupSize]; - y7 = y[(tensorOffset+rts*6)*tupSize]; - y[tensorOffset*tupSize] = CMPLX_ADD7(y1, y2, y3, y4, y5, y6, y7); - y[(tensorOffset+rts)*tupSize] = CMPLX_ADD7(y1, CMPLX_MUL(ru1,y2), CMPLX_MUL(ru2,y3), CMPLX_MUL(ru3,y4), CMPLX_MUL(ru4,y5), CMPLX_MUL(ru5,y6), CMPLX_MUL(ru6,y7)); - y[(tensorOffset+(rts<<1))*tupSize] = CMPLX_ADD7(y1, CMPLX_MUL(ru2,y2), CMPLX_MUL(ru4,y3), CMPLX_MUL(ru6,y4), CMPLX_MUL(ru1,y5), CMPLX_MUL(ru3,y6), CMPLX_MUL(ru5,y7)); - y[(tensorOffset+rts*3)*tupSize] = CMPLX_ADD7(y1, CMPLX_MUL(ru3,y2), CMPLX_MUL(ru6,y3), CMPLX_MUL(ru2,y4), CMPLX_MUL(ru5,y5), CMPLX_MUL(ru1,y6), CMPLX_MUL(ru4,y7)); - y[(tensorOffset+(rts<<2))*tupSize] = CMPLX_ADD7(y1, CMPLX_MUL(ru4,y2), CMPLX_MUL(ru1,y3), CMPLX_MUL(ru5,y4), CMPLX_MUL(ru2,y5), CMPLX_MUL(ru6,y6), CMPLX_MUL(ru3,y7)); - y[(tensorOffset+rts*5)*tupSize] = CMPLX_ADD7(y1, CMPLX_MUL(ru5,y2), CMPLX_MUL(ru3,y3), CMPLX_MUL(ru1,y4), CMPLX_MUL(ru6,y5), CMPLX_MUL(ru4,y6), CMPLX_MUL(ru2,y7)); - y[(tensorOffset+rts*6)*tupSize] = CMPLX_ADD7(y1, CMPLX_MUL(ru6,y2), CMPLX_MUL(ru5,y3), CMPLX_MUL(ru4,y4), CMPLX_MUL(ru3,y5), CMPLX_MUL(ru2,y6), CMPLX_MUL(ru1,y7)); - } - } - } - else - { - hDim_t temp1 = rts*p; - for(blockOffset = 0; blockOffset < lts; blockOffset++) - { - hDim_t temp2 = blockOffset*temp1; - for(modOffset = 0; modOffset < rts; modOffset++) - { - tensorOffset = temp2 + modOffset; - hDim_t row, col; - - for(row = 0; row < p; row++) - { - complex_t acc = ((complex_t){0,0}); - for(col = 0; col < p; col++) - { - CMPLX_IADD(acc, CMPLX_MUL(y[(tensorOffset+col*rts)*tupSize], ru[((col*row) % p)*rustride*tupSize])); - } - tempSpace[row] = acc; - } - - for(row = 0; row < p; row++) - { - y[(tensorOffset+rts*row)*tupSize] = tempSpace[row]; - } - } - } - } -} - -void crtpC (complex_t* y, hShort_t tupSize, hDim_t lts, hDim_t rts, hDim_t p, hDim_t rustride, complex_t* ru) -{ - hDim_t blockOffset, modOffset, tensorOffset; - - if(p == 2) - { - return; - } - else if(p == 3) - { - hDim_t temp1 = rts*2; - complex_t ru1 = ru[rustride*tupSize]; - complex_t ru2 = ru[(rustride<<1)*tupSize]; - - for(blockOffset = 0; blockOffset < lts; blockOffset++) - { - hDim_t temp2 = blockOffset*temp1; - for(modOffset = 0; modOffset < rts; modOffset++) - { - tensorOffset = temp2 + modOffset; - complex_t y1, y2; - y1 = y[tensorOffset*tupSize]; - y2 = y[(tensorOffset+rts)*tupSize]; - y[tensorOffset*tupSize] = CMPLX_ADD(y1, CMPLX_MUL(ru1,y2)); - y[(tensorOffset+rts)*tupSize] = CMPLX_ADD(y1, CMPLX_MUL(ru2,y2)); - } - } - } - else if(p == 5) - { - hDim_t temp1 = rts*4; - complex_t ru1 = ru[rustride*tupSize]; - complex_t ru2 = ru[(rustride<<1)*tupSize]; - complex_t ru3 = ru[(rustride*3)*tupSize]; - complex_t ru4 = ru[(rustride<<2)*tupSize]; - - for(blockOffset = 0; blockOffset < lts; blockOffset++) - { - hDim_t temp2 = blockOffset*temp1; - for(modOffset = 0; modOffset < rts; modOffset++) - { - tensorOffset = temp2 + modOffset; - complex_t y1, y2, y3, y4; - y1 = y[tensorOffset*tupSize]; - y2 = y[(tensorOffset+rts)*tupSize]; - y3 = y[(tensorOffset+(rts<<1))*tupSize]; - y4 = y[(tensorOffset+3*rts)*tupSize]; - y[tensorOffset*tupSize] = CMPLX_ADD4(y1, CMPLX_MUL(ru1,y2), CMPLX_MUL(ru2,y3), CMPLX_MUL(ru3,y4)); - y[(tensorOffset+rts)*tupSize] = CMPLX_ADD4(y1, CMPLX_MUL(ru2,y2), CMPLX_MUL(ru4,y3), CMPLX_MUL(ru1,y4)); - y[(tensorOffset+(rts<<1))*tupSize] = CMPLX_ADD4(y1, CMPLX_MUL(ru3,y2), CMPLX_MUL(ru1,y3), CMPLX_MUL(ru4,y4)); - y[(tensorOffset+rts*3)*tupSize] = CMPLX_ADD4(y1, CMPLX_MUL(ru4,y2), CMPLX_MUL(ru3,y3), CMPLX_MUL(ru2,y4)); - } - } - } - else if(p == 7) - { - hDim_t temp1 = rts*6; - complex_t ru1 = ru[rustride*tupSize]; - complex_t ru2 = ru[(rustride<<1)*tupSize]; - complex_t ru3 = ru[(rustride*3)*tupSize]; - complex_t ru4 = ru[(rustride<<2)*tupSize]; - complex_t ru5 = ru[(rustride*5)*tupSize]; - complex_t ru6 = ru[(rustride*6)*tupSize]; - - for(blockOffset = 0; blockOffset < lts; blockOffset++) - { - hDim_t temp2 = blockOffset*temp1; - for(modOffset = 0; modOffset < rts; modOffset++) - { - tensorOffset = temp2 + modOffset; - complex_t y1, y2, y3, y4, y5, y6; - y1 = y[tensorOffset*tupSize]; - y2 = y[(tensorOffset+rts)*tupSize]; - y3 = y[(tensorOffset+(rts<<1))*tupSize]; - y4 = y[(tensorOffset+3*rts)*tupSize]; - y5 = y[(tensorOffset+(rts<<2))*tupSize]; - y6 = y[(tensorOffset+rts*5)*tupSize]; - y[tensorOffset*tupSize] = CMPLX_ADD6(y1, CMPLX_MUL(ru1,y2), CMPLX_MUL(ru2,y3), CMPLX_MUL(ru3,y4), CMPLX_MUL(ru4,y5), CMPLX_MUL(ru5,y6)); - y[(tensorOffset+rts)*tupSize] = CMPLX_ADD6(y1, CMPLX_MUL(ru2,y2), CMPLX_MUL(ru4,y3), CMPLX_MUL(ru6,y4), CMPLX_MUL(ru1,y5), CMPLX_MUL(ru3,y6)); - y[(tensorOffset+(rts<<1))*tupSize] = CMPLX_ADD6(y1, CMPLX_MUL(ru3,y2), CMPLX_MUL(ru6,y3), CMPLX_MUL(ru2,y4), CMPLX_MUL(ru5,y5), CMPLX_MUL(ru1,y6)); - y[(tensorOffset+rts*3)*tupSize] = CMPLX_ADD6(y1, CMPLX_MUL(ru4,y2), CMPLX_MUL(ru1,y3), CMPLX_MUL(ru5,y4), CMPLX_MUL(ru2,y5), CMPLX_MUL(ru6,y6)); - y[(tensorOffset+(rts<<2))*tupSize] = CMPLX_ADD6(y1, CMPLX_MUL(ru5,y2), CMPLX_MUL(ru3,y3), CMPLX_MUL(ru1,y4), CMPLX_MUL(ru6,y5), CMPLX_MUL(ru4,y6)); - y[(tensorOffset+rts*5)*tupSize] = CMPLX_ADD6(y1, CMPLX_MUL(ru6,y2), CMPLX_MUL(ru5,y3), CMPLX_MUL(ru4,y4), CMPLX_MUL(ru3,y5), CMPLX_MUL(ru2,y6)); - } - } - } - else - { - complex_t* tempSpace = (complex_t*)malloc((p-1)*sizeof(complex_t)); - hDim_t temp1 = rts*(p-1); - for(blockOffset = 0; blockOffset < lts; blockOffset++) - { - hDim_t temp2 = blockOffset*temp1; - for(modOffset = 0; modOffset < rts; modOffset++) - { - tensorOffset = temp2 + modOffset; - hDim_t row, col; - - for(row = 1; row < p; row++) - { - complex_t acc = ((complex_t){0,0}); - for(col = 0; col < p-1; col++) - { - CMPLX_IADD(acc, CMPLX_MUL(y[(tensorOffset+col*rts)*tupSize], ru[((col*row) % p)*rustride*tupSize])); - } - tempSpace[row-1] = acc; - } - - for(row = 0; row < p-1; row++) - { - y[(tensorOffset+rts*row)*tupSize] = tempSpace[row]; - } - } - } - free(tempSpace); - } -} - -//takes inverse rus -void crtpinvC (complex_t* y, hShort_t tupSize, hDim_t lts, hDim_t rts, hDim_t p, hDim_t rustride, complex_t* ruinv) -{ - if(p ==2) - { - // need this case so that we can divide overall by mhat^(-1) - return; - } - else - { - hDim_t tensorOffset,i; - complex_t* tempSpace = (complex_t*)malloc(p*sizeof(complex_t)); - hDim_t temp1 = rts*(p-1); - for(hDim_t blockOffset = 0; blockOffset < lts; blockOffset++) - { - hDim_t temp2 = blockOffset*temp1; - for(hDim_t modOffset = 0; modOffset < rts; modOffset++) - { - tensorOffset = temp2 + modOffset; - - for(i = 0; i < p-1; i++) - { - complex_t sum = ((complex_t){0,0}); - int j; - for(j = 0; j < p-1; j++) - { - int ruIdx = (((j+1)*i) % p)*rustride; - CMPLX_IADD(sum, CMPLX_MUL(y[(tensorOffset+j*rts)*tupSize],ruinv[ruIdx*tupSize])); - } - tempSpace[i] = sum; - } - - complex_t shift = ((complex_t){0,0}); - for(i = 0; i < p-1; i++) - { - // we were given the inverse rus, so we need to negate the indices - int ruIdx = p-(i+1); - CMPLX_IADD(shift, CMPLX_MUL(y[(tensorOffset+i*rts)*tupSize], ruinv[rustride*ruIdx*tupSize])); - } - - for(i = 0; i < p-1; i++) - { - y[(tensorOffset+i*rts)*tupSize] = CMPLX_SUB(tempSpace[i], shift); - } - } - } - } -} - -void ppDFTC (complex_t* y, hShort_t tupSize, hDim_t lts, hDim_t rts, PrimeExponent pe, hDim_t rustride, complex_t* ru, complex_t* temp) -{ - hDim_t p = pe.prime; - hShort_t e = pe.exponent; - - if(e == 0) - { - return; - } - - hDim_t primeRuStride = rustride*ipow(p,e-1); - - hShort_t i; - - hDim_t ltsScale = ipow(p,e-1); - hDim_t rtsScale = 1; - hDim_t twidRuStride = rustride; - for(i = 0; i < e; i++) - { - hDim_t rtsDim = rts*rtsScale; - dftpC (y, tupSize, lts*ltsScale, rtsDim, p, primeRuStride, ru, temp); - dftptwidC (y, tupSize, lts, rtsDim, pe, ltsScale*p, twidRuStride, ru); - - ltsScale /= p; - rtsScale *= p; - twidRuStride *= p; - pe.exponent -= 1; - } -} - -void ppDFTInvC (complex_t* y, hShort_t tupSize, hDim_t lts, hDim_t rts, PrimeExponent pe, hDim_t rustride, complex_t* ru, complex_t* temp) -{ - - hDim_t p = pe.prime; - hShort_t e = pe.exponent; - - if(e == 0) - { - return; - } - hDim_t primeRuStride = rustride*ipow(p,e-1); - - hShort_t i; - - hDim_t ltsScale = 1; - hDim_t rtsScale = ipow(p,e-1); - hDim_t twidRuStride = primeRuStride; - pe.exponent = 1; - for(i = 0; i < e; i++) - { - hDim_t rtsDim = rts*rtsScale; - hDim_t ltsScaleP = ltsScale*p; - dftptwidC (y, tupSize, lts, rtsDim, pe, ltsScaleP, twidRuStride, ru); - dftpC (y, tupSize, lts*ltsScale, rtsDim, p, primeRuStride, ru, temp); - - ltsScale = ltsScaleP; - rtsScale /= p; - twidRuStride /= p; - pe.exponent += 1; - } -} - -void ppcrtC (void* y, hShort_t tupSize, hDim_t lts, hDim_t rts, PrimeExponent pe, void* ru, hInt_t* qs) -{ - hDim_t p = pe.prime; - hDim_t e = pe.exponent; -#ifdef DEBUG_MODE - ASSERT(e != 0); -#endif - hDim_t mprime = ipow(p,e-1); - -#ifdef DEBUG_MODE - printf("rus for p=%" PRId32 ", e=%" PRId16 "\t[", pe.prime, pe.exponent); - hDim_t i; - for(i = 0; i < ipow(p,e); i++) { - printf("(%f,%f),", ((complex_t*)ru)[i].real, ((complex_t*)ru)[i].imag); - } - printf("]\n"); -#endif - - complex_t* temp = 0; - if(p >= DFTP_GENERIC_SIZE) - { - temp = (complex_t*)malloc(p*sizeof(complex_t)); - } - - for(int tupIdx = 0; tupIdx < tupSize; tupIdx++) { - complex_t* z = ((complex_t*)y)+tupIdx; - complex_t* ruOffset = ((complex_t*)ru)+tupIdx; - crtpC (z, tupSize, lts*mprime, rts, p, mprime, ruOffset); - crtTwiddleC (z, tupSize, lts, rts, pe, ruOffset); - pe.exponent -= 1; - ppDFTC (z, tupSize, lts, rts*(p-1), pe, p, ruOffset, temp); - pe.exponent += 1; - } - - if(p >= DFTP_GENERIC_SIZE) - { - free(temp); - } -} - -void ppcrtinvC (void* y, hShort_t tupSize, hDim_t lts, hDim_t rts, PrimeExponent pe, void* ru, hInt_t* qs) -{ - hDim_t p = pe.prime; - hDim_t e = pe.exponent; -#ifdef DEBUG_MODE - ASSERT(e != 0); -#endif - hDim_t mprime = ipow(p,e-1); - - complex_t* temp = 0; - if(p >= DFTP_GENERIC_SIZE) - { - temp = (complex_t*)malloc(p*sizeof(complex_t)); - } - - for(int tupIdx = 0; tupIdx < tupSize; tupIdx++) { - complex_t* z = ((complex_t*)y)+tupIdx; - complex_t* ruOffset = ((complex_t*)ru)+tupIdx; - pe.exponent -= 1; - ppDFTInvC (z, tupSize, lts, rts*(p-1), pe, p, ruOffset, temp); - pe.exponent += 1; - crtTwiddleC (z, tupSize, lts, rts, pe, ruOffset); - crtpinvC (z, tupSize, lts*mprime, rts, p, mprime, ruOffset); - } - - if(p >= DFTP_GENERIC_SIZE) - { - free(temp); - } -} - -void tensorCRTC (hShort_t tupSize, complex_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, complex_t** ru) -{ -#ifdef STATS - struct timespec s1,t1; - crtCCtr++; - clock_gettime(CLOCK_REALTIME, &s1); -#endif -#ifdef DEBUG_MODE - printf("\n\nEntered tensorCRTC\ttotm=%" PRId32 "\tnumFacts=%" PRId16 "\n[", totm, sizeOfPE); - hDim_t j; - for(j = 0; j < totm; j++) { - printf("(%f,%f),", y[j].real, y[j].imag); - } - printf("]\n["); - for(j = 0; j < sizeOfPE; j++) { - printf("(%" PRId32 ",%" PRId16 "),", peArr[j].prime, peArr[j].exponent); - } - printf("]\n"); -#endif - void** rus = (void**)malloc(sizeOfPE*sizeof(void*)); - hShort_t i; - for(i = 0; i < sizeOfPE; i++) - { - rus[i] = (void*) (ru[i]); - } - tensorFuserCRT (y, tupSize, ppcrtC, totm, peArr, sizeOfPE, rus, (hInt_t*)0); - free(rus); -#ifdef STATS - clock_gettime(CLOCK_REALTIME, &t1); - crtCTime = tsAdd(crtCTime, tsSubtract(t1,s1)); -#endif -} - -//takes inverse rus -void tensorCRTInvC (hShort_t tupSize, complex_t* y, hDim_t totm, PrimeExponent* peArr, - hShort_t sizeOfPE, complex_t** ruinv, complex_t* mhatInv) -{ -#ifdef STATS - struct timespec s1,t1; - crtInvCCtr++; - clock_gettime(CLOCK_REALTIME, &s1); -#endif - hDim_t i; - - void** rus = (void**)malloc(sizeOfPE*sizeof(void*)); - for(i = 0; i < sizeOfPE; i++) - { - rus[i] = (void*) (ruinv[i]); - } - - tensorFuserCRT (y, tupSize, ppcrtinvC, totm, peArr, sizeOfPE, rus, (hInt_t*)0); - - for (i = 0; i < tupSize; i++) { - for (hDim_t j = 0; j < totm; j++) - { - CMPLX_IMUL(y[j*tupSize+i], mhatInv[i]); - } - } - - free(rus); -#ifdef STATS - clock_gettime(CLOCK_REALTIME, &t1); - crtInvCTime = tsAdd(crtInvCTime, tsSubtract(t1,s1)); -#endif -} diff --git a/Crypto/Lol/Cyclotomic/Tensor/CTensor/crt.cpp b/Crypto/Lol/Cyclotomic/Tensor/CTensor/crt.cpp new file mode 100644 --- /dev/null +++ b/Crypto/Lol/Cyclotomic/Tensor/CTensor/crt.cpp @@ -0,0 +1,515 @@ +#include "types.h" +#include "tensor.h" +#include "common.h" + +// there should be a special cases that do NOT require temp space to be allocated for all primes *smaller* than DFTP_GENERIC_SIZE +#define DFTP_GENERIC_SIZE 11 + +hDim_t bitrev (PrimeExponent pe, hDim_t j) { + hShort_t e; + hDim_t p = pe.prime; + hDim_t tempj = j; + hDim_t acc = 0; + + for(e = pe.exponent-1; e >= 0; e--) { + div_t qr = div(tempj,p); + acc += qr.rem * ipow(p,e); + tempj = qr.quot; + } + return acc; +} + +template void crtTwiddle (ring* y, hShort_t tupSize, hDim_t lts, hDim_t rts, + PrimeExponent pe, ring* ru) +{ + hDim_t p = pe.prime; + hShort_t e = pe.exponent; + + pe.exponent -= 1; // used for an argument to bitrev + + if(p == 2) { + hDim_t mprime = 1<<(e-1); + hDim_t blockDim = rts*mprime; // size of block in block diagonal tensor matrix + + for(hDim_t i0 = 1; i0 < mprime; i0++) { // loops over i/(p-1) for i = 0..(m'-1), we can skip i0 = 0 + hDim_t temp2 = i0*rts; + ring twid = ru[bitrev(pe, i0)*tupSize]; + + for(hDim_t blockIdx = 0; blockIdx < lts; blockIdx++) { + hDim_t temp3 = blockIdx*blockDim + temp2; + for(hDim_t modOffset = 0; modOffset < rts; modOffset++) { + hDim_t idx = (temp3 + modOffset)*tupSize; + y[idx] *= twid; + } + } + } + } + else { // This loop is faster, probably due to the division in the loop above. + // cilk also slows it down + hDim_t mprime = ipow(p,e-1); + hDim_t blockDim = rts*(p-1)*mprime; // size of block in block diagonal tensor matrix + + for(hDim_t i0 = 1; i0 < mprime; i0++) { // loops over i/(p-1) for i = 0..(m'-1), we can skip i0 = 0 + hDim_t temp1 = i0*(p-1); + for(hDim_t i1 = 0; i1 < (p-1); i1++) { // loops over i%(p-1) for i = 0..(m'-1) + hDim_t temp2 = (temp1+i1)*rts; + ring twid = ru[bitrev(pe, i0)*(i1+1)*tupSize]; + + for(hDim_t blockIdx = 0; blockIdx < lts; blockIdx++) { + hDim_t temp3 = blockIdx*blockDim + temp2; + for(hDim_t modOffset = 0; modOffset < rts; modOffset++) { + hDim_t idx = (temp3 + modOffset)*tupSize; + y[idx] *= twid; + } + } + } + } + } +} + +// dim is power of p +template void dftTwiddle (ring* y, hShort_t tupSize, hDim_t lts, hDim_t rts, + PrimeExponent pe, hDim_t dim, hDim_t rustride, ring* ru) +{ + hDim_t idx; + hDim_t p = pe.prime; + + pe.exponent -= 1; // used for an argument to bitrev + + if(p == 2) { + hDim_t mprime = dim>>1; // divides evenly + hDim_t temp1 = rts*dim; // for use in computing [modified] tensorOffset + for(hDim_t i0 = 1; i0 < mprime; i0++) { // loops over i/p for i = 0..(dim-1), but we skip i0=0 + hDim_t temp3 = rts*(i0*p+1); + ring twid = ru[bitrev(pe,i0)*rustride*tupSize]; + + for(hDim_t blockOffset = 0; blockOffset < lts; blockOffset++) { + hDim_t temp2 = blockOffset*temp1 + temp3; + for(hDim_t modOffset = 0; modOffset < rts; modOffset++) { + idx = (temp2 + modOffset)*tupSize; + y[idx] *= twid; + } + } + } + } + else { + hDim_t mprime = dim/p; // divides evenly + hDim_t temp1 = rts*dim; // for use in computing [modified] tensorOffset + for(hDim_t i0 = 1; i0 < mprime; i0++) { // loops over i/p for i = 0..(dim-1), but we skip i0=0 + for(hDim_t i1 = 1; i1 < p; i1++) { // loops over i%p for i = 0..(dim-1), but we skip i1=0 + hDim_t temp3 = rts*(i0*p+i1); + ring twid = ru[bitrev(pe,i0)*i1*rustride*tupSize]; + + for(hDim_t blockOffset = 0; blockOffset < lts; blockOffset++) { + hDim_t temp2 = blockOffset*temp1 + temp3; + for(hDim_t modOffset = 0; modOffset < rts; modOffset++) { + idx = (temp2 + modOffset)*tupSize; + y[idx] *= twid; + } + } + } + } + } +} + +//implied length of ru is rustride*p +//implied length of tempSpace is p, if p is not a special case +// temp is allowed to be NULL if p < DFTP_GENERIC_SIZE +template void dftp (ring* y, hShort_t tupSize, hDim_t lts, hDim_t rts, + hDim_t p, hDim_t rustride, ring* ru, ring* tempSpace) +{ + hDim_t tensorOffset; + + if(p == 2) { + hDim_t temp1 = rts<<1; + + for(hDim_t blockOffset = 0; blockOffset < lts; blockOffset++) { + hDim_t temp2 = blockOffset*temp1; + for(hDim_t modOffset = 0; modOffset < rts; modOffset++) { + tensorOffset = temp2 + modOffset; + ring u = y[tensorOffset*tupSize]; + ring t = y[(tensorOffset+rts)*tupSize]; + y[tensorOffset*tupSize] = u + t; + y[(tensorOffset+rts)*tupSize] = u - t; + } + } + } + else if(p == 3) { + ring ru1 = ru[rustride*tupSize]; + ring ru2 = ru[(rustride<<1)*tupSize]; + hDim_t temp1 = rts*3; + + for(hDim_t blockOffset = 0; blockOffset < lts; blockOffset++) { + hDim_t temp2 = blockOffset*temp1; + for(hDim_t modOffset = 0; modOffset < rts; modOffset++) { + tensorOffset = temp2 + modOffset; + ring y1, y2, y3; + y1 = y[tensorOffset*tupSize]; + y2 = y[(tensorOffset+rts)*tupSize]; + y3 = y[(tensorOffset+(rts<<1))*tupSize]; + //q is <32 bits, so we can do 3 additions without overflow + y[tensorOffset*tupSize] += (y2 + y3); + y[(tensorOffset+rts)*tupSize] = y1 + (ru1*y2) + (ru2*y3); + y[(tensorOffset+(rts<<1))*tupSize] = y1 + (ru2*y2) + (ru1*y3); + } + } + } + else if(p == 5) { + hDim_t temp1 = rts*5; + ring ru1 = ru[rustride*tupSize]; + ring ru2 = ru[(rustride<<1)*tupSize]; + ring ru3 = ru[(rustride*3)*tupSize]; + ring ru4 = ru[(rustride<<2)*tupSize]; + + for(hDim_t blockOffset = 0; blockOffset < lts; blockOffset++) { + hDim_t temp2 = blockOffset*temp1; + for(hDim_t modOffset = 0; modOffset < rts; modOffset++) { + tensorOffset = temp2 + modOffset; + ring y1, y2, y3, y4, y5; + y1 = y[tensorOffset*tupSize]; + y2 = y[(tensorOffset+rts)*tupSize]; + y3 = y[(tensorOffset+(rts<<1))*tupSize]; + y4 = y[(tensorOffset+3*rts)*tupSize]; + y5 = y[(tensorOffset+(rts<<2))*tupSize]; + y[tensorOffset*tupSize] += y2 + y3 + y4 + y5; + y[(tensorOffset+rts)*tupSize] = y1 + (ru1*y2) + (ru2*y3) + (ru3*y4) + (ru4*y5); + y[(tensorOffset+(rts<<1))*tupSize] = y1 + (ru2*y2) + (ru4*y3) + (ru1*y4) + (ru3*y5); + y[(tensorOffset+rts*3)*tupSize] = y1 + (ru3*y2) + (ru1*y3) + (ru4*y4) + (ru2*y5); + y[(tensorOffset+(rts<<2))*tupSize] = y1 + (ru4*y2) + (ru3*y3) + (ru2*y4) + (ru1*y5); + } + } + } + else if(p == 7) { + hDim_t temp1 = rts*7; + ring ru1 = ru[rustride*tupSize]; + ring ru2 = ru[(rustride<<1)*tupSize]; + ring ru3 = ru[(rustride*3)*tupSize]; + ring ru4 = ru[(rustride<<2)*tupSize]; + ring ru5 = ru[(rustride*5)*tupSize]; + ring ru6 = ru[(rustride*6)*tupSize]; + + for(hDim_t blockOffset = 0; blockOffset < lts; blockOffset++) { + hDim_t temp2 = blockOffset*temp1; + for(hDim_t modOffset = 0; modOffset < rts; modOffset++) { + tensorOffset = temp2 + modOffset; + ring y1, y2, y3, y4, y5, y6, y7; + y1 = y[tensorOffset*tupSize]; + y2 = y[(tensorOffset+rts)*tupSize]; + y3 = y[(tensorOffset+(rts<<1))*tupSize]; + y4 = y[(tensorOffset+3*rts)*tupSize]; + y5 = y[(tensorOffset+(rts<<2))*tupSize]; + y6 = y[(tensorOffset+rts*5)*tupSize]; + y7 = y[(tensorOffset+rts*6)*tupSize]; + y[tensorOffset*tupSize] += y2 + y3 + y4 + y5 + y6 + y7; + y[(tensorOffset+rts)*tupSize] = y1 + (ru1*y2) + (ru2*y3) + (ru3*y4) + (ru4*y5) + (ru5*y6) + (ru6*y7); + y[(tensorOffset+(rts<<1))*tupSize] = y1 + (ru2*y2) + (ru4*y3) + (ru6*y4) + (ru1*y5) + (ru3*y6) + (ru5*y7); + y[(tensorOffset+rts*3)*tupSize] = y1 + (ru3*y2) + (ru6*y3) + (ru2*y4) + (ru5*y5) + (ru1*y6) + (ru4*y7); + y[(tensorOffset+(rts<<2))*tupSize] = y1 + (ru4*y2) + (ru1*y3) + (ru5*y4) + (ru2*y5) + (ru6*y6) + (ru3*y7); + y[(tensorOffset+rts*5)*tupSize] = y1 + (ru5*y2) + (ru3*y3) + (ru1*y4) + (ru6*y5) + (ru4*y6) + (ru2*y7); + y[(tensorOffset+rts*6)*tupSize] = y1 + (ru6*y2) + (ru5*y3) + (ru4*y4) + (ru3*y5) + (ru2*y6) + (ru1*y7); + } + } + } + else { + hDim_t temp1 = rts*p; + for(hDim_t blockOffset = 0; blockOffset < lts; blockOffset++) { + hDim_t temp2 = blockOffset*temp1; + for(hDim_t modOffset = 0; modOffset < rts; modOffset++) { + tensorOffset = temp2 + modOffset; + for(hDim_t row = 0; row < p; row++) { + tempSpace[row] = 0; + //p is small (<< 30 bits), so we can do p additions of mod-q values without overflow + for(hDim_t col = 0; col < p; col++) { + tempSpace[row] += (y[(tensorOffset+col*rts)*tupSize]*ru[((col*row) % p)*rustride*tupSize]); + } + } + + for(hDim_t row = 0; row < p; row++) { + y[(tensorOffset+rts*row)*tupSize] = tempSpace[row]; + } + } + } + } +} + +template void crtp (ring* y, hShort_t tupSize, hDim_t lts, hDim_t rts, + hDim_t p, hDim_t rustride, ring* ru) +{ + hDim_t tensorOffset; + if(p == 2) { + return; + } + else if(p == 3) { + hDim_t temp1 = rts*2; + ring ru1 = ru[rustride*tupSize]; + ring ru2 = ru[(rustride<<1)*tupSize]; + + for(hDim_t blockOffset = 0; blockOffset < lts; blockOffset++) { + hDim_t temp2 = blockOffset*temp1; + for(hDim_t modOffset = 0; modOffset < rts; modOffset++) { + tensorOffset = temp2 + modOffset; + ring y1, y2; + y1 = y[tensorOffset*tupSize]; + y2 = y[(tensorOffset+rts)*tupSize]; + y[tensorOffset*tupSize] += (ru1*y2); + y[(tensorOffset+rts)*tupSize] = y1 + (ru2*y2); + } + } + } + else if(p == 5) { + hDim_t temp1 = rts*4; + ring ru1 = ru[rustride*tupSize]; + ring ru2 = ru[(rustride<<1)*tupSize]; + ring ru3 = ru[(rustride*3)*tupSize]; + ring ru4 = ru[(rustride<<2)*tupSize]; + + for(hDim_t blockOffset = 0; blockOffset < lts; blockOffset++) { + hDim_t temp2 = blockOffset*temp1; + for(hDim_t modOffset = 0; modOffset < rts; modOffset++) { + tensorOffset = temp2 + modOffset; + ring y1, y2, y3, y4; + y1 = y[tensorOffset*tupSize]; + y2 = y[(tensorOffset+rts)*tupSize]; + y3 = y[(tensorOffset+(rts<<1))*tupSize]; + y4 = y[(tensorOffset+3*rts)*tupSize]; + + y[tensorOffset*tupSize] += ((ru1*y2) + (ru2*y3) + (ru3*y4)); + y[(tensorOffset+rts)*tupSize] = y1 + (ru2*y2) + (ru4*y3) + (ru1*y4); + y[(tensorOffset+(rts<<1))*tupSize] = y1 + (ru3*y2) + (ru1*y3) + (ru4*y4); + y[(tensorOffset+rts*3)*tupSize] = y1 + (ru4*y2) + (ru3*y3) + (ru2*y4); + } + } + } + else if(p == 7) { + hDim_t temp1 = rts*6; + ring ru1 = ru[rustride*tupSize]; + ring ru2 = ru[(rustride<<1)*tupSize]; + ring ru3 = ru[(rustride*3)*tupSize]; + ring ru4 = ru[(rustride<<2)*tupSize]; + ring ru5 = ru[(rustride*5)*tupSize]; + ring ru6 = ru[(rustride*6)*tupSize]; + for(hDim_t blockOffset = 0; blockOffset < lts; blockOffset++) { + hDim_t temp2 = blockOffset*temp1; + for(hDim_t modOffset = 0; modOffset < rts; modOffset++) { + tensorOffset = temp2 + modOffset; + ring y1, y2, y3, y4, y5, y6; + y1 = y[tensorOffset*tupSize]; + y2 = y[(tensorOffset+rts)*tupSize]; + y3 = y[(tensorOffset+(rts<<1))*tupSize]; + y4 = y[(tensorOffset+3*rts)*tupSize]; + y5 = y[(tensorOffset+(rts<<2))*tupSize]; + y6 = y[(tensorOffset+rts*5)*tupSize]; + y[tensorOffset*tupSize] += ((ru1*y2) + (ru2*y3) + (ru3*y4) + (ru4*y5) + (ru5*y6)); + y[(tensorOffset+rts)*tupSize] = y1 + (ru2*y2) + (ru4*y3) + (ru6*y4) + (ru1*y5) + (ru3*y6); + y[(tensorOffset+(rts<<1))*tupSize] = y1 + (ru3*y2) + (ru6*y3) + (ru2*y4) + (ru5*y5) + (ru1*y6); + y[(tensorOffset+rts*3)*tupSize] = y1 + (ru4*y2) + (ru1*y3) + (ru5*y4) + (ru2*y5) + (ru6*y6); + y[(tensorOffset+(rts<<2))*tupSize] = y1 + (ru5*y2) + (ru3*y3) + (ru1*y4) + (ru6*y5) + (ru4*y6); + y[(tensorOffset+rts*5)*tupSize] = y1 + (ru6*y2) + (ru5*y3) + (ru4*y4) + (ru3*y5) + (ru2*y6); + } + } + } + else { + ring* tempSpace = (ring*)malloc((p-1)*sizeof(ring)); + hDim_t temp1 = rts*(p-1); + for(hDim_t blockOffset = 0; blockOffset < lts; blockOffset++) { + hDim_t temp2 = blockOffset*temp1; + for(hDim_t modOffset = 0; modOffset < rts; modOffset++) { + tensorOffset = temp2 + modOffset; + + for(hDim_t row = 1; row < p; row++) { + tempSpace[row-1] = 0; + for(hDim_t col = 0; col < p-1; col++) { + tempSpace[row-1] += (y[(tensorOffset+col*rts)*tupSize]*ru[((col*row) % p)*rustride*tupSize]); + } + } + + for(hDim_t row = 0; row < p-1; row++) { + y[(tensorOffset+rts*row)*tupSize] = tempSpace[row]; + } + } + } + free(tempSpace); + } +} + +//takes inverse rus +template void crtpinv (ring* y, hShort_t tupSize, hDim_t lts, hDim_t rts, + hDim_t p, hDim_t rustride, ring* ruinv) +{ + if(p ==2) { + // need this case so that we can divide overall by mhat^(-1) + return; + } + else { + hDim_t tensorOffset,i; + ring* tempSpace = (ring*)malloc((p-1)*sizeof(ring)); + hDim_t temp1 = rts*(p-1); + for(hDim_t blockOffset = 0; blockOffset < lts; blockOffset++) { + hDim_t temp2 = blockOffset*temp1; + for(hDim_t modOffset = 0; modOffset < rts; modOffset++) { + tensorOffset = temp2 + modOffset; + + for(i = 0; i < p-1; i++) { + tempSpace[i] = (int)0; + int j; + for(j = 0; j < p-1; j++) { + int ruIdx = ((j+1)*i) % p; + tempSpace[i] += (y[(tensorOffset+j*rts)*tupSize] * ruinv[ruIdx*rustride*tupSize]); + } + } + + ring shift; // can't assign to a constant on the same line(?) + shift=0; + for(i = 0; i < p-1; i++) { + // we were given the inverse rus, so we need to negate the indices + shift += (y[(tensorOffset+i*rts)*tupSize] * ruinv[rustride*(p-(i+1))*tupSize]); + } + + for(i = 0; i < p-1; i++) { + y[(tensorOffset+i*rts)*tupSize] = tempSpace[i] - shift; + } + } + } + } +} + +template void ppDFT (ring* y, hShort_t tupSize, hDim_t lts, hDim_t rts, + PrimeExponent pe, hDim_t rustride, ring* ru, ring* temp) +{ + hDim_t p = pe.prime; + hShort_t e = pe.exponent; + + if(e == 0) { + return; + } + + hDim_t primeRuStride = rustride*ipow(p,e-1); + + hShort_t i; + + hDim_t ltsScale = ipow(p,e-1); + hDim_t rtsScale = 1; + hDim_t twidRuStride = rustride; + for(i = 0; i < e; i++) { + hDim_t rtsDim = rts*rtsScale; + dftp (y, tupSize, lts*ltsScale, rtsDim, p, primeRuStride, ru, temp); + dftTwiddle (y, tupSize, lts, rtsDim, pe, ltsScale*p, twidRuStride, ru); + + ltsScale /= p; + rtsScale *= p; + twidRuStride *= p; + pe.exponent -= 1; + } +} + +template void ppDFTInv (ring* y, hShort_t tupSize, hDim_t lts, hDim_t rts, + PrimeExponent pe, hDim_t rustride, ring* ru, ring* temp) +{ + hDim_t p = pe.prime; + hShort_t e = pe.exponent; + + if(e == 0) { + return; + } + hDim_t primeRuStride = rustride*ipow(p,e-1); + + hShort_t i; + + hDim_t ltsScale = 1; + hDim_t rtsScale = ipow(p,e-1); + hDim_t twidRuStride = primeRuStride; + pe.exponent = 1; + for(i = 0; i < e; i++) { + hDim_t rtsDim = rts*rtsScale; + hDim_t ltsScaleP = ltsScale*p; + dftTwiddle (y, tupSize, lts, rtsDim, pe, ltsScaleP, twidRuStride, ru); + dftp (y, tupSize, lts*ltsScale, rtsDim, p, primeRuStride, ru, temp); + + ltsScale = ltsScaleP; + rtsScale /= p; + twidRuStride /= p; + pe.exponent += 1; + } +} + +template void ppcrt (ring* y, hShort_t tupSize, hDim_t lts, hDim_t rts, + PrimeExponent pe, ring* ru) +{ + hDim_t p = pe.prime; + hDim_t e = pe.exponent; + hDim_t mprime = ipow(p,e-1); + ring* temp = 0; + if(p >= DFTP_GENERIC_SIZE) { + temp = (ring*)malloc(p*sizeof(ring)); + } + + crtp (y, tupSize, lts*mprime, rts, p, mprime, ru); + crtTwiddle (y, tupSize, lts, rts, pe, ru); + pe.exponent -= 1; + ppDFT (y, tupSize, lts, rts*(p-1), pe, p, ru, temp); + pe.exponent += 1; + + if(p >= DFTP_GENERIC_SIZE) { + free(temp); + } +} + +template void ppcrtinv (ring* y, hShort_t tupSize, hDim_t lts, hDim_t rts, + PrimeExponent pe, ring* ru) +{ + hDim_t p = pe.prime; + hDim_t e = pe.exponent; + hDim_t mprime = ipow(p,e-1); + ring* temp = 0; + if(p >= DFTP_GENERIC_SIZE) { + temp = (ring*)malloc(p*sizeof(ring)); + } + + pe.exponent -= 1; + ppDFTInv (y, tupSize, lts, rts*(p-1), pe, p, ru, temp); + pe.exponent += 1; + crtTwiddle (y, tupSize, lts, rts, pe, ru); + crtpinv (y, tupSize, lts*mprime, rts, p, mprime, ru); + + if(p >= DFTP_GENERIC_SIZE) { + free(temp); + } +} + +extern "C" void tensorCRTRq (hShort_t tupSize, Zq* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, Zq** ru, hInt_t* qs) +{ + tensorFuserCRT (y, tupSize, ppcrt, totm, peArr, sizeOfPE, ru, qs); + canonicalizeZq(y,tupSize,totm,qs); +} + +//takes inverse rus +extern "C" void tensorCRTInvRq (hShort_t tupSize, Zq* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, + Zq** ruinv, Zq* mhatInv, hInt_t* qs) +{ + tensorFuserCRT (y, tupSize, ppcrtinv, totm, peArr, sizeOfPE, ruinv, qs); + for (hShort_t i = 0; i < tupSize; i++) { + Zq::q = qs[i]; + for (hDim_t j = 0; j < totm; j++) { + //careful here! I'm not setting the global q, so I can't rely on Zq multiplication + y[j*tupSize+i] = y[j*tupSize+i]*mhatInv[i]; + } + } + canonicalizeZq(y,tupSize,totm,qs); +} + +extern "C" void tensorCRTC (hShort_t tupSize, Complex* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, Complex** ru) +{ + tensorFuserCRT (y, tupSize, ppcrt, totm, peArr, sizeOfPE, ru, (hInt_t*)0); +} + +//takes inverse rus +extern "C" void tensorCRTInvC (hShort_t tupSize, Complex* y, hDim_t totm, PrimeExponent* peArr, + hShort_t sizeOfPE, Complex** ruinv, Complex* mhatInv) +{ + tensorFuserCRT (y, tupSize, ppcrtinv, totm, peArr, sizeOfPE, ruinv, (hInt_t*)0); + for (hShort_t i = 0; i < tupSize; i++) { + for (hDim_t j = 0; j < totm; j++) { + y[j*tupSize+i] *= mhatInv[i]; + } + } +} diff --git a/Crypto/Lol/Cyclotomic/Tensor/CTensor/g.c b/Crypto/Lol/Cyclotomic/Tensor/CTensor/g.c deleted file mode 100644 --- a/Crypto/Lol/Cyclotomic/Tensor/CTensor/g.c +++ /dev/null @@ -1,828 +0,0 @@ -#include "tensorTypes.h" - - -void gPowR (hInt_t* y, hShort_t tupSize, hDim_t lts, hDim_t rts, hDim_t p) -{ - hDim_t tmp1 = rts*(p-1); - hDim_t tmp2 = tmp1 - rts; - hDim_t blockOffset, modOffset; - hDim_t i; - for (blockOffset = 0; blockOffset < lts; ++blockOffset) - { - hDim_t tmp3 = blockOffset * tmp1; - for (modOffset = 0; modOffset < rts; ++modOffset) - { - hDim_t tensorOffset = tmp3 + modOffset; - hInt_t last = y[(tensorOffset + tmp2)*tupSize]; - for (i = p-2; i != 0; --i) - { - hDim_t idx = tensorOffset + i * rts; - y[idx*tupSize] += last - y[(idx-rts)*tupSize]; - } - y[tensorOffset*tupSize] += last; - } - } -} - -void gPowRq (hInt_t* y, hShort_t tupSize, hDim_t lts, hDim_t rts, hDim_t p, hInt_t q) -{ - hDim_t tmp1 = rts*(p-1); - hDim_t tmp2 = tmp1 - rts; - hDim_t blockOffset, modOffset; - hDim_t i; - for (blockOffset = 0; blockOffset < lts; ++blockOffset) - { - hDim_t tmp3 = blockOffset * tmp1; - for (modOffset = 0; modOffset < rts; ++modOffset) - { - hDim_t tensorOffset = tmp3 + modOffset; - hInt_t last = y[(tensorOffset + tmp2)*tupSize]; - for (i = p-2; i != 0; --i) - { - hDim_t idx = tensorOffset + i * rts; - y[idx*tupSize] = (y[idx*tupSize] + last - y[(idx-rts)*tupSize]) % q; - } - y[tensorOffset*tupSize] = (y[tensorOffset*tupSize] + last) % q; - } - } -} - -void gPowC (complex_t* y, hShort_t tupSize, hDim_t lts, hDim_t rts, hDim_t p) -{ - hDim_t tmp1 = rts*(p-1); - hDim_t tmp2 = tmp1 - rts; - hDim_t blockOffset, modOffset; - hDim_t i; - for (blockOffset = 0; blockOffset < lts; ++blockOffset) - { - hDim_t tmp3 = blockOffset * tmp1; - for (modOffset = 0; modOffset < rts; ++modOffset) - { - hDim_t tensorOffset = tmp3 + modOffset; - complex_t last = y[(tensorOffset + tmp2)*tupSize]; - for (i = p-2; i != 0; --i) - { - hDim_t idx = tensorOffset + i * rts; - CMPLX_IADD(y[idx*tupSize],last); - CMPLX_ISUB(y[idx*tupSize],y[(idx-rts)*tupSize]); - } - CMPLX_IADD(y[tensorOffset*tupSize],last); - } - } -} - -void ppGPowR (void* y, hShort_t tupSize, PrimeExponent pe, hDim_t lts, hDim_t rts, hInt_t* qs) -{ -#ifdef DEBUG_MODE - ASSERT (q==0); -#endif - hDim_t p = pe.prime; - hShort_t e = pe.exponent; - - if (p != 2) - { - for(int tupIdx = 0; tupIdx < tupSize; tupIdx++) { - gPowR (((hInt_t*)y)+tupIdx, tupSize, lts*ipow(p,e-1), rts, p); - } - } -} - -void ppGPowRq (void* y, hShort_t tupSize, PrimeExponent pe, hDim_t lts, hDim_t rts, hInt_t* qs) -{ - hDim_t p = pe.prime; - hShort_t e = pe.exponent; - if (p != 2) - { - for(int tupIdx = 0; tupIdx < tupSize; tupIdx++) { - gPowRq (((hInt_t*)y)+tupIdx, tupSize, lts*ipow(p,e-1), rts, p, qs[tupIdx]); - } - } -} - -void ppGPowC (void* y, hShort_t tupSize, PrimeExponent pe, hDim_t lts, hDim_t rts, hInt_t* qs) -{ - hDim_t p = pe.prime; - hShort_t e = pe.exponent; - if (p != 2) - { - for(int tupIdx = 0; tupIdx < tupSize; tupIdx++) { - gPowC (((complex_t*)y)+tupIdx, tupSize, lts*ipow(p,e-1), rts, p); - } - } -} - -void gDecR (hInt_t* y, hShort_t tupSize, hDim_t lts, hDim_t rts, hDim_t p) -{ - hDim_t tmp1 = rts*(p-1); - hDim_t blockOffset; - hDim_t modOffset; - hDim_t i; - - for (blockOffset = 0; blockOffset < lts; ++blockOffset) - { - hDim_t tmp2 = blockOffset * tmp1; - for (modOffset = 0; modOffset < rts; ++modOffset) - { - hDim_t tensorOffset = tmp2 + modOffset; - hInt_t acc = y[tensorOffset*tupSize]; - for (i = p-2; i != 0; --i) - { - hDim_t idx = tensorOffset + i * rts; - acc += y[idx*tupSize]; - y[idx*tupSize] -= y[(idx-rts)*tupSize]; - } - y[tensorOffset*tupSize] += acc; - } - } -} - -void gDecRq (hInt_t* y, hShort_t tupSize, hDim_t lts, hDim_t rts, hDim_t p, hInt_t q) -{ - hDim_t tmp1 = rts*(p-1); - hDim_t blockOffset; - hDim_t modOffset; - hDim_t i; - - for (blockOffset = 0; blockOffset < lts; ++blockOffset) - { - hDim_t tmp2 = blockOffset * tmp1; - for (modOffset = 0; modOffset < rts; ++modOffset) - { - hDim_t tensorOffset = tmp2 + modOffset; - hInt_t acc = y[tensorOffset*tupSize]; - for (i = p-2; i != 0; --i) - { - hDim_t idx = tensorOffset + i * rts; - // acc is at most p*q << 64 bits, so no need to mod - acc = acc + y[idx*tupSize]; - y[idx*tupSize] = (y[idx*tupSize] - y[(idx-rts)*tupSize]) % q; - } - y[tensorOffset*tupSize] = (y[tensorOffset*tupSize] + acc) % q; - } - } -} - -void ppGDecR (void* y, hShort_t tupSize, PrimeExponent pe, hDim_t lts, hDim_t rts, hInt_t* qs) -{ -#ifdef DEBUG_MODE - ASSERT (q==0); -#endif - hDim_t p = pe.prime; - hShort_t e = pe.exponent; - if (p != 2) - { - for(int tupIdx = 0; tupIdx < tupSize; tupIdx++) { - gDecR (((hInt_t*)y)+tupIdx, tupSize, lts*ipow(p,e-1), rts, p); - } - } -} - -void ppGDecRq (void* y, hShort_t tupSize, PrimeExponent pe, hDim_t lts, hDim_t rts, hInt_t* qs) -{ - hDim_t p = pe.prime; - hShort_t e = pe.exponent; - if (p != 2) - { - for(int tupIdx = 0; tupIdx < tupSize; tupIdx++) { - gDecRq (((hInt_t*)y)+tupIdx, tupSize, lts*ipow(p,e-1), rts, p, qs[tupIdx]); - } - } -} - - -void gInvPowR (hInt_t* y, hShort_t tupSize, hDim_t lts, hDim_t rts, hDim_t p) -{ - hDim_t tmp1 = rts * (p-1); - hDim_t blockOffset, modOffset; - hDim_t i; - - for (blockOffset = 0; blockOffset < lts; ++blockOffset) - { - hDim_t tmp2 = blockOffset * tmp1; - for (modOffset = 0; modOffset < rts; ++modOffset) - { - hDim_t tensorOffset = tmp2 + modOffset; - hInt_t lelts = 0; - for (i = 0; i < p-1; ++i) - { - lelts += y[(tensorOffset + i*rts)*tupSize]; - } - hInt_t relts = 0; - for (i = p-2; i >= 0; --i) - { - hDim_t idx = tensorOffset + i*rts; - hInt_t z = y[idx*tupSize]; - y[idx*tupSize] = (p-1-i) * lelts - (i+1)*relts; - lelts -= z; - relts += z; - } - } - } -} - -void gInvPowRq (hInt_t* y, hShort_t tupSize, hDim_t lts, hDim_t rts, hDim_t p, hInt_t q) -{ - hDim_t tmp1 = rts * (p-1); - hDim_t blockOffset, modOffset; - hDim_t i; - - for (blockOffset = 0; blockOffset < lts; ++blockOffset) - { - hDim_t tmp2 = blockOffset * tmp1; - for (modOffset = 0; modOffset < rts; ++modOffset) - { - hDim_t tensorOffset = tmp2 + modOffset; - hInt_t lelts = 0; - //lelts is at most p*q, so we can mod once at the end - for (i = 0; i < p-1; ++i) - { - lelts = lelts + y[(tensorOffset + i*rts)*tupSize]; - } - lelts = lelts % q; - //in the next loop, lelts <= p*q and relts <= p*q - //products are <= p*p*q, and diff is <= 2*p*p*q - //so we assume 2*p^2 << 31 bits - hInt_t relts = 0; - for (i = p-2; i >= 0; --i) - { - hDim_t idx = tensorOffset + i*rts; - hInt_t z = y[idx*tupSize]; - y[idx*tupSize] = (((p-1-i) * lelts) - ((i+1)*relts)) % q; - lelts -= z; - relts += z; - } - } - } -} - -void gInvPowC (complex_t* y, hShort_t tupSize, hDim_t lts, hDim_t rts, hDim_t p) -{ - hDim_t tmp1 = rts * (p-1); - hDim_t blockOffset, modOffset; - hDim_t i; - - for (blockOffset = 0; blockOffset < lts; ++blockOffset) - { - hDim_t tmp2 = blockOffset * tmp1; - for (modOffset = 0; modOffset < rts; ++modOffset) - { - hDim_t tensorOffset = tmp2 + modOffset; - complex_t lelts = ((complex_t){0, 0});; - for (i = 0; i < p-1; ++i) - { - CMPLX_IADD(lelts,y[(tensorOffset + i*rts)*tupSize]); - } - complex_t relts = ((complex_t){0, 0});; - for (i = p-2; i >= 0; --i) - { - hDim_t idx = tensorOffset + i*rts; - complex_t z = y[idx*tupSize]; - - complex_t c1 = ((complex_t){p-1-i, 0}); - complex_t c2 = ((complex_t){i+1, 0}); - complex_t t1 = CMPLX_MUL(c1, lelts); - complex_t t2 = CMPLX_MUL(c2, relts); - y[idx*tupSize] = CMPLX_SUB(t1,t2); - CMPLX_ISUB(lelts,z); - CMPLX_IADD(relts,z); - } - } - } -} - -void ppGInvPowR (void* y, hShort_t tupSize, PrimeExponent pe, hDim_t lts, hDim_t rts, hInt_t* qs) -{ -#ifdef DEBUG_MODE - ASSERT (q==0); -#endif - hDim_t p = pe.prime; - hShort_t e = pe.exponent; - if (p != 2) - { - for(int tupIdx = 0; tupIdx < tupSize; tupIdx++) { - gInvPowR (((hInt_t*)y)+tupIdx, tupSize, lts*ipow(p,e-1), rts, p); - } - } -} - -void ppGInvPowRq (void* y, hShort_t tupSize, PrimeExponent pe, hDim_t lts, hDim_t rts, hInt_t* qs) -{ - hDim_t p = pe.prime; - hShort_t e = pe.exponent; - if (p != 2) - { - for(int tupIdx = 0; tupIdx < tupSize; tupIdx++) { - gInvPowRq (((hInt_t*)y)+tupIdx, tupSize, lts*ipow(p,e-1), rts, p, qs[tupIdx]); - } - } -} - -void ppGInvPowC (void* y, hShort_t tupSize, PrimeExponent pe, hDim_t lts, hDim_t rts, hInt_t* qs) -{ -#ifdef DEBUG_MODE - ASSERT (q==0); -#endif - hDim_t p = pe.prime; - hShort_t e = pe.exponent; - if (p != 2) - { - for(int tupIdx = 0; tupIdx < tupSize; tupIdx++) { - gInvPowC (((complex_t*)y)+tupIdx, tupSize, lts*ipow(p,e-1), rts, p); - } - } -} - -//do not call for p=2! -void gCRTRq (hInt_t* y, hShort_t tupSize, hDim_t lts, hDim_t rts, hDim_t p, hInt_t* gcoeffs, hInt_t q) -{ - hDim_t gindex; - hDim_t blockOffset, modOffset, idx; - hDim_t temp1 = rts*(p-1); - - for(gindex = 0; gindex < p-1; gindex++) - { - hInt_t coeff = gcoeffs[gindex*tupSize]; - hDim_t temp3 = gindex*rts; - for(blockOffset = 0; blockOffset < lts; blockOffset++) - { - hDim_t temp2 = blockOffset*temp1 + temp3; - for(modOffset = 0; modOffset < rts; modOffset++) - { - idx = temp2 + modOffset; - y[idx*tupSize] = (y[idx*tupSize]*coeff)%q; - } - } - } -} - -//do not call for p=2! -void gCRTC (complex_t* y, hShort_t tupSize, hDim_t lts, hDim_t rts, hDim_t p, complex_t* gcoeffs) -{ - hDim_t gindex; - hDim_t blockOffset, modOffset, idx; - hDim_t temp1 = rts*(p-1); - - for(gindex = 0; gindex < p-1; gindex++) - { - complex_t coeff = gcoeffs[gindex*tupSize]; - hDim_t temp3 = gindex*rts; - for(blockOffset = 0; blockOffset < lts; blockOffset++) - { - hDim_t temp2 = blockOffset*temp1 + temp3; - for(modOffset = 0; modOffset < rts; modOffset++) - { - idx = temp2 + modOffset; - CMPLX_IMUL(y[idx*tupSize],coeff); - } - } - } -} - -void ppGCRTRq (void* y, hShort_t tupSize, hDim_t lts, hDim_t rts, PrimeExponent pe, void* gcoeffs, hInt_t* qs) -{ - hDim_t p = pe.prime; - hShort_t e = pe.exponent; - -#ifdef DEBUG_MODE - printf("gcoeffs for p=%" PRId32 ", e=%" PRId16 "\t[", pe.prime, pe.exponent); - int i; - for(i = 0; i < ((p-1)*ipow(p,e-1)); i++) { - printf("%" PRId64 ",", ((hInt_t*)gcoeffs)[i]); - } - printf("]\n"); -#endif - - if (p != 2) - { - for(int tupIdx = 0; tupIdx < tupSize; tupIdx++) { - gCRTRq (((hInt_t*)y)+tupIdx, tupSize, lts*ipow(p,e-1), rts, p, ((hInt_t*)gcoeffs)+tupIdx, qs[tupIdx]); - } - } -} - -void ppGCRTC (void* y, hShort_t tupSize, hDim_t lts, hDim_t rts, PrimeExponent pe, void* gcoeffs, hInt_t* qs) -{ - hDim_t p = pe.prime; - hShort_t e = pe.exponent; - -#ifdef DEBUG_MODE - printf("gcoeffs for p=%" PRId32 ", e=%" PRId16 "\t[", pe.prime, pe.exponent); - int i; - for(i = 0; i < ((p-1)*ipow(p,e-1)); i++) { - printf("(%f,%f),", ((complex_t*)gcoeffs)[i].real, ((complex_t*)gcoeffs)[i].imag); - } - printf("]\n"); -#endif - - if (p != 2) - { - for(int tupIdx = 0; tupIdx < tupSize; tupIdx++) { - gCRTC (((complex_t*)y)+tupIdx, tupSize, lts*ipow(p,e-1), rts, p, ((complex_t*)gcoeffs)+tupIdx); - } - } -} - -void gInvDecR (hInt_t* y, hShort_t tupSize, hDim_t lts, hDim_t rts, hDim_t p) -{ - hDim_t blockOffset; - hDim_t modOffset; - hDim_t i; - hDim_t tmp1 = rts*(p-1); - - for (blockOffset = 0; blockOffset < lts; ++blockOffset) - { - hDim_t tmp2 = blockOffset*tmp1; - for (modOffset = 0; modOffset < rts; ++modOffset) - { - hDim_t tensorOffset = tmp2 + modOffset; - hInt_t lastOut = 0; - for (i=1; i < p; ++i) - { - lastOut += i * y[(tensorOffset + (i-1)*rts)*tupSize]; - } - hInt_t acc = lastOut / p; - ASSERT (acc * p == lastOut); // this line asserts that lastOut % p == 0, without calling % operator - for (i = p-2; i > 0; --i) - { - hDim_t idx = tensorOffset + i*rts; - hInt_t tmp = acc; - acc -= y[idx*tupSize]; // we already divided acc by p, do not multiply y[idx] by p - y[idx*tupSize] = tmp; - } - y[tensorOffset*tupSize] = acc; - } - } -} - -void gInvDecRq (hInt_t* y, hShort_t tupSize, hDim_t lts, hDim_t rts, hDim_t p, hInt_t q) -{ - hDim_t blockOffset; - hDim_t modOffset; - hDim_t i; - hDim_t tmp1 = rts*(p-1); - hInt_t reciprocalOfP = reciprocal (q,p); - - for (blockOffset = 0; blockOffset < lts; ++blockOffset) - { - hDim_t tmp2 = blockOffset*tmp1; - for (modOffset = 0; modOffset < rts; ++modOffset) - { - hDim_t tensorOffset = tmp2 + modOffset; - hInt_t lastOut = 0; - for (i=1; i < p; ++i) - { - lastOut += (i * y[(tensorOffset + (i-1)*rts)*tupSize]); - } - //in the previous loop, |lastOut| <= p*p*q - lastOut = lastOut % q; - hInt_t acc = (lastOut * reciprocalOfP) % q; - // |acc| <= p*q - for (i = p-2; i > 0; --i) - { - hDim_t idx = tensorOffset + i*rts; - hInt_t tmp = acc; - acc = acc - y[idx*tupSize]; - y[idx*tupSize] = tmp % q; - } - y[tensorOffset*tupSize] = acc % q; - } - } -} - -void ppGInvDecR (void* y, hShort_t tupSize, PrimeExponent pe, hDim_t lts, hDim_t rts, hInt_t* qs) -{ -#ifdef DEBUG_MODE - ASSERT (q==0); -#endif - hDim_t p = pe.prime; - hShort_t e = pe.exponent; - if (p != 2) - { - for(int tupIdx = 0; tupIdx < tupSize; tupIdx++) { - gInvDecR (((hInt_t*)y)+tupIdx, tupSize, lts*ipow(p,e-1), rts, p); - } - } -} - -void ppGInvDecRq (void* y, hShort_t tupSize, PrimeExponent pe, hDim_t lts, hDim_t rts, hInt_t* qs) -{ - hDim_t p = pe.prime; - hShort_t e = pe.exponent; - if (p != 2) - { - for(int tupIdx = 0; tupIdx < tupSize; tupIdx++) { - gInvDecRq (((hInt_t*)y)+tupIdx, tupSize, lts*ipow(p,e-1), rts, p, qs[tupIdx]); - } - } -} - -#ifdef STATS -int gprCtr = 0; -int gprqCtr = 0; -int gdrCtr = 0; -int gdrqCtr = 0; -int giprCtr = 0; -int giprqCtr = 0; -int gidrCtr = 0; -int gidrqCtr = 0; -int gcrqCtr = 0; -int gccCtr = 0; -int gicrqCtr = 0; -int giccCtr = 0; - -struct timespec gprTime = {0,0}; -struct timespec gprqTime = {0,0}; -struct timespec gdrTime = {0,0}; -struct timespec gdrqTime = {0,0}; -struct timespec giprTime = {0,0}; -struct timespec giprqTime = {0,0}; -struct timespec gidrTime = {0,0}; -struct timespec gidrqTime = {0,0}; -struct timespec gcrqTime = {0,0}; -struct timespec gccTime = {0,0}; -#endif - -void tensorGPowR (hShort_t tupSize, hInt_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE) -{ -#ifdef STATS - gprCtr++; - struct timespec s1,t1; - clock_gettime(CLOCK_REALTIME, &s1); -#endif - tensorFuser (y, tupSize, ppGPowR, totm, peArr, sizeOfPE, (hInt_t*)0); - -#ifdef STATS - clock_gettime(CLOCK_REALTIME, &t1); - gprTime = tsAdd(gprTime, tsSubtract(t1,s1)); -#endif -} - -void tensorGPowRq (hShort_t tupSize, hInt_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, hInt_t* qs) -{ -#ifdef STATS - gprqCtr++; - struct timespec s1,t1; - clock_gettime(CLOCK_REALTIME, &s1); -#endif - tensorFuser (y, tupSize, ppGPowRq, totm, peArr, sizeOfPE, qs); - - hDim_t j; - for(int tupIdx = 0; tupIdx void gPow (ring* y, hShort_t tupSize, hDim_t lts, hDim_t rts, hDim_t p) +{ + if (p == 2) {return;} + hDim_t tmp1 = rts*(p-1); + hDim_t tmp2 = tmp1 - rts; + hDim_t blockOffset, modOffset; + hDim_t i; + for (blockOffset = 0; blockOffset < lts; ++blockOffset) { + hDim_t tmp3 = blockOffset * tmp1; + for (modOffset = 0; modOffset < rts; ++modOffset) { + hDim_t tensorOffset = tmp3 + modOffset; + ring last = y[(tensorOffset + tmp2)*tupSize]; + for (i = p-2; i != 0; --i) { + hDim_t idx = tensorOffset + i * rts; + y[idx*tupSize] += (last - y[(idx-rts)*tupSize]); + } + y[tensorOffset*tupSize] += last; + } + } +} + +template void gDec (ring* y, hShort_t tupSize, hDim_t lts, hDim_t rts, hDim_t p) +{ + if (p == 2) {return;} + hDim_t tmp1 = rts*(p-1); + hDim_t blockOffset; + hDim_t modOffset; + hDim_t i; + + for (blockOffset = 0; blockOffset < lts; ++blockOffset) { + hDim_t tmp2 = blockOffset * tmp1; + for (modOffset = 0; modOffset < rts; ++modOffset) { + hDim_t tensorOffset = tmp2 + modOffset; + ring acc = y[tensorOffset*tupSize]; + for (i = p-2; i != 0; --i) { + hDim_t idx = tensorOffset + i * rts; + acc += y[idx*tupSize]; + y[idx*tupSize] -= y[(idx-rts)*tupSize]; + } + y[tensorOffset*tupSize] += acc; + } + } +} + +template void gInvPow (ring* y, hShort_t tupSize, hDim_t lts, hDim_t rts, hDim_t p) +{ + if (p == 2) {return;} + hDim_t tmp1 = rts * (p-1); + hDim_t blockOffset, modOffset; + hDim_t i; + + for (blockOffset = 0; blockOffset < lts; ++blockOffset) { + hDim_t tmp2 = blockOffset * tmp1; + for (modOffset = 0; modOffset < rts; ++modOffset) { + hDim_t tensorOffset = tmp2 + modOffset; + ring lelts; + lelts = 0; + for (i = 0; i < p-1; ++i) { + lelts += y[(tensorOffset + i*rts)*tupSize]; + } + ring relts; + relts = 0; + for (i = p-2; i >= 0; --i) { + hDim_t idx = tensorOffset + i*rts; + ring z = y[idx*tupSize]; + ring lmul, rmul; + lmul = p-1-i; + rmul = i+1; + y[idx*tupSize] = lmul * lelts - rmul * relts; + lelts -= z; + relts += z; + } + } + } +} + +template void gInvDec (ring* y, hShort_t tupSize, hDim_t lts, hDim_t rts, hDim_t p) +{ + if (p == 2) {return;} + hDim_t blockOffset; + hDim_t modOffset; + hDim_t i; + hDim_t tmp1 = rts*(p-1); + + for (blockOffset = 0; blockOffset < lts; ++blockOffset) { + hDim_t tmp2 = blockOffset*tmp1; + for (modOffset = 0; modOffset < rts; ++modOffset) { + hDim_t tensorOffset = tmp2 + modOffset; + ring lastOut; + lastOut = 0; + for (i=1; i < p; ++i) { + ring ri; + ri = i; + lastOut += (ri * y[(tensorOffset + (i-1)*rts)*tupSize]); + } + ring rp; + rp = p; + ring acc = lastOut / rp; + ASSERT ((acc * rp) == lastOut); // this line asserts that lastOut % p == 0, without calling % operator + for (i = p-2; i > 0; --i) { + hDim_t idx = tensorOffset + i*rts; + ring tmp = acc; + acc -= y[idx*tupSize]; // we already divided acc by p, do not multiply y[idx] by p + y[idx*tupSize] = tmp; + } + y[tensorOffset*tupSize] = acc; + } + } +} + +extern "C" void tensorGPowR (hShort_t tupSize, hInt_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE) +{ + tensorFuserPrime (y, tupSize, gPow, totm, peArr, sizeOfPE, (hInt_t*)0); +} + +extern "C" void tensorGPowRq (hShort_t tupSize, Zq* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, hInt_t* qs) +{ + tensorFuserPrime (y, tupSize, gPow, totm, peArr, sizeOfPE, qs); + canonicalizeZq(y,tupSize,totm,qs); +} + +extern "C" void tensorGPowC (hShort_t tupSize, Complex* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE) +{ + tensorFuserPrime (y, tupSize, gPow, totm, peArr, sizeOfPE, (hInt_t*)0); +} + +extern "C" void tensorGDecR (hShort_t tupSize, hInt_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE) +{ + tensorFuserPrime (y, tupSize, gDec, totm, peArr, sizeOfPE, (hInt_t*)0); +} + +extern "C" void tensorGDecRq (hShort_t tupSize, Zq* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, hInt_t* qs) +{ + tensorFuserPrime (y, tupSize, gDec, totm, peArr, sizeOfPE, qs); + canonicalizeZq(y,tupSize,totm,qs); +} + +extern "C" void tensorGInvPowR (hShort_t tupSize, hInt_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE) +{ + tensorFuserPrime (y, tupSize, gInvPow, totm, peArr, sizeOfPE, (hInt_t*)0); +} + +extern "C" void tensorGInvPowRq (hShort_t tupSize, Zq* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, hInt_t* qs) +{ + tensorFuserPrime (y, tupSize, gInvPow, totm, peArr, sizeOfPE, qs); + canonicalizeZq(y,tupSize,totm,qs); +} + +extern "C" void tensorGInvPowC (hShort_t tupSize, Complex* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE) +{ + tensorFuserPrime (y, tupSize, gInvPow, totm, peArr, sizeOfPE, (hInt_t*)0); +} + +extern "C" void tensorGInvDecR (hShort_t tupSize, hInt_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE) +{ + tensorFuserPrime (y, tupSize, gInvDec, totm, peArr, sizeOfPE, (hInt_t*)0); +} + +extern "C" void tensorGInvDecRq (hShort_t tupSize, Zq* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, hInt_t* qs) +{ + tensorFuserPrime (y, tupSize, gInvDec, totm, peArr, sizeOfPE, qs); + canonicalizeZq(y,tupSize,totm,qs); +} diff --git a/Crypto/Lol/Cyclotomic/Tensor/CTensor/generalfuncs.c b/Crypto/Lol/Cyclotomic/Tensor/CTensor/generalfuncs.c deleted file mode 100644 --- a/Crypto/Lol/Cyclotomic/Tensor/CTensor/generalfuncs.c +++ /dev/null @@ -1,305 +0,0 @@ -#include "tensorTypes.h" - -hDim_t ipow(hDim_t base, hShort_t exp) -{ -#ifdef DEBUG_MODE - ASSERT(exp >= 0); -#endif - hDim_t result = 1; - while (exp) - { - if (exp & 1) - { - result *= base; - } - exp >>= 1; - base *= base; - } - return result; -} - -complex_t cmplxpow(complex_t base, hShort_t exp) -{ - complex_t result = (complex_t){1,0}; - while (exp) - { - if (exp & 1) - { - CMPLX_IMUL(result,base); - } - exp >>= 1; - CMPLX_IMUL(base,base); - } - return result; -} - -hInt_t qpow(hInt_t base, hShort_t exp, hInt_t q) -{ - hInt_t result = 1; - while (exp) - { - if (exp & 1) - { - result = (result*base)%q; - } - exp >>= 1; - base = (base*base)%q; - } - return result; -} - -// a is the field size. we are looking for reciprocal of b -hInt_t reciprocal (hInt_t a, hInt_t b) -{ - hInt_t fieldSize = a; - - hInt_t y = 1; - hInt_t lasty = 0; - while (b != 0) - { - hInt_t quotient = a / b; - hInt_t tmp = a % b; - a = b; - b = tmp; - tmp = y; - y = lasty - quotient*y; - lasty = tmp; - } - ASSERT (a==1); // if this one fails, then b is not invertible mod a - - // this actually returns EITHER the reciprocal OR reciprocal + fieldSize - hInt_t res = lasty + fieldSize; -#ifdef DEBUG_MODE - ASSERT (0); - ASSERT ((res >= 0) && (res < fieldSize + fieldSize)); - hInt_t test = res * b % fieldSize; - ASSERT (test == 1); -#endif - return res; - -} - -//for square transforms -void tensorFuser (void* y, hShort_t tupSize, funcPtr f, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, hInt_t* qs) -{ - hDim_t lts = totm; - hDim_t rts = 1; - hShort_t i; - - for (i = 0; i < sizeOfPE; ++i) - { - PrimeExponent pe = peArr[i]; - hDim_t ipow_pe = ipow(pe.prime, (pe.exponent-1)); - hDim_t dim = (pe.prime-1) * ipow_pe; // the totient of pe - lts /= dim; - (*f) (y, tupSize, pe, lts, rts, qs); - rts *= dim; - } -} - -void tensorFuserCRT (void* y, hShort_t tupSize, crtFuncPtr f, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, void** ru, hInt_t* q) -{ - hDim_t lts = totm; - hDim_t rts = 1; - hShort_t i; - - for (i = 0; i < sizeOfPE; ++i) - { - PrimeExponent pe = peArr[i]; - hDim_t ipow_pe = ipow(pe.prime, (pe.exponent-1)); - hDim_t dim = (pe.prime-1) * ipow_pe; // the totient of pe - lts /= dim; - (*f) (y, tupSize, lts, rts, pe, ru[i], q); - rts *= dim; - } -} - -struct timespec tsSubtract (struct timespec time1, struct timespec time2) -{ /* Local variables. */ - struct timespec result ; - -/* Subtract the second time from the first. */ - - if ((time1.tv_sec < time2.tv_sec) || - ((time1.tv_sec == time2.tv_sec) && - (time1.tv_nsec <= time2.tv_nsec))) { /* TIME1 <= TIME2? */ - result.tv_sec = result.tv_nsec = 0 ; - } else { /* TIME1 > TIME2 */ - result.tv_sec = time1.tv_sec - time2.tv_sec ; - if (time1.tv_nsec < time2.tv_nsec) { - result.tv_nsec = time1.tv_nsec + 1000000000L - time2.tv_nsec ; - result.tv_sec-- ; /* Borrow a second. */ - } else { - result.tv_nsec = time1.tv_nsec - time2.tv_nsec ; - } - } - - return (result) ; -} - -struct timespec tsAdd (struct timespec time1, struct timespec time2) -{ /* Local variables. */ - struct timespec result ; - -/* Add the two times together. */ - - result.tv_sec = time1.tv_sec + time2.tv_sec ; - result.tv_nsec = time1.tv_nsec + time2.tv_nsec ; - if (result.tv_nsec >= 1000000000L) { /* Carry? */ - result.tv_sec++ ; result.tv_nsec = result.tv_nsec - 1000000000L ; - } - - return (result) ; -} - -const char *tsShow (struct timespec binaryTime, bool inLocal, const char *format) -{ /* Local variables. */ - struct tm calendarTime ; -#define MAX_TIMES 4 - static char asciiTime[MAX_TIMES][64] ; - static int current = 0 ; - -/* Convert the TIMESPEC to calendar time: year, month, day, etc. */ - -#ifdef VXWORKS - if (inLocal) - localtime_r ((time_t *) &binaryTime.tv_sec, &calendarTime) ; - else - gmtime_r ((time_t *) &binaryTime.tv_sec, &calendarTime) ; -#else - if (inLocal) - calendarTime = *(localtime ((time_t *) &binaryTime.tv_sec)) ; - else - calendarTime = *(gmtime ((time_t *) &binaryTime.tv_sec)) ; -#endif - -/* Format the time in ASCII. */ - - current = (current + 1) % MAX_TIMES ; - - if (format == NULL) { - strftime (asciiTime[current], 64, "%Y-%j-%H:%M:%S", &calendarTime) ; - sprintf (asciiTime[current] + strlen (asciiTime[current]), - ".%06ld", (binaryTime.tv_nsec % 1000000000L) / 1000L) ; - } else { - strftime (asciiTime[current], 64, format, &calendarTime) ; - sprintf (asciiTime[current] + strlen (asciiTime[current]), - ".%06ld", (binaryTime.tv_nsec % 1000000000L) / 1000L) ; - } - - return (asciiTime[current]); -} - - - -const char* timeformat = "%M:%S"; - -void getStats() { - -#ifdef STATS - struct timespec total; - printf("CRT Stats:\n"); - printf("CRT_Rq times: Real:%s\tMono:%s\tProc:%s\tThread:%s\n", tsShow(crttime1, false, timeformat),tsShow(crttime2, false, timeformat),tsShow(crttime3, false, timeformat),tsShow(crttime4, false, timeformat)); - printf("CTR_Rq: %d\t%s\t%d\t%s\n", crtRqCtr, tsShow(crttime1, false, timeformat), crtInvRqCtr, tsShow(crtInvRqTime, false, timeformat)); - printf("CTR_C: %d\t%s\t%d\t%s\n", crtCCtr, tsShow(crtCTime, false, timeformat), crtInvCCtr, tsShow(crtInvCTime, false, timeformat)); - - printf("\nG Stats:\n"); - printf("GPow_R: %d\t%s\t%d\t%s\n", gprCtr, tsShow(gprTime, false, timeformat), giprCtr, tsShow(giprTime, false, timeformat)); - printf("GPow_Rq: %d\t%s\t%d\t%s\n", gprqCtr, tsShow(gprqTime, false, timeformat), giprqCtr, tsShow(giprqTime, false, timeformat)); - printf("GPow_C: %d\t%s\t%d\t%s\n", gpcCtr, tsShow(gpcTime, false, timeformat), gipcCtr, tsShow(gipcTime, false, timeformat)); - printf("GDec_R: %d\t%s\t%d\t%s\n", gdrCtr, tsShow(gdrTime, false, timeformat), gidrCtr, tsShow(gidrTime, false, timeformat)); - printf("GDec_Rq: %d\t%s\t%d\t%s\n", gdrqCtr, tsShow(gdrqTime, false, timeformat), gidrqCtr, tsShow(gidrqTime, false, timeformat)); - printf("GCRT_Rq: %d\t%d\t%s\n", gcrqCtr, gicrqCtr, tsShow(gcrqTime, false, timeformat)); - printf("GCRT_C: %d\t%d\t%s\n", gccCtr, giccCtr, tsShow(gccTime, false, timeformat)); - - printf("\nL Stats:\n"); - printf("L_R: %d\t%s\t%d\t%s\n", lrCtr, tsShow(lrTime, false, timeformat), lirCtr, tsShow(lirTime, false, timeformat)); - printf("L_Rq: %d\t%s\t%d\t%s\n", lrqCtr, tsShow(lrqTime, false, timeformat), lirqCtr, tsShow(lirqTime, false, timeformat)); - printf("L_D: %d\t%s\t%d\t%s\n", ldCtr, tsShow(ldTime, false, timeformat), lidCtr, tsShow(lidTime, false, timeformat)); - printf("L_C: %d\t%s\t%d\t%s\n", lcCtr, tsShow(lcTime, false, timeformat), licCtr, tsShow(licTime, false, timeformat)); - - printf("\nNorm Stats:\n"); - printf("NormSq_R %d\t%s\n", normrCtr, tsShow(normrTime, false, timeformat)); - - printf("\nBasic Stats:\n"); - printf("Mul: %d\t%s\n", mulCtr, tsShow(mulTime, false, timeformat)); - printf("Add: %d\t%s\n", addCtr, tsShow(addTime, false, timeformat)); - - total = tsAdd(norrTime, tsAdd(crttime1, tsAdd(crtInvRqTime, tsAdd(crtCTime, tsAdd(crtInvCTime, tsAdd(gprTime, tsAdd(giprTime, tsAdd(gdrTime, tsAdd(gidrTime, tsAdd(gprqTime, tsAdd(giprqTime, tsAdd(gdrqTime, tsAdd(gidrqTime, tsAdd(gcrqTime, tsAdd(gccTime, tsAdd(lrTime, tsAdd(lirTime, tsAdd(lrqTime, tsAdd(lirqTime, tsAdd(ldTime, tsAdd(lidTime, tsAdd(lcTime, tsAdd(licTime, tsAdd(mulTime,addTime)))))))))))))))))))))))); - - printf("\nTotal C Time: %s\n\n", tsShow(total, false, timeformat)); - - crtRqCtr = 0; - crtInvRqCtr = 0; - crtCCtr = 0; - crtInvCCtr = 0; - - gprCtr = 0; - gpcCtr = 0; - gprqCtr = 0; - gdrCtr = 0; - gdrqCtr = 0; - giprCtr = 0; - gipcCtr = 0; - giprqCtr = 0; - gidrCtr = 0; - gidrqCtr = 0; - gcrqCtr = 0; - gccCtr = 0; - gicrqCtr = 0; - giccCtr = 0; - - lrqCtr = 0; - lrCtr = 0; - ldCtr = 0; - lcCtr = 0; - lirqCtr = 0; - lirCtr = 0; - lidCtr = 0; - licCtr = 0; - - normrCtr = 0; - - mulCtr = 0; - addCtr = 0; - - mulTime = (struct timespec){0,0}; - addTime = (struct timespec){0,0}; - - lrqTime = (struct timespec){0,0}; - lrTime = (struct timespec){0,0}; - ldTime = (struct timespec){0,0}; - lcTime = (struct timespec){0,0}; - lirqTime = (struct timespec){0,0}; - lirTime = (struct timespec){0,0}; - lidTime = (struct timespec){0,0}; - licTime = (struct timespec){0,0}; - - normrTime = (struct timespec){0,0}; - - gprTime = (struct timespec){0,0}; - gpcTime = (struct timespec){0,0}; - gprqTime = (struct timespec){0,0}; - gdrTime = (struct timespec){0,0}; - gdrqTime = (struct timespec){0,0}; - giprTime = (struct timespec){0,0}; - gipcTime = (struct timespec){0,0}; - giprqTime = (struct timespec){0,0}; - gidrTime = (struct timespec){0,0}; - gidrqTime = (struct timespec){0,0}; - gcrqTime = (struct timespec){0,0}; - gccTime = (struct timespec){0,0}; - - crttime1 = (struct timespec){0,0}; - crttime2 = (struct timespec){0,0}; - crttime3 = (struct timespec){0,0}; - crttime4 = (struct timespec){0,0}; - - crtInvRqTime = (struct timespec){0,0}; - crtCTime = (struct timespec){0,0}; - crtInvCTime = (struct timespec){0,0}; -#endif - fflush(stdout); -} - - diff --git a/Crypto/Lol/Cyclotomic/Tensor/CTensor/l.c b/Crypto/Lol/Cyclotomic/Tensor/CTensor/l.c deleted file mode 100644 --- a/Crypto/Lol/Cyclotomic/Tensor/CTensor/l.c +++ /dev/null @@ -1,434 +0,0 @@ -#include "tensorTypes.h" - -void lpRq (hInt_t* y, hShort_t tupSize, hDim_t lts, hDim_t rts, hDim_t p, hInt_t q) { - hDim_t blockOffset; - hDim_t modOffset; - int i; - hDim_t tmp1 = rts*(p-1); - for (blockOffset = 0; blockOffset < lts; ++blockOffset) { - hDim_t tmp2 = blockOffset*tmp1; - for (modOffset = 0; modOffset < rts; ++modOffset) { - hDim_t idx = tmp2 + modOffset + rts; - for (i = 1; i < p-1; ++i) { - hInt_t temp = y[(idx-rts)*tupSize] + y[idx*tupSize]; - if (temp >= q) y[idx*tupSize]=temp-q; - else y[idx*tupSize] = temp; - idx += rts; - } - } - } -} - -void lpR (hInt_t* y, hShort_t tupSize, hDim_t lts, hDim_t rts, hDim_t p) { - hDim_t blockOffset; - hDim_t modOffset; - int i; - - hDim_t tmp1 = rts*(p-1); - for (blockOffset = 0; blockOffset < lts; ++blockOffset) { - hDim_t tmp2 = blockOffset*tmp1; - for (modOffset = 0; modOffset < rts; ++modOffset) { - hDim_t idx = tmp2 + modOffset + rts; - for (i = 1; i < p-1; ++i) { - y[idx*tupSize] += y[(idx-rts)*tupSize]; - idx += rts; - } - } - } -} - -void lpDouble (double* y, hShort_t tupSize, hDim_t lts, hDim_t rts, hDim_t p) { - hDim_t blockOffset; - hDim_t modOffset; - int i; - - hDim_t tmp1 = rts*(p-1); - for (blockOffset = 0; blockOffset < lts; ++blockOffset) { - hDim_t tmp2 = blockOffset*tmp1; - for (modOffset = 0; modOffset < rts; ++modOffset) { - hDim_t idx = tmp2 + modOffset + rts; - for (i = 1; i < p-1; ++i) { - y[idx*tupSize] += y[(idx-rts)*tupSize]; - idx += rts; - } - } - } -} - -void lpC (complex_t* y, hShort_t tupSize, hDim_t lts, hDim_t rts, hDim_t p) { - hDim_t blockOffset; - hDim_t modOffset; - int i; - - hDim_t tmp1 = rts*(p-1); - for (blockOffset = 0; blockOffset < lts; ++blockOffset) { - hDim_t tmp2 = blockOffset*tmp1; - for (modOffset = 0; modOffset < rts; ++modOffset) { - hDim_t idx = tmp2 + modOffset + rts; - for (i = 1; i < p-1; ++i) { - CMPLX_IADD (y[idx*tupSize], y[(idx-rts)*tupSize]); - idx += rts; - } - } - } -} - -void lpInvRq (hInt_t* y, hShort_t tupSize, hDim_t lts, hDim_t rts, hDim_t p, hInt_t q) { - hDim_t blockOffset; - hDim_t modOffset; - int i; - - hDim_t tmp1 = rts*(p-1); - for (blockOffset = 0; blockOffset < lts; ++blockOffset) { - hDim_t tmp2 = blockOffset*tmp1; - for (modOffset = 0; modOffset < rts; ++ modOffset) { - hDim_t tensorOffset = tmp2 + modOffset; - hDim_t idx = tensorOffset + (p-2) * rts; - for (i = p-2; i != 0; --i) { - hInt_t temp = y[idx*tupSize] - y[(idx-rts)*tupSize] + q; - if (temp >= q) y[idx*tupSize]=temp-q; - else y[idx*tupSize] = temp; - idx -= rts; - } - } - } -} - -void lpInvR (hInt_t* y, hShort_t tupSize, hDim_t lts, hDim_t rts, hDim_t p) { - hDim_t blockOffset; - hDim_t modOffset; - int i; - - hDim_t tmp1 = rts*(p-1); - for (blockOffset = 0; blockOffset < lts; ++blockOffset) { - hDim_t tmp2 = blockOffset*tmp1; - for (modOffset = 0; modOffset < rts; ++ modOffset) { - hDim_t tensorOffset = tmp2 + modOffset; - hDim_t idx = tensorOffset + (p-2) * rts; - for (i = p-2; i != 0; --i) { - y[idx*tupSize] -= y[(idx-rts)*tupSize] ; - idx -= rts; - } - } - } -} - -void lpInvDouble (double* y, hShort_t tupSize, hDim_t lts, hDim_t rts, hDim_t p) { - hDim_t blockOffset; - hDim_t modOffset; - int i; - - hDim_t tmp1 = rts*(p-1); - for (blockOffset = 0; blockOffset < lts; ++blockOffset) { - hDim_t tmp2 = blockOffset*tmp1; - for (modOffset = 0; modOffset < rts; ++ modOffset) { - hDim_t tensorOffset = tmp2 + modOffset; - hDim_t idx = tensorOffset + (p-2) * rts; - for (i = p-2; i != 0; --i) { - y[idx*tupSize] -= y[(idx-rts)*tupSize] ; - idx -= rts; - } - } - } -} - -void lpInvC (complex_t* y, hShort_t tupSize, hDim_t lts, hDim_t rts, hDim_t p) { - hDim_t blockOffset; - hDim_t modOffset; - int i; - - hDim_t tmp1 = rts*(p-1); - for (blockOffset = 0; blockOffset < lts; ++blockOffset) { - hDim_t tmp2 = blockOffset*tmp1; - for (modOffset = 0; modOffset < rts; ++ modOffset) { - hDim_t tensorOffset = tmp2 + modOffset; - hDim_t idx = tensorOffset + (p-2) * rts; - for (i = p-2; i != 0; --i) { - CMPLX_ISUB (y[idx*tupSize], y[(idx-rts)*tupSize]); - idx -= rts; - } - } - } -} - -void ppLRq (void* y, hShort_t tupSize, PrimeExponent pe, hDim_t lts, hDim_t rts, hInt_t* qs) { - hDim_t p = pe.prime; - hShort_t e = pe.exponent; - if(p == 2) return; - for(int tupIdx = 0; tupIdx < tupSize; tupIdx++) { - lpRq (((hInt_t*)y)+tupIdx, tupSize, lts*ipow(p,e-1), rts, p, qs[tupIdx]); - } -} - -void ppLR (void* y, hShort_t tupSize, PrimeExponent pe, hDim_t lts, hDim_t rts, hInt_t* qs) { -#ifdef DEBUG_MODE - ASSERT (q==0); -#endif - hDim_t p = pe.prime; - hShort_t e = pe.exponent; - if(p == 2) return; - for(int tupIdx = 0; tupIdx < tupSize; tupIdx++) { - lpR (((hInt_t*)y)+tupIdx, tupSize, lts*ipow(p,e-1), rts, p); - } -} - -void ppLDouble (void* y, hShort_t tupSize, PrimeExponent pe, hDim_t lts, hDim_t rts, hInt_t* qs) { -#ifdef DEBUG_MODE - ASSERT (q==0); -#endif - hDim_t p = pe.prime; - hShort_t e = pe.exponent; - if(p == 2) return; - for(int tupIdx = 0; tupIdx < tupSize; tupIdx++) { - lpDouble (((double*)y)+tupIdx, tupSize, lts*ipow(p,e-1), rts, p); - } -} - -void ppLC (void* y, hShort_t tupSize, PrimeExponent pe, hDim_t lts, hDim_t rts, hInt_t* qs) { -#ifdef DEBUG_MODE - ASSERT (q==0); -#endif - hDim_t p = pe.prime; - hShort_t e = pe.exponent; - if(p == 2) return; - for(int tupIdx = 0; tupIdx < tupSize; tupIdx++) { - lpC (((complex_t*)y)+tupIdx, tupSize, lts*ipow(p,e-1), rts, p); - } -} - - -void ppLInvRq (void* y, hShort_t tupSize, PrimeExponent pe, hDim_t lts, hDim_t rts, hInt_t* qs) { - hDim_t p = pe.prime; - hShort_t e = pe.exponent; - if(p == 2) return; - for(int tupIdx = 0; tupIdx < tupSize; tupIdx++) { - lpInvRq (((hInt_t*)y)+tupIdx, tupSize, lts*ipow(p,e-1), rts, p, qs[tupIdx]); - } -} - -void ppLInvR (void* y, hShort_t tupSize, PrimeExponent pe, hDim_t lts, hDim_t rts, hInt_t* qs) { -#ifdef DEBUG_MODE - ASSERT (q==0); -#endif - hDim_t p = pe.prime; - hShort_t e = pe.exponent; - if(p == 2) return; - for(int tupIdx = 0; tupIdx < tupSize; tupIdx++) { - lpInvR (((hInt_t*)y)+tupIdx, tupSize, lts*ipow(p,e-1), rts, p); - } -} - -void ppLInvDouble (void* y, hShort_t tupSize, PrimeExponent pe, hDim_t lts, hDim_t rts, hInt_t* qs) { -#ifdef DEBUG_MODE - ASSERT (q==0); -#endif - hDim_t p = pe.prime; - hShort_t e = pe.exponent; - if(p == 2) return; - for(int tupIdx = 0; tupIdx < tupSize; tupIdx++) { - lpInvDouble (((double*)y)+tupIdx, tupSize, lts*ipow(p,e-1), rts, p); - } -} - -void ppLInvC (void* y, hShort_t tupSize, PrimeExponent pe, hDim_t lts, hDim_t rts, hInt_t* qs) { -#ifdef DEBUG_MODE - ASSERT (q==0); -#endif - hDim_t p = pe.prime; - hShort_t e = pe.exponent; - if(p == 2) return; - for(int tupIdx = 0; tupIdx < tupSize; tupIdx++) { - lpInvC (((complex_t*)y)+tupIdx, tupSize, lts*ipow(p,e-1), rts, p); - } -} - -#ifdef STATS -int lrqCtr = 0; -int lrCtr = 0; -int ldCtr = 0; -int lcCtr = 0; -int lirqCtr = 0; -int lirCtr = 0; -int lidCtr = 0; -int licCtr = 0; - -struct timespec lrqTime = {0,0}; -struct timespec lrTime = {0,0}; -struct timespec ldTime = {0,0}; -struct timespec lcTime = {0,0}; -struct timespec lirqTime = {0,0}; -struct timespec lirTime = {0,0}; -struct timespec lidTime = {0,0}; -struct timespec licTime = {0,0}; -#endif - - -void tensorLRq (hShort_t tupSize, hInt_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, hInt_t* qs) { -#ifdef STATS - lrqCtr++; - struct timespec s1,t1; - clock_gettime(CLOCK_REALTIME, &s1); -#endif -#ifdef DEBUG_MODE - hDim_t i; - printf("\n\nEntered tensorLRq\ttotm=%" PRId32 "\tnumFacts=%" PRId16 "\tq=%" PRId64 "\n[", totm, sizeOfPE, q); - /*for(i = 0; i < totm; i++) { - printf("%" PRId64 ",", y[i]); - }*/ - printf("]\n["); - for(i = 0; i < sizeOfPE; i++) { - printf("(%" PRId32 ",%" PRId16 "),", peArr[i].prime, peArr[i].exponent); - } - printf("]\n"); -#endif - tensorFuser (y, tupSize, ppLRq, totm, peArr, sizeOfPE, qs); // don't need to shift here -#ifdef DEBUG_MODE - for(i = 0; i < totm*tupSize; i++) { - if(y[i]<0) { - printf("tensorLRq\n"); - } - } -#endif -#ifdef STATS - clock_gettime(CLOCK_REALTIME, &t1); - lrqTime = tsAdd(lrqTime, tsSubtract(t1,s1)); -#endif -} - -void tensorLR (hShort_t tupSize, hInt_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE) { -#ifdef STATS - lrCtr++; - struct timespec s1,t1; - clock_gettime(CLOCK_REALTIME, &s1); -#endif -#ifdef DEBUG_MODE - printf("\n\nEntered tensorLR\ttotm=%" PRId32 "\tnumFacts=%" PRId16 "\n[", totm, sizeOfPE); - hDim_t i; - for(i = 0; i < totm; i++) { - printf("%" PRId64 ",", y[i]); - } - printf("]\n["); - for(i = 0; i < sizeOfPE; i++) { - printf("(%" PRId32 ",%" PRId16 "),", peArr[i].prime, peArr[i].exponent); - } - printf("]\n"); -#endif - tensorFuser (y, tupSize, ppLR, totm, peArr, sizeOfPE, (hInt_t*)0); -#ifdef STATS - clock_gettime(CLOCK_REALTIME, &t1); - lrTime = tsAdd(lrTime, tsSubtract(t1,s1)); -#endif -} - -void tensorLDouble (hShort_t tupSize, double* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE) { -#ifdef STATS - ldCtr++; - struct timespec s1,t1; - clock_gettime(CLOCK_REALTIME, &s1); -#endif -#ifdef DEBUG_MODE - printf("\n\nEntered tensorLDouble\ttotm=%" PRId32 "\tnumFacts=%" PRId16 "\n[", totm, sizeOfPE); - hDim_t i; - for(i = 0; i < totm; i++) { - printf("%f,", y[i]); - } - printf("]\n["); - for(i = 0; i < sizeOfPE; i++) { - printf("(%" PRId32 ",%" PRId16 "),", peArr[i].prime, peArr[i].exponent); - } - printf("]\n"); -#endif - tensorFuser (y, tupSize, ppLDouble, totm, peArr, sizeOfPE, (hInt_t*)0); -#ifdef STATS - clock_gettime(CLOCK_REALTIME, &t1); - ldTime = tsAdd(ldTime, tsSubtract(t1,s1)); -#endif -} - -void tensorLC (hShort_t tupSize, complex_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE) { -#ifdef STATS - lcCtr++; - struct timespec s1,t1; - clock_gettime(CLOCK_REALTIME, &s1); -#endif -#ifdef DEBUG_MODE - printf("\n\nEntered tensorLC\ttotm=%" PRId32 "\tnumFacts=%" PRId16 "\n[", totm, sizeOfPE); - hDim_t i; - for(i = 0; i < totm; i++) { - printf("(%f,%f),", y[i].real, y[i].imag); - } - printf("]\n["); - for(i = 0; i < sizeOfPE; i++) { - printf("(%" PRId32 ",%" PRId16 "),", peArr[i].prime, peArr[i].exponent); - } - printf("]\n"); -#endif - tensorFuser (y, tupSize, ppLC, totm, peArr, sizeOfPE, (hInt_t*)0); -#ifdef STATS - clock_gettime(CLOCK_REALTIME, &t1); - lcTime = tsAdd(lcTime, tsSubtract(t1,s1)); -#endif -} - -void tensorLInvRq (hShort_t tupSize, hInt_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, hInt_t* qs) { -#ifdef STATS - lirqCtr++; - struct timespec s1,t1; - clock_gettime(CLOCK_REALTIME, &s1); -#endif - tensorFuser (y, tupSize, ppLInvRq, totm, peArr, sizeOfPE, qs); -#ifdef DEBUG_MODE - hDim_t i; - for(i = 0; i < totm*tupSize; i++) - { - if(y[i]<0) - { - printf("tensorLInvRq\n"); - } - } -#endif -#ifdef STATS - clock_gettime(CLOCK_REALTIME, &t1); - lirqTime = tsAdd(lirqTime, tsSubtract(t1,s1)); -#endif -} - -void tensorLInvR (hShort_t tupSize, hInt_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE) { -#ifdef STATS - lirCtr++; - struct timespec s1,t1; - clock_gettime(CLOCK_REALTIME, &s1); -#endif - tensorFuser (y, tupSize, ppLInvR, totm, peArr, sizeOfPE, (hInt_t*)0); -#ifdef STATS - clock_gettime(CLOCK_REALTIME, &t1); - lirTime = tsAdd(lirTime, tsSubtract(t1,s1)); -#endif -} - -void tensorLInvDouble (hShort_t tupSize, double* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE) { -#ifdef STATS - lidCtr++; - struct timespec s1,t1; - clock_gettime(CLOCK_REALTIME, &s1); -#endif - tensorFuser (y, tupSize, ppLInvDouble, totm, peArr, sizeOfPE, (hInt_t*)0); -#ifdef STATS - clock_gettime(CLOCK_REALTIME, &t1); - lidTime = tsAdd(lidTime, tsSubtract(t1,s1)); -#endif -} - -void tensorLInvC (hShort_t tupSize, complex_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE) { -#ifdef STATS - licCtr++; - struct timespec s1,t1; - clock_gettime(CLOCK_REALTIME, &s1); -#endif - tensorFuser (y, tupSize, ppLInvC, totm, peArr, sizeOfPE, (hInt_t*)0); -#ifdef STATS - clock_gettime(CLOCK_REALTIME, &t1); - licTime = tsAdd(licTime, tsSubtract(t1,s1)); -#endif -} - diff --git a/Crypto/Lol/Cyclotomic/Tensor/CTensor/l.cpp b/Crypto/Lol/Cyclotomic/Tensor/CTensor/l.cpp new file mode 100644 --- /dev/null +++ b/Crypto/Lol/Cyclotomic/Tensor/CTensor/l.cpp @@ -0,0 +1,87 @@ +#include "types.h" +#include "tensor.h" + +template void lp (ring* y, hShort_t tupSize, hDim_t lts, hDim_t rts, hDim_t p) +{ + hDim_t blockOffset; + hDim_t modOffset; + int i; + + if(p == 2) {return;} + + hDim_t tmp1 = rts*(p-1); + for (blockOffset = 0; blockOffset < lts; ++blockOffset) { + hDim_t tmp2 = blockOffset*tmp1; + for (modOffset = 0; modOffset < rts; ++modOffset) { + hDim_t idx = tmp2 + modOffset + rts; + for (i = 1; i < p-1; ++i) { + y[idx*tupSize] += y[(idx-rts)*tupSize]; + idx += rts; + } + } + } +} + +template void lpInv (ring* y, hShort_t tupSize, hDim_t lts, hDim_t rts, hDim_t p) +{ + hDim_t blockOffset; + hDim_t modOffset; + int i; + + if(p == 2) {return;} + + hDim_t tmp1 = rts*(p-1); + for (blockOffset = 0; blockOffset < lts; ++blockOffset) { + hDim_t tmp2 = blockOffset*tmp1; + for (modOffset = 0; modOffset < rts; ++ modOffset) { + hDim_t tensorOffset = tmp2 + modOffset; + hDim_t idx = tensorOffset + (p-2) * rts; + for (i = p-2; i != 0; --i) { + y[idx*tupSize] -= y[(idx-rts)*tupSize] ; + idx -= rts; + } + } + } +} + +extern "C" void tensorLRq (hShort_t tupSize, Zq* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, hInt_t* qs) +{ + tensorFuserPrime (y, tupSize, lp, totm, peArr, sizeOfPE, qs); + canonicalizeZq(y,tupSize,totm,qs); +} + +extern "C" void tensorLR (hShort_t tupSize, hInt_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE) +{ + tensorFuserPrime (y, tupSize, lp, totm, peArr, sizeOfPE, (hInt_t*)0); +} + +extern "C" void tensorLDouble (hShort_t tupSize, double* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE) +{ + tensorFuserPrime (y, tupSize, lp, totm, peArr, sizeOfPE, (hInt_t*)0); +} + +extern "C" void tensorLC (hShort_t tupSize, Complex* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE) +{ + tensorFuserPrime (y, tupSize, lp, totm, peArr, sizeOfPE, (hInt_t*)0); +} + +extern "C" void tensorLInvRq (hShort_t tupSize, Zq* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, hInt_t* qs) +{ + tensorFuserPrime (y, tupSize, lpInv, totm, peArr, sizeOfPE, qs); + canonicalizeZq(y,tupSize,totm,qs); +} + +extern "C" void tensorLInvR (hShort_t tupSize, hInt_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE) +{ + tensorFuserPrime (y, tupSize, lpInv, totm, peArr, sizeOfPE, (hInt_t*)0); +} + +extern "C" void tensorLInvDouble (hShort_t tupSize, double* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE) +{ + tensorFuserPrime (y, tupSize, lpInv, totm, peArr, sizeOfPE, (hInt_t*)0); +} + +extern "C" void tensorLInvC (hShort_t tupSize, Complex* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE) +{ + tensorFuserPrime (y, tupSize, lpInv, totm, peArr, sizeOfPE, (hInt_t*)0); +} diff --git a/Crypto/Lol/Cyclotomic/Tensor/CTensor/mul.cpp b/Crypto/Lol/Cyclotomic/Tensor/CTensor/mul.cpp new file mode 100644 --- /dev/null +++ b/Crypto/Lol/Cyclotomic/Tensor/CTensor/mul.cpp @@ -0,0 +1,24 @@ +#include "types.h" + +template void zipWithStar (ring* a, ring* b, hShort_t tupSize, hDim_t totm, hInt_t* qs) +{ + for(int tupIdx = 0; tupIdx < tupSize; tupIdx++) { + if(qs) { + Zq::q = qs[tupIdx]; + } + for(int i = 0; i < totm; i++) { + a[i*tupSize+tupIdx] *= b[i*tupSize+tupIdx]; + } + } +} + +//a = zipWith (*) a b +extern "C" void mulRq (hShort_t tupSize, Zq* a, Zq* b, hDim_t totm, hInt_t* qs) +{ + zipWithStar(a, b, tupSize, totm, qs); +} + +extern "C" void mulC (hShort_t tupSize, Complex* a, Complex* b, hDim_t totm) +{ + zipWithStar(a, b, tupSize, totm, (hInt_t*)0); +} diff --git a/Crypto/Lol/Cyclotomic/Tensor/CTensor/norm.c b/Crypto/Lol/Cyclotomic/Tensor/CTensor/norm.c deleted file mode 100644 --- a/Crypto/Lol/Cyclotomic/Tensor/CTensor/norm.c +++ /dev/null @@ -1,86 +0,0 @@ -#include "tensorTypes.h" - -#ifdef STATS -int normrCtr = 0; -struct timespec normrTime = {0,0}; -#endif - -void pNormSqR (hInt_t* y, hShort_t tupSize, hDim_t lts, hDim_t rts, hDim_t p) { - hDim_t blockOffset; - hDim_t modOffset; - hDim_t i; - - if(p==2) { - return; - } - - hDim_t tmp1 = rts*(p-1); - for (blockOffset = 0; blockOffset < lts; ++blockOffset) { - hDim_t tmp2 = blockOffset*tmp1; - for (modOffset = 0; modOffset < rts; ++modOffset) { - hDim_t tensorOffset = tmp2 + modOffset; - hInt_t sum = 0; - for (i = 0; i < p-1; ++i) { - sum += y[(tensorOffset + i*rts)*tupSize]; - } - for (i = 0; i < p-1; ++i) { - y[(tensorOffset + i*rts)*tupSize] += sum; - } - } - } -} - -void ppNormSqR (void* y, hShort_t tupSize, PrimeExponent pe, hDim_t lts, hDim_t rts, hInt_t* qs) { -#ifdef DEBUG_MODE - ASSERT (q==0); -#endif - hDim_t p = pe.prime; - hShort_t e = pe.exponent; - for(int tupIdx = 0; tupIdx < tupSize; tupIdx++) { - pNormSqR (((hInt_t*)y)+tupIdx, tupSize, lts*ipow(p,e-1), rts, p); - } -} - -void tensorNormSqR (hShort_t tupSize, hInt_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE) { -#ifdef STATS - normrCtr++; - struct timespec s1,t1; - clock_gettime(CLOCK_REALTIME, &s1); -#endif -#ifdef DEBUG_MODE - printf("\n\nEntered tensorNormSqR\ttotm=%" PRId32 "\tnumFacts=%" PRId16 "\n[", totm, sizeOfPE); - hDim_t i; - for(i = 0; i < totm; i++) { - printf("%" PRId64 ",", y[i]); - } - printf("]\n["); - for(i = 0; i < sizeOfPE; i++) { - printf("(%" PRId32 ",%" PRId16 "),", peArr[i].prime, peArr[i].exponent); - } - printf("]\n"); -#endif - - hInt_t* tempSpace = (hInt_t*)malloc(totm*tupSize*sizeof(hInt_t)); - for(hDim_t i = 0; i < totm*tupSize; i++) { - tempSpace[i]=y[i]; - } - - tensorFuser(y, tupSize, ppNormSqR, totm, peArr, sizeOfPE, (hInt_t*)0); - - //do dot product and return in index 0 - for(int tupIdx = 0; tupIdx < tupSize; tupIdx++) { - hInt_t dotprod = 0; - for(hDim_t i = 0; i < totm; i++) { - dotprod += (tempSpace[i*tupSize+tupIdx]*y[i*tupSize+tupIdx]); - } - - y[tupIdx] = dotprod; - } - - free(tempSpace); - -#ifdef STATS - clock_gettime(CLOCK_REALTIME, &t1); - lrTime = tsAdd(normrTime, tsSubtract(t1,s1)); -#endif -} diff --git a/Crypto/Lol/Cyclotomic/Tensor/CTensor/norm.cpp b/Crypto/Lol/Cyclotomic/Tensor/CTensor/norm.cpp new file mode 100644 --- /dev/null +++ b/Crypto/Lol/Cyclotomic/Tensor/CTensor/norm.cpp @@ -0,0 +1,69 @@ +#include "types.h" +#include "tensor.h" + +template void pNormSq (ring* y, hShort_t tupSize, hDim_t lts, hDim_t rts, hDim_t p) +{ + hDim_t blockOffset; + hDim_t modOffset; + hDim_t i; + + if(p==2) {return;} + + hDim_t tmp1 = rts*(p-1); + for (blockOffset = 0; blockOffset < lts; ++blockOffset) { + hDim_t tmp2 = blockOffset*tmp1; + for (modOffset = 0; modOffset < rts; ++modOffset) { + hDim_t tensorOffset = tmp2 + modOffset; + ring sum = 0; + for (i = 0; i < p-1; ++i) { + sum += y[(tensorOffset + i*rts)*tupSize]; + } + for (i = 0; i < p-1; ++i) { + y[(tensorOffset + i*rts)*tupSize] += sum; + } + } + } +} + +extern "C" void tensorNormSqR (hShort_t tupSize, hInt_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE) +{ + hInt_t* tempSpace = (hInt_t*)malloc(totm*tupSize*sizeof(hInt_t)); + for(hDim_t i = 0; i < totm*tupSize; i++) { + tempSpace[i]=y[i]; + } + + tensorFuserPrime(y, tupSize, pNormSq, totm, peArr, sizeOfPE, (hInt_t*)0); + + //do dot product and return in index 0 + for(int tupIdx = 0; tupIdx < tupSize; tupIdx++) { + hInt_t dotprod = 0; + for(hDim_t i = 0; i < totm; i++) { + dotprod += (tempSpace[i*tupSize+tupIdx]*y[i*tupSize+tupIdx]); + } + + y[tupIdx] = dotprod; + } + + free(tempSpace); +} + +extern "C" void tensorNormSqD (hShort_t tupSize, double* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE) +{ + double* tempSpace = (double*)malloc(totm*tupSize*sizeof(double)); + for(hDim_t i = 0; i < totm*tupSize; i++) { + tempSpace[i]=y[i]; + } + tensorFuserPrime(y, tupSize, pNormSq, totm, peArr, sizeOfPE, (hInt_t*)0); + + //do dot product and return in index 0 + for(int tupIdx = 0; tupIdx < tupSize; tupIdx++) { + double dotprod = 0; + for(hDim_t i = 0; i < totm; i++) { + dotprod += (tempSpace[i*tupSize+tupIdx]*y[i*tupSize+tupIdx]); + } + + y[tupIdx] = dotprod; + } + + free(tempSpace); +} diff --git a/Crypto/Lol/Cyclotomic/Tensor/CTensor/random.c b/Crypto/Lol/Cyclotomic/Tensor/CTensor/random.c deleted file mode 100644 --- a/Crypto/Lol/Cyclotomic/Tensor/CTensor/random.c +++ /dev/null @@ -1,74 +0,0 @@ - -#include -#include -#include "tensorTypes.h" - -// this function takes *inverse* RUs, so no negation is needed on the indexing -// I had been negating the ru-idx, but this was causing a *negative* mod, resulting in a hard-to-find bug -void primeD (double *y, hShort_t tupSize, hDim_t lts, hDim_t rts, hDim_t p, hDim_t rustride, complex_t* ruinv) -{ - if(p == 2) - { - return; - } - hDim_t blockOffset, modOffset, tensorOffset; - double *tempSpace = (double*)malloc((p-1)*sizeof(double)); - hDim_t temp1 = rts*(p-1); - for(blockOffset = 0; blockOffset < lts; blockOffset++) - { - hDim_t temp2 = blockOffset*temp1; - for(modOffset = 0; modOffset < rts; modOffset++) - { - tensorOffset = temp2 + modOffset; - hDim_t row, col; - - for(row = 0; row < p-1; row++) - { - double acc = 0; - for(col = 1; col <= (p>>1); col++) - { - acc += 2 * ruinv[((row*col) % p)*rustride*tupSize].real * y[(tensorOffset+rts*(col-1))*tupSize]; - } - for(col = (p>>1)+1; col <= p-1; col++) - { - acc += 2 * ruinv[((row*col) % p)*rustride*tupSize].imag * y[(tensorOffset+rts*(col-1))*tupSize]; - } - tempSpace[row] = acc/sqrt(2); - } - - for(row = 0; row < p-1; row++) - { - y[(tensorOffset+rts*row)*tupSize] = tempSpace[row]; - } - } - } - free(tempSpace); -} - -void ppD (void *y, hShort_t tupSize, hDim_t lts, hDim_t rts, PrimeExponent pe, void *ruinv, hInt_t* qs) -{ - hDim_t p = pe.prime; - hDim_t e = pe.exponent; -#ifdef DEBUG_MODE - ASSERT(e != 0); -#endif - hDim_t mprime = ipow(p,e-1); - for(int tupIdx = 0; tupIdx < tupSize; tupIdx++) { - primeD (((double*)y)+tupIdx, tupSize, lts*mprime, rts, p, mprime, ((complex_t*)ruinv)+tupIdx); - } -} - -//the contents of y will be destroyed, but should be initialized in Haskell-land to independent Guassians over the reals -void tensorGaussianDec (hShort_t tupSize, double *y, hDim_t totm, PrimeExponent *peArr, hShort_t sizeOfPE, complex_t** ruinv) -{ - void** ruinvs = (void**)malloc(sizeOfPE*sizeof(void*)); - hShort_t i; - for(i = 0; i < sizeOfPE; i++) - { - ruinvs[i] = (void*) (ruinv[i]); - } - - tensorFuserCRT (y, tupSize, ppD, totm, peArr, sizeOfPE, ruinvs, (hInt_t*)0); - - free(ruinvs); -} diff --git a/Crypto/Lol/Cyclotomic/Tensor/CTensor/random.cpp b/Crypto/Lol/Cyclotomic/Tensor/CTensor/random.cpp new file mode 100644 --- /dev/null +++ b/Crypto/Lol/Cyclotomic/Tensor/CTensor/random.cpp @@ -0,0 +1,53 @@ +#include "types.h" +#include "tensor.h" +#include "common.h" +#include + +// this function takes *inverse* RUs, so no negation is needed on the indexing +// I had been negating the ru-idx, but this was causing a *negative* mod, resulting in a hard-to-find bug +void primeD (double *y, hShort_t tupSize, hDim_t lts, hDim_t rts, hDim_t p, hDim_t rustride, Complex* ruinv) +{ + if(p == 2) { + return; + } + hDim_t blockOffset, modOffset, tensorOffset; + double *tempSpace = (double*)malloc((p-1)*sizeof(double)); + hDim_t temp1 = rts*(p-1); + for(blockOffset = 0; blockOffset < lts; blockOffset++) { + hDim_t temp2 = blockOffset*temp1; + for(modOffset = 0; modOffset < rts; modOffset++) { + tensorOffset = temp2 + modOffset; + hDim_t row, col; + + for(row = 0; row < p-1; row++) { + double acc = 0; + for(col = 1; col <= (p>>1); col++) { + acc += 2 * ruinv[((row*col) % p)*rustride*tupSize].real * y[(tensorOffset+rts*(col-1))*tupSize]; + } + for(col = (p>>1)+1; col <= p-1; col++) { + acc += 2 * ruinv[((row*col) % p)*rustride*tupSize].imag * y[(tensorOffset+rts*(col-1))*tupSize]; + } + tempSpace[row] = acc/sqrt(2); + } + + for(row = 0; row < p-1; row++) { + y[(tensorOffset+rts*row)*tupSize] = tempSpace[row]; + } + } + } + free(tempSpace); +} + +void ppD (double *y, hShort_t tupSize, hDim_t lts, hDim_t rts, PrimeExponent pe, Complex *ruinv) +{ + hDim_t p = pe.prime; + hDim_t e = pe.exponent; + hDim_t mprime = ipow(p,e-1); + primeD (y, tupSize, lts*mprime, rts, p, mprime, ruinv); +} + +//the contents of y will be destroyed, but should be initialized in Haskell-land to independent Guassians over the reals +extern "C" void tensorGaussianDec (hShort_t tupSize, double *y, hDim_t totm, PrimeExponent *peArr, hShort_t sizeOfPE, Complex** ruinv) +{ + tensorFuserCRT (y, tupSize, ppD, totm, peArr, sizeOfPE, ruinv, (hInt_t*)0); +} diff --git a/Crypto/Lol/Cyclotomic/Tensor/CTensor/tensor.h b/Crypto/Lol/Cyclotomic/Tensor/CTensor/tensor.h new file mode 100644 --- /dev/null +++ b/Crypto/Lol/Cyclotomic/Tensor/CTensor/tensor.h @@ -0,0 +1,56 @@ +#ifndef TENSOR_CPP_ +#define TENSOR_CPP_ + +#include "types.h" +#include "common.h" +#ifdef __cplusplus +template +using primeFunc = void (*) (ring*, hShort_t, hDim_t, hDim_t, hDim_t); + +template +using primeCRTFunc = void (*) (ringy*, hShort_t, hDim_t, hDim_t, PrimeExponent, ringru*); + +//for square transforms +template void tensorFuserPrime (ring* y, hShort_t tupSize, primeFunc f, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, hInt_t* qs) +{ + hDim_t lts = totm; + hDim_t rts = 1; + hShort_t i; + + for (i = 0; i < sizeOfPE; ++i) { + PrimeExponent pe = peArr[i]; + hDim_t ipow_pe = ipow(pe.prime, (pe.exponent-1)); + hDim_t dim = (pe.prime-1) * ipow_pe; // the totient of pe + lts /= dim; + for(int tupIdx = 0; tupIdx < tupSize; tupIdx++) { + if(qs) { + Zq::q = qs[tupIdx]; // global update + } + (*f) (y+tupIdx, tupSize, lts*ipow_pe, rts, pe.prime); + } + rts *= dim; + } +} + +template void tensorFuserCRT (ringy* y, hShort_t tupSize, primeCRTFunc f, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, ringru** ru, hInt_t* qs) +{ + hDim_t lts = totm; + hDim_t rts = 1; + hShort_t i; + + for (i = 0; i < sizeOfPE; ++i) { + PrimeExponent pe = peArr[i]; + hDim_t ipow_pe = ipow(pe.prime, (pe.exponent-1)); + hDim_t dim = (pe.prime-1) * ipow_pe; // the totient of pe + lts /= dim; + for(int tupIdx = 0; tupIdx < tupSize; tupIdx++) { + if(qs) { + Zq::q = qs[tupIdx]; // global update + } + (*f) (y+tupIdx, tupSize, lts, rts, pe, ru[i]+tupIdx); + } + rts *= dim; + } +} +#endif /* __cplusplus */ +#endif /* TENSOR_CPP_ */ diff --git a/Crypto/Lol/Cyclotomic/Tensor/CTensor/tensorTypes.h b/Crypto/Lol/Cyclotomic/Tensor/CTensor/tensorTypes.h deleted file mode 100644 --- a/Crypto/Lol/Cyclotomic/Tensor/CTensor/tensorTypes.h +++ /dev/null @@ -1,231 +0,0 @@ - -#ifndef TENSORTYPES_H_ -#define TENSORTYPES_H_ - - -// remove next line for more efficient code -//#define DEBUG_MODE - - -#include -#include -#include -#include -#include -#include - - -#define ASSERT(EXP) { \ - if (!(EXP)) { \ - fprintf (stderr, "Assertion in file '%s' line %d : " #EXP " is false\n", __FILE__, __LINE__); \ - exit(-1); \ - } \ -} - - -//timers and counters -#ifdef STATS -extern int crtRqCtr; -extern int crtInvRqCtr; -extern int crtCCtr; -extern int crtInvCCtr; - -extern int gprCtr; -extern int gpcCtr; -extern int gprqCtr; -extern int gdrCtr; -extern int gdrqCtr; -extern int giprCtr; -extern int gipcCtr; -extern int giprqCtr; -extern int gidrCtr; -extern int gidrqCtr; -extern int gcrqCtr; -extern int gccCtr; -extern int gicrqCtr; -extern int giccCtr; - -extern int lrqCtr; -extern int lrCtr; -extern int ldCtr; -extern int lcCtr; -extern int lirqCtr; -extern int lirCtr; -extern int lidCtr; -extern int licCtr; - -extern int normrCtr; - -extern int mulCtr; -extern struct timespec mulTime; -extern int addCtr; -extern struct timespec addTime; - -extern struct timespec lrqTime; -extern struct timespec lrTime; -extern struct timespec ldTime; -extern struct timespec lcTime; -extern struct timespec lirqTime; -extern struct timespec lirTime; -extern struct timespec lidTime; -extern struct timespec licTime; - -extern struct timespec normrTime; - -extern struct timespec crttime1; -extern struct timespec crttime2; -extern struct timespec crttime3; -extern struct timespec crttime4; -extern struct timespec crtInvRqTime; -extern struct timespec crtCTime; -extern struct timespec crtInvCTime; - -extern struct timespec gprTime; -extern struct timespec gpcTime; -extern struct timespec gprqTime; -extern struct timespec gdrTime; -extern struct timespec gdrqTime; -extern struct timespec giprTime; -extern struct timespec gipcTime; -extern struct timespec giprqTime; -extern struct timespec gidrTime; -extern struct timespec gidrqTime; -extern struct timespec gcrqTime; -extern struct timespec gccTime; -#endif - -typedef int64_t hInt_t ; -typedef int32_t hDim_t ; -typedef int16_t hShort_t ; -typedef int8_t hByte_t ; - -typedef struct -{ - hDim_t prime; - hShort_t exponent; -} PrimeExponent; - - -typedef struct -{ - double real; - double imag; -} complex_t; - -#define CMPLX_ADD(a,b) ((complex_t){((a).real + (b).real), ((a).imag + (b).imag)}) -#define CMPLX_ADD3(a,b,c) ((complex_t){((a).real + (b).real + (c).real), ((a).imag + (b).imag + (c).imag)}) -#define CMPLX_ADD4(a,b,c,d) ((complex_t){((a).real + (b).real + (c).real + (d).real), ((a).imag + (b).imag + (c).imag + (d).imag)}) -#define CMPLX_ADD5(a,b,c,d,e) ((complex_t){((a).real + (b).real + (c).real + (d).real + (e).real), ((a).imag + (b).imag + (c).imag + (d).imag + (e).imag)}) -#define CMPLX_ADD6(a,b,c,d,e,f) ((complex_t){((a).real + (b).real + (c).real + (d).real + (e).real + (f).real), ((a).imag + (b).imag + (c).imag + (d).imag + (e).imag + (f).imag)}) -#define CMPLX_ADD7(a,b,c,d,e,f,g) ((complex_t){((a).real + (b).real + (c).real + (d).real + (e).real + (f).real + (g).real), ((a).imag + (b).imag + (c).imag + (d).imag + (e).imag + (f).imag + (g).imag)}) - -#define CMPLX_SUB(a,b) ((complex_t){((a).real - (b).real), ((a).imag - (b).imag)}) -#define CMPLX_MUL(a,b) ((complex_t){((a).real*(b).real - (a).imag*(b).imag), \ - (a).real*(b).imag + (a).imag*(b).real}) -#define CMPLX_DIV(a,b) ((complex_t){((a).real*(b).real + (a).imag*(b).imag)/((b).real*(b).real+(b).imag*(b).imag), \ - ((a).imag*(b).real - (a).real*(b).imag)/((b).real*(b).real+(b).imag*(b).imag)}) - -// 'inside' operators -#define CMPLX_IADD(a,b) { (a).real += (b).real; (a).imag += (b).imag; } -#define CMPLX_ISUB(a,b) { (a).real -= (b).real; (a).imag -= (b).imag; } -#define CMPLX_IMUL(a,b) { double temp = ((a).real*(b).real - (a).imag*(b).imag); \ - (a).imag = ((a).real*(b).imag + (a).imag*(b).real); \ - (a).real = temp; } - -// calculates base ** exp -hDim_t ipow(hDim_t base, hShort_t exp); -complex_t cmplxpow(complex_t base, hShort_t exp); -hInt_t qpow(hInt_t base, hShort_t exp, hInt_t q); - -hInt_t reciprocal (hInt_t a, hInt_t b); - -struct timespec tsSubtract (struct timespec time1, struct timespec time2); -struct timespec tsAdd (struct timespec time1, struct timespec time2); -const char *tsShow (struct timespec binaryTime, bool inLocal, const char *format); - -void getStats(); - -void mulRq (hShort_t tupSize, hInt_t* a, hInt_t* b, hDim_t totm, hInt_t* qs); -//void mulMq (hInt_t* a, const hInt_t* b, const hDim_t totm, const hByte_t logr, const hInt_t k, const hInt_t q); -void mulC (hShort_t tupSize, complex_t* a, complex_t* b, hDim_t totm); - -void addR (hShort_t tupSize, hInt_t* a, hInt_t* b, hDim_t totm); -void addRq (hShort_t tupSize, hInt_t* a, const hInt_t* b, const hDim_t totm, const hInt_t* qs); -//void addMq (hInt_t* a, const hInt_t* b, const hDim_t totm, const hByte_t logr, const hInt_t k, const hInt_t q); -void addC (hShort_t tupSize, complex_t* a, complex_t* b, hDim_t totm); -void addD (hShort_t tupSize, double* a, double* b, hDim_t totm); - -typedef void (*funcPtr) (void* outputVec, hShort_t tupSize, PrimeExponent pe, hDim_t lts, hDim_t rts, hInt_t* qs); -void tensorFuser (void* y, hShort_t tupSize, funcPtr f, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, hInt_t* qs); - -typedef void (*normFuncPtr) (void* outputVec, hShort_t tupSize, PrimeExponent pe, hDim_t lts, hDim_t rts, hInt_t* output, hInt_t* qs); -void tensorFuserNorm (void* y, hShort_t tupSize, normFuncPtr f, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, hInt_t* output, hInt_t q); - -typedef void (*crtFuncPtr) (void* y, hShort_t tupSize, hDim_t lts, hDim_t rts, PrimeExponent pe, void* ru, hInt_t* q); -void tensorFuserCRT (void* y, hShort_t tupSize, crtFuncPtr f, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, void** ru, hInt_t* q); - -void tensorGPowR (hShort_t tupSize, hInt_t* x, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE); - -void tensorGPowRq (hShort_t tupSize, hInt_t* x, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, hInt_t* qs); - -void tensorGPowC (hShort_t tupSize, complex_t* x, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE); - -void tensorGDecR (hShort_t tupSize, hInt_t* x, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE); - -void tensorGDecRq (hShort_t tupSize, hInt_t* x, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, hInt_t* qs); - -void tensorGInvPowR (hShort_t tupSize, hInt_t* x, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE); - -void tensorGInvPowRq (hShort_t tupSize, hInt_t* x, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, hInt_t* qs); - -void tensorGInvPowC (hShort_t tupSize, complex_t* x, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE); - -void tensorGInvDecR (hShort_t tupSize, hInt_t* x, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE); - -void tensorGInvDecRq (hShort_t tupSize, hInt_t* x, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, hInt_t* qs); - -void tensorGCRTRq (hShort_t tupSize, hInt_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, hInt_t** gcoeffs, hInt_t* qs); - -void tensorGInvCRTRq (hShort_t tupSize, hInt_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, hInt_t** gcoeffs, hInt_t* qs); - -void tensorGCRTC (hShort_t tupSize, complex_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, complex_t** gcoeffs); - -void tensorGInvCRTC (hShort_t tupSize, complex_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, complex_t** gcoeffs); - - - -void tensorLRq (hShort_t tupSize, hInt_t* x, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, hInt_t* qs); - -void tensorLR (hShort_t tupSize, hInt_t* x, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE); - -void tensorLDouble (hShort_t tupSize, double* x, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE); - -void tensorLC (hShort_t tupSize, complex_t* x, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE); - -void tensorLInvRq (hShort_t tupSize, hInt_t* x, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, hInt_t* qs); - -void tensorLInvR (hShort_t tupSize, hInt_t* x, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE); - -void tensorLInvDouble (hShort_t tupSize, double* x, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE); - -void tensorLInvC (hShort_t tupSize, complex_t* x, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE); - - - -void tensorCRTRq (hShort_t tupSize, hInt_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, hInt_t** ru, hInt_t* qs); - -void tensorCRTC (hShort_t tupSize, complex_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, complex_t** ru); - -void tensorCRTInvRq (hShort_t tupSize, hInt_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, hInt_t** ru, hInt_t* minv, hInt_t* qs); - -void tensorCRTInvC (hShort_t tupSize, complex_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, complex_t** ru, complex_t* minv); - - - -void tensorGaussianDec (hShort_t tupSize, double* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, complex_t** ru); - -void tensorNormSqR (hShort_t tupSize, hInt_t* x, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE); - - -#endif /* TENSORTYPES_H_ */ - diff --git a/Crypto/Lol/Cyclotomic/Tensor/CTensor/types.h b/Crypto/Lol/Cyclotomic/Tensor/CTensor/types.h new file mode 100644 --- /dev/null +++ b/Crypto/Lol/Cyclotomic/Tensor/CTensor/types.h @@ -0,0 +1,138 @@ + +#ifndef TENSORTYPES_H_ +#define TENSORTYPES_H_ + +#include + +typedef int64_t hInt_t ; +typedef int32_t hDim_t ; +typedef int16_t hShort_t ; +typedef int8_t hByte_t ; + +typedef struct +{ + hDim_t prime; + hShort_t exponent; +} PrimeExponent; + + +hInt_t reciprocal (hInt_t a, hInt_t b); + +//http://stackoverflow.com/questions/37572628 +#ifdef __cplusplus +//http://stackoverflow.com/a/4421719 +class Zq +{ +public: + hInt_t x; + + static hInt_t q; // declared here, defined in generalfuncs.cpp + + Zq& operator=(const hInt_t& c) + { + this->x = c % q; + return *this; + } + Zq& operator+=(const Zq& b) + { + this->x += b.x; + this->x %= q; + return *this; + } + Zq& operator-=(const Zq& b) + { + this->x -= b.x; + this->x %= q; + return *this; + } + Zq& operator*=(const Zq& b) + { + this->x *= b.x; + this->x %= q; + return *this; + } + Zq& operator/=(const Zq& b) + { + Zq binv; + binv = reciprocal(q,b.x); + *this *= binv; + return *this; + } +}; +inline char operator==(Zq a, const Zq& b) +{ + return (a.x == b.x); +} +inline Zq operator+(Zq a, const Zq& b) +{ + a += b; + return a; +} +inline Zq operator-(Zq a, const Zq& b) +{ + a -= b; + return a; +} +inline Zq operator*(Zq a, const Zq& b) +{ + a *= b; + return a; +} +inline Zq operator/(Zq a, const Zq& b) +{ + a /= b; + return a; +} + +void canonicalizeZq (Zq* y, hShort_t tupSize, hDim_t totm, hInt_t* qs); + +class Complex +{ +public: + double real; + double imag; + + Complex& operator=(const hInt_t& c) + { + this->real = c; + this->imag = 0; + return *this; + } + Complex& operator+=(const Complex& b) + { + this->real = this->real+b.real; + this->imag = this->imag+b.imag; + return *this; + } + Complex& operator-=(const Complex& b) + { + this->real = this->real-b.real; + this->imag = this->imag-b.imag; + return *this; + } + Complex& operator*=(const Complex& b) + { + double a = this->real; + this->real = (a*b.real)-(this->imag*b.imag); + this->imag = (a*b.imag)+(this->imag*b.real); + return *this; + } +}; +inline Complex operator+(Complex a, const Complex& b) +{ + a += b; + return a; +} +inline Complex operator-(Complex a, const Complex& b) +{ + a -= b; + return a; +} +inline Complex operator*(Complex a, const Complex& b) +{ + a *= b; + return a; +} + +#endif /* __cplusplus */ +#endif /* TENSORTYPES_H_ */ diff --git a/Crypto/Lol/Cyclotomic/Tensor/CTensor/zq.cpp b/Crypto/Lol/Cyclotomic/Tensor/CTensor/zq.cpp new file mode 100644 --- /dev/null +++ b/Crypto/Lol/Cyclotomic/Tensor/CTensor/zq.cpp @@ -0,0 +1,36 @@ +#include "types.h" +#include "common.h" + +// a is the field size. we are looking for reciprocal of b +hInt_t reciprocal (hInt_t a, hInt_t b) +{ + hInt_t fieldSize = a; + + hInt_t y = 1; + hInt_t lasty = 0; + while (b != 0) { + hInt_t quotient = a / b; + hInt_t tmp = a % b; + a = b; + b = tmp; + tmp = y; + y = lasty - quotient*y; + lasty = tmp; + } + ASSERT (a==1); // if this one fails, then b is not invertible mod a + + // this actually returns EITHER the reciprocal OR reciprocal + fieldSize + hInt_t res = lasty + fieldSize; + return res; +} + +void canonicalizeZq (Zq* y, hShort_t tupSize, hDim_t totm, hInt_t* qs) { + for(int tupIdx = 0; tupIdx)) import Control.Arrow hiding (arr) import Control.DeepSeq (NFData (rnf)) +import Control.Monad.Except (throwError) import Control.Monad.Random import Data.Coerce import Data.Constraint hiding ((***)) import Data.Foldable as F import Data.Maybe +import Data.Sequence as S (fromList) import Data.Traversable as T -import Data.Vector as V hiding (force) -import Data.Vector.Unboxed as U hiding (force) +import Data.Vector as V hiding (force, (++)) +import Data.Vector.Unboxed as U hiding (force, (++)) + import Test.QuickCheck -- | An implementation of 'Tensor' backed by repa. @@ -45,6 +54,52 @@ deriving instance Show r => Show (RT m r) +instance (Fact m, Reflects q Int64) => Protoable (RT m (ZqBasic q Int64)) where + type ProtoType (RT m (ZqBasic q Int64)) = Rq + + toProto (RT (Arr xs)) = + let m = fromIntegral $ proxy valueFact (Proxy::Proxy m) + q = proxy value (Proxy::Proxy q) :: Int64 + in Rq m (fromIntegral q) $ S.fromList $ RT.toList $ RT.map lift xs + toProto x@(ZV _) = toProto $ toRT x + + fromProto (Rq m' q' xs) = + let m = proxy valueFact (Proxy::Proxy m) :: Int + q = proxy value (Proxy::Proxy q) :: Int64 + n = proxy totientFact (Proxy::Proxy m) + xs' = RT.fromList (Z:.n) $ LP.map reduce $ F.toList xs + len = F.length xs + in if m == fromIntegral m' && len == n && fromIntegral q == q' + then return $ RT $ Arr xs' + else throwError $ + "An error occurred while reading the proto type for RT.\n\ + \Expected m=" ++ show m ++ ", got " ++ show m' ++ "\n\ + \Expected n=" ++ show n ++ ", got " ++ show len ++ "\n\ + \Expected q=" ++ show q ++ ", got " ++ show q' ++ "." + +instance (Fact m, Reflects q Double) => Protoable (RT m (RRq q Double)) where + type ProtoType (RT m (RRq q Double)) = Kq + + toProto (RT (Arr xs)) = + let m = fromIntegral $ proxy valueFact (Proxy::Proxy m) + q = proxy value (Proxy::Proxy q) :: Double + in Kq m q $ S.fromList $ RT.toList $ RT.map lift xs + toProto x@(ZV _) = toProto $ toRT x + + fromProto (Kq m' q' xs) = + let m = proxy valueFact (Proxy::Proxy m) :: Int + q = proxy value (Proxy::Proxy q) :: Double + n = proxy totientFact (Proxy::Proxy m) + xs' = RT.fromList (Z:.n) $ LP.map reduce $ F.toList xs + len = F.length xs + in if m == fromIntegral m' && len == n && q == q' + then return $ RT $ Arr xs' + else throwError $ + "An error occurred while reading the proto type for RT.\n\ + \Expected m=" ++ show m ++ ", got " ++ show m' ++ "\n\ + \Expected n=" ++ show n ++ ", got " ++ show len ++ "\n\ + \Expected q=" ++ show (round q :: Int64) ++ ", got " ++ show q' ++ "." + instance Eq r => Eq (RT m r) where (ZV a) == (ZV b) = a == b (RT a) == (RT b) = a == b @@ -84,7 +139,6 @@ entailIndexT = tag $ Sub Dict entailEqT = tag $ Sub Dict entailZTT = tag $ Sub Dict - --entailRingT = tag $ Sub Dict entailNFDataT = tag $ Sub Dict entailRandomT = tag $ Sub Dict entailShowT = tag $ Sub Dict @@ -138,11 +192,6 @@ zipWithT f (RT (Arr a1)) (RT (Arr a2)) = RT $ Arr $ force $ RT.zipWith f a1 a2 zipWithT f v1 v2 = zipWithT f (toRT v1) (toRT v2) - unzipTElt (RT (Arr arr)) = (RT . Arr . fromUnboxed (extent arr)) *** - (RT . Arr . fromUnboxed (extent arr)) $ - U.unzip $ toUnboxed arr - unzipTElt v = unzipTElt $ toRT v - unzipT v@(RT _) = unzipT $ toZV v unzipT (ZV v) = ZV *** ZV $ unzipIZV v @@ -172,7 +221,6 @@ {-# INLINABLE fmapT #-} {-# INLINABLE fmapTM #-} {-# INLINABLE zipWithT #-} - {-# INLINABLE unzipTElt #-} {-# INLINABLE unzipT #-} @@ -240,13 +288,15 @@ => Module.C (GF fp d) (RT m fp) where r *> v = case v of - RT (Arr arr) -> RT $ Arr $ RT.fromList (extent arr) $ unCoeffs $ r *> Coeffs $ RT.toList arr - ZV zv -> ZV $ fromJust $ iZipVector $ V.fromList $ unCoeffs $ r *> Coeffs $ V.toList $ unIZipVector zv + RT (Arr arr) -> RT $ Arr $ RT.fromList (extent arr) + $ unCoeffs $ r *> Coeffs $ RT.toList arr + ZV zv -> ZV $ fromJust $ iZipVector $ V.fromList + $ unCoeffs $ r *> Coeffs $ V.toList $ unIZipVector zv ---------- Miscellaneous instances ---------- instance (Unbox r, Random (Arr m r)) => Random (RT m r) where - random = runRand $ RT <$> (liftRand random) + random = runRand $ RT <$> liftRand random randomR = error "randomR nonsensical for RT" diff --git a/Crypto/Lol/Cyclotomic/Tensor/RepaTensor/CRT.hs b/Crypto/Lol/Cyclotomic/Tensor/RepaTensor/CRT.hs --- a/Crypto/Lol/Cyclotomic/Tensor/RepaTensor/CRT.hs +++ b/Crypto/Lol/Cyclotomic/Tensor/RepaTensor/CRT.hs @@ -1,5 +1,6 @@ -{-# LANGUAGE ConstraintKinds, FlexibleContexts, GADTs, NoImplicitPrelude, - ScopedTypeVariables #-} +{-# LANGUAGE ConstraintKinds, FlexibleContexts, GADTs, + MultiParamTypeClasses, NoImplicitPrelude, ScopedTypeVariables + #-} -- | Functions to support the chinese remainder transform on Repa arrays @@ -12,17 +13,16 @@ import Crypto.Lol.CRTrans import Crypto.Lol.Cyclotomic.Tensor -import Crypto.Lol.Cyclotomic.Tensor.RepaTensor.GL import Crypto.Lol.Cyclotomic.Tensor.RepaTensor.RTCommon as RT -import Crypto.Lol.LatticePrelude as LP +import Crypto.Lol.Prelude as LP import Control.Applicative import Data.Coerce import Data.Singletons.Prelude -- | Embeds a scalar into the CRT basis (when it exists). -scalarCRT' :: forall m r . (Fact m, CRTrans r, Unbox r) - => Maybe (r -> Arr m r) +scalarCRT' :: forall mon m r . (Fact m, CRTrans mon r, Unbox r) + => mon (r -> Arr m r) {-# INLINABLE scalarCRT' #-} scalarCRT' = let pps = proxy ppsFact (Proxy::Proxy m) @@ -30,52 +30,56 @@ in pure $ Arr . force . fromFunction sz . const -- | Multiply by @g_m@ in the CRT basis (when it exists). -mulGCRT' :: forall m r . (Fact m, CRTrans r, Unbox r, Elt r) - => Maybe (Arr m r -> Arr m r) +mulGCRT' :: (Fact m, CRTrans mon r, Unbox r, Elt r) + => mon (Arr m r -> Arr m r) {-# INLINABLE mulGCRT' #-} mulGCRT' = (coerce (\x -> force . RT.zipWith (*) x) `asTypeOf` asTypeOf) <$> gCRT -- | Divide by @g@ in the CRT basis (when it exists). -divGCRT' :: (Fact m, CRTrans r, IntegralDomain r, ZeroTestable r, - Unbox r, Elt r) => Maybe (Arr m r -> Arr m r) +divGCRT' :: (Fact m, CRTrans mon r, Unbox r, Elt r) => mon (Arr m r -> Arr m r) {-# INLINABLE divGCRT' #-} -divGCRT' = (coerce (\x -> force . RT.zipWith (*) x) `asTypeOf` asTypeOf) <$> gInvCRT +divGCRT' = (coerce (\x -> force . RT.zipWith (*) x) `asTypeOf` asTypeOf) <$> gInvCRT --- | The representation of @g@ in the CRT basis (when it exists). -gCRT :: (Fact m, CRTrans r, Unbox r, Elt r) => Maybe (Arr m r) -{-# INLINABLE gCRT #-} -gCRT = fCRT <*> pure (fGPow $ scalarPow' LP.one) +wrapVector :: forall mon m r . (Monad mon, Fact m, Ring r, Unbox r, Elt r) + => TaggedT m mon (Matrix r) -> mon (Arr m r) +wrapVector v = do + vmat <- proxyT v (Proxy::Proxy m) + let n = proxy totientFact (Proxy::Proxy m) + return $ coerce $ force $ RT.fromFunction (Z:.n) + (\(Z:.i) -> indexM vmat i 0) --- | The representation of @g^{ -1 }@ in the CRT basis (when it exists). -gInvCRT:: (Fact m, CRTrans r, IntegralDomain r, - ZeroTestable r, Unbox r, Elt r) - => Maybe (Arr m r) +gCRT, gInvCRT :: (Fact m, CRTrans mon r, Unbox r, Elt r) => mon (Arr m r) +{-# INLINABLE gCRT #-} {-# INLINABLE gInvCRT #-} -gInvCRT = fCRT <*> fGInvPow (scalarPow' LP.one) +-- | The coefficient vector of @g@ in the CRT basis (when it exists). +gCRT = wrapVector gCRTM +-- | The coefficient vector of @g^{ -1 }@ in the CRT basis (when it exists). +gInvCRT = wrapVector gInvCRTM + fCRT, fCRTInv :: - forall m r . (Fact m, CRTrans r, Unbox r, Elt r) - => Maybe (Arr m r -> Arr m r) + forall mon m r . (Fact m, CRTrans mon r, Unbox r, Elt r) + => mon (Arr m r -> Arr m r) {-# INLINABLE fCRT #-} {-# INLINABLE fCRTInv #-} --- | The chinese remainder transform. --- Exists if and only if crt exists for all prime powers. +-- | The Chinese Remainder Transform. +-- Exists if and only if CRT exists for all prime powers. fCRT = evalM $ fTensor ppCRT -- divide by mhat after doing crtInv' --- | The inverse chinese remainder transform. --- Exists if and only if crt exists for all prime powers. -fCRTInv = do -- in Maybe - (_, mhatInv) :: (CRTInfo r) <- proxyT crtInfoFact (Proxy :: Proxy m) +-- | The inverse Chinese Remainder Transform. +-- Exists if and only if CRT exists for all prime powers. +fCRTInv = do + (_, mhatInv) :: (CRTInfo r) <- proxyT crtInfo (Proxy :: Proxy m) let totm = proxy totientFact (Proxy :: Proxy m) divMhat = trans totm $ RT.map (*mhatInv) evalM $ (divMhat .*) <$> fTensor ppCRTInv' ppDFT, ppDFTInv', ppCRT, ppCRTInv' :: - forall pp r . (PPow pp, CRTrans r, Unbox r, Elt r) - => TaggedT pp Maybe (Trans r) + forall mon pp r . (PPow pp, CRTrans mon r, Unbox r, Elt r) + => TaggedT pp mon (Trans r) {-# INLINABLE ppDFT #-} {-# INLINABLE ppDFTInv' #-} @@ -139,8 +143,8 @@ -- DFT_p, CRT_p, scaled DFT_p^{ -1 } and CRT_p^{ -1 } pDFT, pDFTInv', pCRT, pCRTInv' :: - forall p r . (Prim p, CRTrans r, Unbox r, Elt r) - => TaggedT p Maybe (Trans r) + forall mon p r . (Prime p, CRTrans mon r, Unbox r, Elt r) + => TaggedT p mon (Trans r) {-# INLINABLE pDFT #-} {-# INLINABLE pDFTInv' #-} @@ -150,7 +154,7 @@ pDFT = let pval = proxy valuePrime (Proxy::Proxy p) in if pval == 2 then return butterfly - else do (omegaPPow, _) <- crtInfoPrime + else do (omegaPPow, _) <- crtInfo return $ trans pval $ mulMat $ force $ fromFunction (Z :. pval :. pval) (\(Z:.i:.j) -> omegaPPow (i*j)) @@ -158,7 +162,7 @@ pDFTInv' = let pval = proxy valuePrime (Proxy::Proxy p) in if pval == 2 then return butterfly - else do (omegaPPow, _) <- crtInfoPrime + else do (omegaPPow, _) <- crtInfo return $ trans pval $ mulMat $ force $ fromFunction (Z :. pval :. pval) (\(Z:.i:.j) -> omegaPPow (-i*j)) @@ -166,7 +170,7 @@ pCRT = let pval = proxy valuePrime (Proxy::Proxy p) in if pval == 2 then return $ Id 1 - else do (omegaPPow, _) <- crtInfoPrime + else do (omegaPPow, _) <- crtInfo return $ trans (pval-1) $ mulMat $ force $ fromFunction (Z :. pval-1 :. pval-1) (\(Z:.i:.j) -> omegaPPow ((i+1)*j)) @@ -176,7 +180,7 @@ let pval = proxy valuePrime (Proxy::Proxy p) in if pval == 2 then return $ Id 1 else do - (omegaPPow, _) <- crtInfoPrime + (omegaPPow, _) <- crtInfo return $ trans (pval-1) $ mulMat $ force $ fromFunction (Z :. pval-1 :. pval-1) (\(Z:.i:.j) -> omegaPPow (negate i*(j+1)) - @@ -184,8 +188,8 @@ -- twiddle factors for DFT_pp and CRT_pp decompositions ppTwid, ppTwidHat :: - forall pp r . (PPow pp, CRTrans r, Unbox r, Elt r) - => Bool -> TaggedT pp Maybe (Trans r) + forall mon pp r . (PPow pp, CRTrans mon r, Unbox r, Elt r) + => Bool -> TaggedT pp mon (Trans r) {-# INLINABLE ppTwid #-} {-# INLINABLE ppTwidHat #-} @@ -194,7 +198,7 @@ let pp@(p,e) = proxy ppPPow (Proxy :: Proxy pp) ppval = valuePP pp in do - (omegaPPPow, _) <- crtInfoPPow + (omegaPPPow, _) <- crtInfo return $ trans ppval $ mulDiag $ force $ fromFunction (Z :. ppval) (\(Z:.i) -> let (iq,ir) = i `divMod` p @@ -206,7 +210,7 @@ let pp@(p,e) = proxy ppPPow (Proxy :: Proxy pp) pptot = totientPP pp in do - (omegaPPPow, _) <- crtInfoPPow + (omegaPPPow, _) <- crtInfo return $ trans pptot $ mulDiag $ force $ fromFunction (Z :. pptot) (\(Z:.i) -> let (iq,ir) = i `divMod` (p-1) diff --git a/Crypto/Lol/Cyclotomic/Tensor/RepaTensor/Dec.hs b/Crypto/Lol/Cyclotomic/Tensor/RepaTensor/Dec.hs --- a/Crypto/Lol/Cyclotomic/Tensor/RepaTensor/Dec.hs +++ b/Crypto/Lol/Cyclotomic/Tensor/RepaTensor/Dec.hs @@ -8,7 +8,7 @@ import Crypto.Lol.Cyclotomic.Tensor.RepaTensor.RTCommon as R import Crypto.Lol.GaussRandom -import Crypto.Lol.LatticePrelude +import Crypto.Lol.Prelude import Control.Monad.Random @@ -33,7 +33,7 @@ fE = eval $ fTensor $ ppTensor pE -- | The @E_p@ transformation for a prime @p@. -pE :: forall p r . (Prim p, Transcendental r, Unbox r, Elt r) +pE :: forall p r . (Prime p, Transcendental r, Unbox r, Elt r) => Tagged p (Trans r) pE = let pval = proxy valuePrime (Proxy::Proxy p) in tag $ if pval==2 then Id 1 @@ -62,7 +62,7 @@ fGramDec' = eval $ fTensor $ ppTensor pGramDec -- | Multiply by (scaled) Gram matrix of decoding basis: (I_{p-1} + all-1s). -pGramDec :: forall p r . (Prim p, Ring r, Unbox r, Elt r) => Tagged p (Trans r) +pGramDec :: forall p r . (Prime p, Ring r, Unbox r, Elt r) => Tagged p (Trans r) pGramDec = let pval = proxy valuePrime (Proxy::Proxy p) in tag $ if pval==2 then Id 1 diff --git a/Crypto/Lol/Cyclotomic/Tensor/RepaTensor/Extension.hs b/Crypto/Lol/Cyclotomic/Tensor/RepaTensor/Extension.hs --- a/Crypto/Lol/Cyclotomic/Tensor/RepaTensor/Extension.hs +++ b/Crypto/Lol/Cyclotomic/Tensor/RepaTensor/Extension.hs @@ -1,7 +1,7 @@ {-# LANGUAGE BangPatterns, ConstraintKinds, DataKinds, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, NoImplicitPrelude, - PolyKinds, ScopedTypeVariables, TemplateHaskell, TypeFamilies, - TypeOperators #-} + PolyKinds, ScopedTypeVariables, TemplateHaskell, + TypeFamilies, TypeOperators #-} -- | RT-specific functions for embedding/twacing in various bases @@ -10,22 +10,22 @@ , coeffs', powBasisPow', crtSetDec' ) where -import Crypto.Lol.LatticePrelude as LP hiding (lift, (!!)) import Crypto.Lol.CRTrans -import Crypto.Lol.Reflects -import qualified Crypto.Lol.Cyclotomic.Tensor as T +import qualified Crypto.Lol.Cyclotomic.Tensor as T import Crypto.Lol.Cyclotomic.Tensor.RepaTensor.CRT import Crypto.Lol.Cyclotomic.Tensor.RepaTensor.RTCommon as RT -import Crypto.Lol.Types.FiniteField -import Crypto.Lol.Types.ZmStar +import Crypto.Lol.Prelude as LP +import Crypto.Lol.Types.FiniteField +import Crypto.Lol.Types.ZmStar + import Control.Applicative -import Control.Arrow (first, (***)) +import Control.Arrow (first, second) import Data.Coerce import Data.Default import Data.Maybe -import Data.Reflection (reify) +import Data.Reflection (reify) import qualified Data.Vector as V import qualified Data.Vector.Unboxed as U import Data.Vector.Unboxed.Deriving @@ -41,7 +41,7 @@ [| (Z :.) |] -- | The "tweaked trace" function in either the powerful or decoding --- basis of the m'th cyclotomic ring to the mth cyclotomic ring when +-- basis of the m'th cyclotomic ring to the mth cyclotomic ring when -- @m | m'@. twacePowDec' :: forall m m' r . (m `Divides` m', Unbox r) => Arr m' r -> Arr m r @@ -50,22 +50,21 @@ in coerce $ \ !arr -> force $ backpermute (extent indices) (indices !) arr -- | The "tweaked trace" function in the CRT --- basis of the m'th cyclotomic ring to the mth cyclotomic ring when +-- basis of the m'th cyclotomic ring to the mth cyclotomic ring when -- @m | m'@. -twaceCRT' :: forall m m' r . - (m `Divides` m', CRTrans r, IntegralDomain r, - ZeroTestable r, Unbox r, Elt r) - => Maybe (Arr m' r -> Arr m r) -twaceCRT' = do -- Maybe monad +twaceCRT' :: forall mon m m' r . + (m `Divides` m', CRTrans mon r, Unbox r, Elt r) + => mon (Arr m' r -> Arr m r) +twaceCRT' = do g' :: Arr m' r <- gCRT gInv <- gInvCRT embed :: Arr m r -> Arr m' r <- embedCRT' - (_, m'hatinv) <- proxyT crtInfoFact (Proxy::Proxy m') + (_, m'hatinv) <- proxyT crtInfo (Proxy::Proxy m') let hatRatioInv = m'hatinv * fromIntegral (proxy valueHatFact (Proxy::Proxy m)) -- tweak = mhat * g' / (m'hat * g) tweak = (coerce $ \x -> force . RT.map (* hatRatioInv) . RT.zipWith (*) x) (embed gInv) g' :: Arr m' r indices = proxy extIndicesCRT (Proxy::Proxy '(m, m')) - return $ + return $ -- take true trace after mul-by-tweak coerce (\ !arr -> sumS . backpermute (extent indices) (indices !) . RT.zipWith (*) arr) tweak @@ -92,11 +91,11 @@ -- | Embeds an array in the CRT basis of the the mth cyclotomic ring -- to an array in the CRT basis of the m'th cyclotomic ring when @m | m'@ -embedCRT' :: forall m m' r . (m `Divides` m', CRTrans r, Unbox r) - => Maybe (Arr m r -> Arr m' r) -embedCRT' = do -- in Maybe +embedCRT' :: forall mon m m' r . (m `Divides` m', CRTrans mon r, Unbox r) + => mon (Arr m r -> Arr m' r) +embedCRT' = do -- first check existence of CRT transform of index m' - proxyT crtInfoFact (Proxy::Proxy m') :: Maybe (CRTInfo r) + _ <- proxyT crtInfo (Proxy::Proxy m') :: mon (CRTInfo r) let idxs = proxy baseIndicesCRT (Proxy::Proxy '(m,m')) return $ coerce $ \ !arr -> (force $ backpermute (extent idxs) (idxs !) arr) @@ -114,7 +113,7 @@ -- Outputs a list of arrays in O_m' that are an O_m basis for O_m' powBasisPow' :: forall m m' r . (m `Divides` m', Ring r, Unbox r) => Tagged m [Arr m' r] -powBasisPow' = return $ +powBasisPow' = return $ let (_, phi, phi', _) = proxy T.indexInfo (Proxy::Proxy '(m,m')) idxs = proxy T.baseIndicesPow (Proxy::Proxy '(m,m')) in LP.map (\k -> Arr $ force $ fromFunction (Z :. phi') @@ -128,7 +127,7 @@ (m `Divides` m', PrimeField fp, Coprime (PToF (CharOf fp)) m', Unbox fp) => Tagged m [Arr m' fp] -crtSetDec' = return $ +crtSetDec' = return $ let m'p = Proxy :: Proxy m' p = proxy valuePrime (Proxy::Proxy (CharOf fp)) phi = proxy totientFact m'p @@ -143,7 +142,7 @@ elt j i = T.indexM twCRTs' j (zmsToIdx i) trace' = trace :: GF fp d -> fp cosets = proxy (partitionCosets p) (Proxy::Proxy '(m,m')) - in LP.map (\is -> Arr $ force $ fromFunction (Z :. phi) + in LP.map (\is -> Arr $ force $ fromFunction (Z :. phi) (\(Z:.j) -> hinv * trace' (sum $ LP.map (elt j) is))) cosets @@ -176,7 +175,7 @@ baseIndicesPow = do idxs <- T.baseIndicesPow - return $ fromUnboxed (Z :. U.length idxs) $ U.map (id *** (Z:.)) idxs + return $ fromUnboxed (Z :. U.length idxs) $ U.map (second (Z:.)) idxs baseIndicesDec = do idxs <- T.baseIndicesDec @@ -188,6 +187,6 @@ extIndicesCoeffs :: forall m m' . (m `Divides` m') => Tagged '(m, m') (V.Vector (Array U DIM1 DIM1)) -extIndicesCoeffs = - V.map (\arr -> fromUnboxed (Z :. U.length arr) $ +extIndicesCoeffs = + V.map (\arr -> fromUnboxed (Z :. U.length arr) $ U.map (Z:.) arr) <$> T.extIndicesCoeffs diff --git a/Crypto/Lol/Cyclotomic/Tensor/RepaTensor/GL.hs b/Crypto/Lol/Cyclotomic/Tensor/RepaTensor/GL.hs --- a/Crypto/Lol/Cyclotomic/Tensor/RepaTensor/GL.hs +++ b/Crypto/Lol/Cyclotomic/Tensor/RepaTensor/GL.hs @@ -9,7 +9,7 @@ ) where import Crypto.Lol.Cyclotomic.Tensor.RepaTensor.RTCommon as RT -import Crypto.Lol.LatticePrelude as LP +import Crypto.Lol.Prelude as LP import Data.Coerce fL, fLInv, fGPow, fGDec :: (Fact m, Additive r, Unbox r, Elt r) @@ -46,7 +46,7 @@ wrapGInv' :: forall m r . (Fact m, IntegralDomain r, ZeroTestable r, Unbox r, Elt r) - => (forall p . Prim p => Tagged p (Trans r)) + => (forall p . Prime p => Tagged p (Trans r)) -> Arr m r -> Maybe (Arr m r) wrapGInv' ginv = let fGInv = eval $ fTensor $ ppTensor ginv @@ -65,7 +65,7 @@ in if pass then Just out else Nothing {-# INLINABLE divCheck #-} -pWrap :: forall p r . Prim p +pWrap :: forall p r . Prime p => (forall rep . Source rep r => Int -> Array rep DIM2 r -> Array D DIM2 r) -> Tagged p (Trans r) pWrap f = let pval = proxy valuePrime (Proxy::Proxy p) @@ -76,10 +76,10 @@ {-# INLINABLE pWrap #-} -pL, pLInv, pGPow, pGDec :: (Prim p, Additive r, Unbox r, Elt r) +pL, pLInv, pGPow, pGDec :: (Prime p, Additive r, Unbox r, Elt r) => Tagged p (Trans r) -pGInvPow', pGInvDec' :: (Prim p, Ring r, Unbox r, Elt r) +pGInvPow', pGInvDec' :: (Prime p, Ring r, Unbox r, Elt r) => Tagged p (Trans r) {-# INLINABLE pL #-} {-# INLINABLE pLInv #-} diff --git a/Crypto/Lol/Cyclotomic/Tensor/RepaTensor/RTCommon.hs b/Crypto/Lol/Cyclotomic/Tensor/RepaTensor/RTCommon.hs --- a/Crypto/Lol/Cyclotomic/Tensor/RepaTensor/RTCommon.hs +++ b/Crypto/Lol/Cyclotomic/Tensor/RepaTensor/RTCommon.hs @@ -18,14 +18,14 @@ , sumS, sumAllS ) where -import Crypto.Lol.LatticePrelude as LP hiding ((!!)) +import Crypto.Lol.Prelude as LP hiding ((!!)) -import Algebra.Additive as Additive (C) -import Algebra.Ring as Ring (C) +import Algebra.Additive as Additive (C) +import Algebra.Ring as Ring (C) import Algebra.ZeroTestable as ZeroTestable (C) import Control.DeepSeq (NFData (..)) -import Control.Monad.Identity +import Control.Monad.Identity () import Control.Monad.Random import Data.Array.Repa as R hiding (sumAllP, sumAllS, sumP, sumS, (*^), (+^), (-^), (/^)) @@ -34,12 +34,9 @@ import Data.Coerce import Data.Singletons import Data.Singletons.Prelude hiding ((:.)) -import qualified Data.Vector.Unboxed as U +import Data.Vector.Unboxed as U (replicate, replicateM) import Test.QuickCheck --- just for specialization -import Crypto.Lol.Types.ZqBasic - -- always unboxed (manifest); intermediate calculations can use -- delayed arrays @@ -65,7 +62,7 @@ replM :: forall m r mon . (Fact m, Unbox r, Monad mon) => mon r -> mon (Arr m r) replM = let n = proxy totientFact (Proxy::Proxy m) - in liftM (Arr . fromUnboxed (Z:.n)) . U.replicateM n + in fmap (Arr . fromUnboxed (Z:.n)) . U.replicateM n {-# INLINABLE replM #-} instance (Fact m, Additive r, Unbox r, Elt r) => Additive.C (Arr m r) where @@ -86,7 +83,7 @@ instance (Fact m, ZeroTestable r, Unbox r, Elt r) => ZeroTestable.C (Arr m r) where -- not using 'zero' to avoid Additive r constraint - isZero (Arr a) + isZero (Arr a) = isZero $ foldAllS (\ x y -> if isZero x then y else x) (a R.! (Z:.0)) a {-# INLINABLE isZero #-} @@ -125,7 +122,7 @@ -- | For a prime power p^e, tensors up any function f defined for -- (and tagged by) a prime to @I_(p^{e-1}) \otimes f@ ppTensor :: forall pp r mon . (PPow pp, Monad mon) - => (forall p . (Prim p) => TaggedT p mon (Trans r)) + => (forall p . (Prime p) => TaggedT p mon (Trans r)) -> TaggedT pp mon (Trans r) ppTensor func = tagT $ case (sing :: SPrimePower pp) of @@ -200,7 +197,7 @@ -- | Monadic version of 'eval' evalM :: (Unbox r, Monad mon) => TaggedT m mon (Trans r) -> mon (Arr m r -> Arr m r) -evalM = liftM (eval . return) . untagT +evalM = fmap (eval . return) . untagT {-# INLINE evalM #-} -- | maps the innermost dimension to a 2-dim array with innermost dim d, @@ -234,7 +231,7 @@ in if mcols == vrows then fromFunction (sh :. mrows) f else error "mulMatVec: mcols != vdim" {-# INLINABLE mulMat #-} - + -- | multiplication by a diagonal matrix along innermost dim mulDiag :: (Source r1 r, Source r2 r, Ring r, Unbox r, Elt r) => Array r1 DIM1 r -> Array r2 DIM2 r -> Array D DIM2 r @@ -247,7 +244,7 @@ -- | Embeds a scalar into a powerful-basis representation of a Repa array, -- tagged by the cyclotomic index scalarPow' :: forall m r . (Fact m, Additive r, Unbox r) => r -> Arr m r -scalarPow' = coerce . (go $ proxy totientFact (Proxy::Proxy m)) +scalarPow' = coerce . go (proxy totientFact (Proxy::Proxy m)) where go n !r = let fct (Z:.0) = r fct _ = LP.zero in force $ fromFunction (Z:.n) fct diff --git a/Crypto/Lol/Cyclotomic/UCyc.hs b/Crypto/Lol/Cyclotomic/UCyc.hs --- a/Crypto/Lol/Cyclotomic/UCyc.hs +++ b/Crypto/Lol/Cyclotomic/UCyc.hs @@ -1,8 +1,18 @@ -{-# LANGUAGE ConstraintKinds, DataKinds, FlexibleContexts, - FlexibleInstances, GADTs, InstanceSigs, MultiParamTypeClasses, - NoImplicitPrelude, PolyKinds, RankNTypes, RebindableSyntax, - ScopedTypeVariables, TypeFamilies, TypeOperators, - UndecidableInstances #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} -- | A low-level implementation of cyclotomic rings that allows (and -- requires) the programmer to control the underlying representation @@ -18,28 +28,29 @@ module Crypto.Lol.Cyclotomic.UCyc ( -- * Data types and constraints - UCyc, P, D, C, UCElt, NFElt + UCyc, P, D, C, E, UCycEC, UCRTElt, NFElt -- * Changing representation -, toPow, toDec, toCRT, fmapPow, fmapDec, unzipCyc, unzipUCElt +, toPow, toDec, toCRT, fmapPow, fmapDec +, unzipPow, unzipDec, unzipCRTC, unzipCRTE -- * Scalars -, scalarPow, scalarCRT -- scalarDec suppressed +, scalarPow, scalarCRT -- * Basic operations , mulG, divG, gSqNorm -- * Error sampling , tGaussian, errorRounded, errorCoset -- * Inter-ring operations and values -, embedPow, embedDec, embedCRT -, twacePow, twaceDec, twaceCRT +, embedPow, embedDec, embedCRTC, embedCRTE +, twacePow, twaceDec, twaceCRTC, twaceCRTE , coeffsPow, coeffsDec, powBasis, crtSet ) where import Crypto.Lol.Cyclotomic.Tensor hiding (embedCRT, embedDec, embedPow, - scalarCRT, scalarPow, -- scalarDec - twaceCRT) + scalarCRT, scalarPow, twaceCRT) import Crypto.Lol.CRTrans -import qualified Crypto.Lol.Cyclotomic.Tensor as T -import Crypto.Lol.LatticePrelude as LP +import Crypto.Lol.Cyclotomic.CRTSentinel +import qualified Crypto.Lol.Cyclotomic.Tensor as T +import Crypto.Lol.Prelude as LP import Crypto.Lol.Types.FiniteField import Crypto.Lol.Types.ZPP @@ -51,22 +62,30 @@ import Control.Applicative as A import Control.Arrow import Control.DeepSeq -import Control.Monad +import Control.Monad.Identity import Control.Monad.Random import Data.Foldable as F import Data.Maybe import Data.Traversable import Test.QuickCheck +import Crypto.Lol.Types.Proto + --import qualified Debug.Trace as DT -- | Nullary index type representing the powerful basis. data P -- | Nullary index type representing the decoding basis. data D --- | Nullary index type representing a CRT basis. +-- | Nullary index type representing the CRT basis over base ring. data C +-- | Nullary index type representing the CRT basis over extension of +-- base ring. +data E +-- | Convenient synonym for either CRT representation. +type UCycEC t m r = Either (UCyc t m E r) (UCyc t m C r) + -- | Represents a cyclotomic ring such as @Z[zeta]@, -- @Zq[zeta]@, and @Q(zeta)@ in an explicit representation: @t@ is the -- 'Tensor' type for storing coefficient tensors; @m@ is the @@ -75,17 +94,18 @@ -- -- The 'Functor', 'Applicative', 'Foldable' and 'Traversable' -- instances all work coefficient-wise (in the specified basis). -data UCyc t m rep r where +data UCyc t (m :: Factored) rep r where Pow :: !(t m r) -> UCyc t m P r Dec :: !(t m r) -> UCyc t m D r - -- Invariant: for a given (t,m,r), exactly one of these two is ever - -- used: CRTr if crtFuncs exists, otherwise CRTe - CRTr :: !(t m r) -> UCyc t m C r - CRTe :: !(t m (CRTExt r)) -> UCyc t m C r + -- Use CRTSentinel to enforce invariant that exactly one of these + -- can be created for a given (t,m,r). + CRTC :: !(CSentinel t m r) -> !(t m r) -> UCyc t m C r + CRTE :: !(ESentinel t m r) -> !(t m (CRTExt r)) -> UCyc t m E r --- | Constraints needed for many operations involving the 'UCyc' CRT ('C') --- representation. -type UCElt t r = (Tensor t, CRTEmbed r, CRTElt t r, CRTElt t (CRTExt r)) +-- | Constraints needed for CRT-related operations on 'UCyc' data. +type UCRTElt t r = (Tensor t, CRTEmbed r, + CRTrans Maybe r, TElt t r, + CRTrans Identity (CRTExt r), TElt t (CRTExt r)) -- | Convenient synonym for 'deepseq'-able element type. type NFElt r = (NFData r, NFData (CRTExt r)) @@ -95,20 +115,11 @@ scalarPow = Pow . T.scalarPow {-# INLINABLE scalarPow #-} -{- CJP: suppressed - -- | Embed a scalar from the base ring. -scalarDec :: (Tensor t, Fact m, Ring r, TElt t r) => r -> UCyc t m D r -scalarDec = Dec . T.scalarDec -{-# INLINABLE scalarDec #-} - --} - --- | Embed a scalar from the base ring. -scalarCRT :: (Fact m, UCElt t r) => r -> UCyc t m C r -scalarCRT = fromMaybe - (CRTe . fromJust' "UCyc: no CRT over CRTExt" T.scalarCRT . toExt) - ((CRTr .) <$> T.scalarCRT) +scalarCRT :: (Fact m, UCRTElt t r) => r -> UCycEC t m r +scalarCRT r = case crtSentinel of + Right s -> Right $ CRTC s $ scalarCRTCS s r + Left s -> Left $ CRTE s $ runIdentity T.scalarCRT $ toExt r {-# INLINABLE scalarCRT #-} -- Eq instances @@ -121,12 +132,11 @@ (Dec v1) == (Dec v2) = v1 == v2 \\ witness entailEqT v1 {-# INLINABLE (==) #-} -instance (Eq r, Fact m, UCElt t r) => Eq (UCyc t m C r) where - (CRTr v1) == (CRTr v2) = v1 == v2 \\ witness entailEqT v1 - -- compare in pow due to precision - u1 == u2 = toPow u1 == toPow u2 +instance (Eq r, Tensor t, Fact m, TElt t r) => Eq (UCyc t m C r) where + (CRTC _ v1) == (CRTC _ v2) = v1 == v2 \\ witness entailEqT v1 {-# INLINABLE (==) #-} +-- no Eq instance for E due to precision ---------- Numeric Prelude instances ---------- @@ -142,13 +152,13 @@ isZero (Dec v) = isZero v \\ witness entailZTT v {-# INLINABLE isZero #-} -instance (ZeroTestable r, Fact m, UCElt t r) +instance (ZeroTestable r, Tensor t, Fact m, TElt t r) => ZeroTestable.C (UCyc t m C r) where - isZero (CRTr v) = isZero v \\ witness entailZTT v - -- use powerful basis due to precision - isZero u = isZero $ toPow u + isZero (CRTC _ v) = isZero v \\ witness entailZTT v {-# INLINABLE isZero #-} +-- no ZT instance for E due to precision + -- Additive instances instance (Additive r, Tensor t, Fact m, TElt t r) => Additive.C (UCyc t m P r) where @@ -171,38 +181,39 @@ {-# INLINABLE (-) #-} {-# INLINABLE negate #-} -instance (Fact m, UCElt t r) => Additive.C (UCyc t m C r) where +-- | only for appropriate CRT representation (otherwise 'zero' would +-- violate internal invariant) +instance (Fact m, UCRTElt t r) => Additive.C (UCycEC t m r) where + zero = scalarCRT zero -- CJP: precision OK? Alternatively, switch to pow and back after -- adding/subtracting. Expensive, but necessary given output type. - (CRTr v1) + (CRTr v2) = CRTr $ zipWithT (+) v1 v2 - (CRTe v1) + (CRTe v2) = CRTe $ zipWithT (+) v1 v2 - _ + _ = error "UCyc (+) internal error: mixed CRTr/CRTe" + (Right (CRTC s v1)) + (Right (CRTC _ v2)) = Right $ CRTC s $ zipWithT (+) v1 v2 + (Left (CRTE s v1)) + (Left (CRTE _ v2)) = Left $ CRTE s $ zipWithT (+) v1 v2 + _ + _ = error "UCyc (+) internal error: mixed CRTC/CRTE" - (CRTr v1) - (CRTr v2) = CRTr $ zipWithT (-) v1 v2 - (CRTe v1) - (CRTe v2) = CRTe $ zipWithT (-) v1 v2 - _ - _ = error "UCyc (-) internal error: mixed CRTr/CRTe" + (Right (CRTC s v1)) - (Right (CRTC _ v2)) = Right $ CRTC s $ zipWithT (-) v1 v2 + (Left (CRTE s v1)) - (Left (CRTE _ v2)) = Left $ CRTE s $ zipWithT (-) v1 v2 + _ - _ = error "UCyc (-) internal error: mixed CRTC/CRTE" - negate (CRTr v) = CRTr $ fmapT negate v - negate (CRTe v) = CRTe $ fmapT negate v + negate (Right (CRTC s v)) = Right $ CRTC s $ fmapT negate v + negate (Left (CRTE s v)) = Left $ CRTE s $ fmapT negate v {-# INLINABLE zero #-} {-# INLINABLE (+) #-} {-# INLINABLE (-) #-} {-# INLINABLE negate #-} --- Ring instance: only for CRT +-- | only for appropriate CRT representation +instance (Fact m, UCRTElt t r) => Ring.C (UCycEC t m r) where -instance (Fact m, UCElt t r) => Ring.C (UCyc t m C r) where one = scalarCRT one fromInteger c = scalarCRT $ fromInteger c - -- CJP: precision OK? Alternatively, switch to pow (and back) after - -- multiplying. Expensive, but necessary given output type. - (CRTr v1) * (CRTr v2) = CRTr $ zipWithT (*) v1 v2 - (CRTe v1) * (CRTe v2) = CRTe $ zipWithT (*) v1 v2 - _ * _ = error "UCyc internal error: mixed CRTr/CRTe" + (Right (CRTC s v1)) * (Right (CRTC _ v2)) = Right $ CRTC s $ zipWithT (*) v1 v2 + (Left (CRTE s v1)) * (Left (CRTE _ v2)) = Left $ CRTE s $ zipWithT (*) v1 v2 + _ * _ = error "UCyc internal error: mixed CRTC/CRTE" {-# INLINABLE one #-} {-# INLINABLE fromInteger #-} @@ -217,12 +228,17 @@ r *> (Dec v) = Dec $ fmapT (r *) v {-# INLINABLE (*>) #-} -instance (Ring r, Fact m, UCElt t r) => Module.C r (UCyc t m C r) where - r *> (CRTr v) = CRTr $ fmapT (r *) v - r *> (CRTe v) = CRTe $ fmapT (toExt r *) v +instance (Ring r, Fact m, UCRTElt t r) => Module.C r (UCycEC t m r) where + + r *> (Right (CRTC s v)) = Right $ CRTC s $ fmapT (r *) v + r *> (Left (CRTE s v)) = Left $ CRTE s $ fmapT (toExt r *) v {-# INLINABLE (*>) #-} -instance (GFCtx fp d, Fact m, UCElt t fp) => Module.C (GF fp d) (UCyc t m P fp) where +-- | @Rp@ is an @F_{p^d}@-module when @d@ divides @phi(m)@, by +-- applying @d@-dimensional @Fp@-linear transform on @d@-dim chunks of +-- powerful basis coeffs +instance (GFCtx fp d, Fact m, Tensor t, TElt t fp) + => Module.C (GF fp d) (UCyc t m P fp) where -- can use any r-basis to define module mult, but must be -- consistent. r *> (Pow v) = Pow $ r LP.*> v \\ witness entailModuleT (r,v) @@ -238,7 +254,8 @@ reduce (Dec v) = Dec $ fmapT reduce v {-# INLINABLE reduce #-} --- CJP: no Reduce for C rep because we can't efficiently handle CRTe case +-- CJP: no Reduce for C because CRT basis may not exist for target +-- type type instance LiftOf (UCyc t m P r) = UCyc t m P (LiftOf r) type instance LiftOf (UCyc t m D r) = UCyc t m D (LiftOf r) @@ -253,6 +270,7 @@ lift (Dec v) = Dec $ fmapT lift v {-# INLINABLE lift #-} +-- CJP: no Lift' for C because CRT basis may not exist for target type instance (Rescale a b, Tensor t, Fact m, TElt t a, TElt t b) => Rescale (UCyc t m P a) (UCyc t m P b) where @@ -264,63 +282,88 @@ rescale (Dec v) = Dec $ fmapT rescale v {-# INLINABLE rescale #-} +-- CJP: no Rescale for C because CRT basis may not exist for target +-- type -- CJP: we don't instantiate RescaleCyc because it requires changing bases -- CJP: we don't instantiate Gadget etc., because (1) their methods --- wouldn't be efficient, and (2) their superclasses are not even --- well-defined (e.g., Ring for P rep). +-- wouldn't be efficient, and (2) their superclass constraints are not +-- satisfied anyway (e.g., Ring for P rep). --- | Type-restricted (and potentially more efficient) map for +-- | Type-restricted (and potentially more efficient) 'fmap' for -- powerful-basis representation. fmapPow :: (Tensor t, Fact m, TElt t a, TElt t b) => (a -> b) -> UCyc t m P a -> UCyc t m P b fmapPow f (Pow v) = Pow $ fmapT f v {-# INLINABLE fmapPow #-} --- | Type-restricted (and potentially more efficient) map for +-- | Type-restricted (and potentially more efficient) 'fmap' for -- decoding-basis representation. fmapDec :: (Tensor t, Fact m, TElt t a, TElt t b) => (a -> b) -> UCyc t m D a -> UCyc t m D b fmapDec f (Dec v) = Dec $ fmapT f v {-# INLINABLE fmapDec #-} --- | Unzip for unrestricted types. -unzipCyc :: (Tensor t, Fact m) - => UCyc t m rep (a,b) -> (UCyc t m rep a, UCyc t m rep b) -{-# INLINABLE unzipCyc #-} -unzipCyc (Pow v) = Pow *** Pow $ unzipT v -unzipCyc (Dec v) = Dec *** Dec $ unzipT v -unzipCyc (CRTr v) = CRTr *** CRTr $ unzipT v -unzipCyc (CRTe v) = CRTe *** CRTe $ unzipT v +-- | Unzip in the powerful basis. +unzipPow :: (Tensor t, Fact m, TElt t (a,b), TElt t a, TElt t b) + => UCyc t m P (a,b) -> (UCyc t m P a, UCyc t m P b) +{-# INLINABLE unzipPow #-} +unzipPow (Pow v) = Pow *** Pow $ unzipT v --- | Type-restricted (and potentially more efficient) unzip. -unzipUCElt :: (Tensor t, Fact m, UCElt t (a,b), UCElt t a, UCElt t b) - => UCyc t m rep (a,b) -> (UCyc t m rep a, UCyc t m rep b) -{-# INLINABLE unzipUCElt #-} -unzipUCElt (Pow v) = Pow *** Pow $ unzipTElt v -unzipUCElt (Dec v) = Dec *** Dec $ unzipTElt v -unzipUCElt (CRTr v) = CRTr *** CRTr $ unzipTElt v -unzipUCElt (CRTe v) = CRTe *** CRTe $ unzipTElt v +-- | Unzip in the decoding basis. +unzipDec :: (Tensor t, Fact m, TElt t (a,b), TElt t a, TElt t b) + => UCyc t m D (a,b) -> (UCyc t m D a, UCyc t m D b) +{-# INLINABLE unzipDec #-} +unzipDec (Dec v) = Dec *** Dec $ unzipT v +-- | Unzip in the CRT basis over the base ring. The output components +-- are 'Either' because each target base ring may not support 'C'. +unzipCRTC :: (Tensor t, Fact m, UCRTElt t (a,b), UCRTElt t a, UCRTElt t b) + => UCyc t m C (a,b) + -> (Either (UCyc t m P a) (UCyc t m C a), + Either (UCyc t m P b) (UCyc t m C b)) +unzipCRTC (CRTC s v) + = let (ac,bc) = unzipT v + (ap,bp) = Pow *** Pow $ unzipT $ crtInvCS s v + in (fromMaybe (Left ap) (Right <$> (CRTC <$> crtCSentinel <*> pure ac)), + fromMaybe (Left bp) (Right <$> (CRTC <$> crtCSentinel <*> pure bc))) + +-- | Unzip in the CRT basis over the extension of the base ring. The +-- output components are 'Either' because each target base might +-- instead support 'C'. +unzipCRTE :: (Tensor t, Fact m, UCRTElt t (a,b), UCRTElt t a, UCRTElt t b) + => UCyc t m E (a,b) + -> (Either (UCyc t m P a) (UCyc t m E a), + Either (UCyc t m P b) (UCyc t m E b)) +unzipCRTE (CRTE _ v) + = let (ae,be) = unzipT v + (a',b') = unzipT $ fmapT fromExt $ runIdentity crtInv v + (ap,bp) = Pow *** Pow $ (a',b') + in (fromMaybe (Left ap) (Right <$> (CRTE <$> crtESentinel <*> pure ae)), + fromMaybe (Left bp) (Right <$> (CRTE <$> crtESentinel <*> pure be))) + + -- | Multiply by the special element @g@. -mulG :: (Tensor t, Fact m, UCElt t r) => UCyc t m rep r -> UCyc t m rep r +mulG :: (Tensor t, Fact m, UCRTElt t r) => UCyc t m rep r -> UCyc t m rep r {-# INLINABLE mulG #-} mulG (Pow v) = Pow $ mulGPow v mulG (Dec v) = Dec $ mulGDec v --- fromJust is safe here because we're already in CRTr -mulG (CRTr v) = CRTr $ fromJust' "UCyc.mulG CRTr" mulGCRT v -mulG (CRTe v) = CRTe $ fromJust' "UCyc.mulG CRTe" mulGCRT v +mulG (CRTC s v) = CRTC s $ mulGCRTCS s v +mulG (CRTE s v) = CRTE s $ runIdentity mulGCRT v -- | Divide by the special element @g@. -divG :: (Tensor t, Fact m, UCElt t r) => UCyc t m rep r -> Maybe (UCyc t m rep r) +-- WARNING: this implementation is not a constant-time algorithm, so +-- information about the argument may be leaked through a timing +-- channel. +divG :: (Tensor t, Fact m, UCRTElt t r, ZeroTestable r, IntegralDomain r) + => UCyc t m rep r -> Maybe (UCyc t m rep r) {-# INLINABLE divG #-} divG (Pow v) = Pow <$> divGPow v divG (Dec v) = Dec <$> divGDec v --- fromJust is OK here because we're already in CRTr -divG (CRTr v) = Just $ CRTr $ fromJust' "UCyc.divG CRTr" divGCRT v -divG (CRTe v) = Just $ CRTe $ fromJust' "UCyc.divG CRTe" divGCRT v +divG (CRTC s v) = Just $ CRTC s $ divGCRTCS s v +divG (CRTE s v) = Just $ CRTE s $ runIdentity divGCRT v -- | Yield the scaled squared norm of @g_m \cdot e@ under -- the canonical embedding, namely, @@ -330,10 +373,7 @@ {-# INLINABLE gSqNorm #-} -- | Sample from the "tweaked" Gaussian error distribution @t*D@ in --- the decoding basis, where @D@ has scaled variance @v@. (Note: This --- implementation uses Double precision to generate the Gaussian --- sample, which may not be sufficient for rigorous proof-based --- security.) +-- the decoding basis, where @D@ has scaled variance @v@. tGaussian :: (Tensor t, Fact m, OrdFloat q, Random q, TElt t q, ToRational v, MonadRandom rnd) => v -> rnd (UCyc t m D q) @@ -342,7 +382,10 @@ -- | Generate an LWE error term from the "tweaked" Gaussian with given -- scaled variance, deterministically rounded using the decoding --- basis. +-- basis. (Note: This +-- implementation uses Double precision to generate the Gaussian +-- sample, which may not be sufficient for rigorous proof-based +-- security.) errorRounded :: forall v rnd t m z . (ToInteger z, Tensor t, Fact m, TElt t z, ToRational v, MonadRandom rnd) @@ -353,7 +396,10 @@ -- | Generate an LWE error term from the "tweaked" Gaussian with -- scaled variance @v * p^2@, deterministically rounded to the given --- coset of @R_p@ using the decoding basis. +-- coset of @R_p@ using the decoding basis. (Note: This +-- implementation uses Double precision to generate the Gaussian +-- sample, which may not be sufficient for rigorous proof-based +-- security.) errorCoset :: forall t m zp z v rnd . (Mod zp, z ~ ModRep zp, Lift zp z, Tensor t, Fact m, TElt t zp, TElt t z, ToRational v, MonadRandom rnd) @@ -361,7 +407,7 @@ {-# INLINABLE errorCoset #-} errorCoset = let pval = fromIntegral $ proxy modulus (Proxy::Proxy zp) - in \ svar c -> do err <- tGaussian (svar*pval*pval) :: rnd (UCyc t m D Double) + in \ svar c -> do err :: UCyc t m D Double <- tGaussian (svar*pval*pval) return $! roundCoset <$> c <*> err @@ -379,21 +425,28 @@ embedDec (Dec v) = Dec $ T.embedDec v {-# INLINABLE embedDec #-} --- | Embed into an extension ring, for a CRT basis. (The output is --- an 'Either' because in some cases it is most efficient to preserve --- the 'UCyc' internal invariant by producing output with respect to --- the powerful basis.) -embedCRT :: forall t m m' r . (m `Divides` m', UCElt t r) - => UCyc t m C r -> Either (UCyc t m' P r) (UCyc t m' C r) -{-# INLINABLE embedCRT #-} -embedCRT x@(CRTr v) = fromMaybe (Left $ embedPow $ toPow x) - (Right . CRTr <$> (T.embedCRT <*> pure v)) -embedCRT x@(CRTe v) = - -- preserve invariant: CRTe iff CRTr is invalid for m' - fromMaybe (Right $ CRTe $ fromJust' "UCyc.embedCRT CRTe" T.embedCRT v) - (proxyT hasCRTFuncs (Proxy::Proxy (t m r)) A.*> - pure (Left $ embedPow $ toPow x)) +-- | Embed into an extension ring, for the CRT basis. (The output is +-- an 'Either' because the extension ring might not support 'C'.) +embedCRTC :: (m `Divides` m', UCRTElt t r) + => UCyc t m C r -> Either (UCyc t m' P r) (UCyc t m' C r) +{-# INLINABLE embedCRTC #-} +embedCRTC x@(CRTC s v) = + case crtSentinel of + -- go to CRTC if valid, else go to Pow + Left _ -> Left $ embedPow $ toPow x + Right s' -> Right $ CRTC s' $ embedCRTCS s s' v +-- | Similar to 'embedCRTC'. (The output is an 'Either' because the +-- extension ring might support 'C', in which case we never use 'E'.) +embedCRTE :: forall m m' t r . (m `Divides` m', UCRTElt t r) + => UCyc t m E r -> Either (UCyc t m' P r) (UCyc t m' E r) +{-# INLINABLE embedCRTE #-} +embedCRTE x@(CRTE _ v) = + case crtSentinel of + -- go to CRTE if valid, else go to Pow + Left s -> Right $ CRTE s $ runIdentity T.embedCRT v + Right _ -> Left $ embedPow $ toPow x + -- | Twace into a subring, for the powerful basis. twacePow :: (Ring r, Tensor t, m `Divides` m', TElt t r) => UCyc t m' P r -> UCyc t m P r @@ -406,22 +459,28 @@ twaceDec (Dec v) = Dec $ twacePowDec v {-# INLINABLE twaceDec #-} --- | Twace into a subring, for a CRT basis. (The output is an --- 'Either' because in some cases it is most efficient to preserve the --- 'UCyc' internal invariant by producing output with respect to the --- powerful basis.) -twaceCRT :: forall t m m' r . (m `Divides` m', UCElt t r) - => UCyc t m' C r -> Either (UCyc t m P r) (UCyc t m C r) -{-# INLINABLE twaceCRT #-} -twaceCRT x@(CRTr v) = - -- stay in CRTr only iff it's valid for target, else go to Pow - fromMaybe (Left $ twacePow $ toPow x) (Right . CRTr <$> (T.twaceCRT <*> pure v)) -twaceCRT x@(CRTe v) = - -- stay in CRTe iff CRTr is invalid for target, else go to Pow - fromMaybe (Right $ CRTe $ fromJust' "UCyc.twace CRTe" T.twaceCRT v) - (proxyT hasCRTFuncs (Proxy::Proxy (t m r)) A.*> - Just (Left $ twacePow $ toPow x)) +-- | Twace into a subring, for the CRT basis. (The output is an +-- 'Either' because the subring might not support 'C'.) +twaceCRTC :: (m `Divides` m', UCRTElt t r) + => UCyc t m' C r -> Either (UCyc t m P r) (UCyc t m C r) +{-# INLINABLE twaceCRTC #-} +twaceCRTC x@(CRTC s' v) = + case crtSentinel of + -- go to CRTC if valid for target, else go to Pow + Left _ -> Left $ twacePow $ toPow x + Right s -> Right $ CRTC s $ twaceCRTCS s' s v +-- | Similar to 'twaceCRTC'. (The output is an 'Either' because the +-- subring might support 'C', in which case we never use 'E'.) +twaceCRTE :: forall t m m' r . (m `Divides` m', UCRTElt t r) + => UCyc t m' E r -> Either (UCyc t m P r) (UCyc t m E r) +{-# INLINABLE twaceCRTE #-} +twaceCRTE x@(CRTE _ v) = + case crtSentinel of + -- go to CRTE if valid for target, else go to Pow + Left s -> Right $ CRTE s $ runIdentity T.twaceCRT v + Right _ -> Left $ twacePow $ toPow x + -- | Yield the @O_m@-coefficients of an @O_m'@-element, with respect to -- the relative powerful @O_m@-basis. coeffsPow :: (Ring r, Tensor t, m `Divides` m', TElt t r) @@ -448,7 +507,7 @@ crtSet :: forall t m m' r p mbar m'bar . (m `Divides` m', ZPP r, p ~ CharOf (ZpOf r), mbar ~ PFree p m, m'bar ~ PFree p m', - UCElt t r, TElt t (ZpOf r)) + UCRTElt t r, TElt t (ZpOf r)) => Tagged m [UCyc t m' P r] {-# INLINABLE crtSet #-} crtSet = @@ -461,7 +520,7 @@ pm = Proxy::Proxy m pm' = Proxy::Proxy m' in retag (fmap (embedPow . - (if e > 1 then toPow . (^(p^(e-1))) . toCRT else toPow) . + (if e > 1 then toPowCE . (^(p^(e-1))) . toCRT else toPow) . Dec . fmapT liftZp) <$> (crtSetDec :: Tagged mbar [t m'bar (ZpOf r)])) \\ pFreeDivides pp pm pm' \\ pSplitTheorems pp pm \\ pSplitTheorems pp pm' @@ -470,53 +529,183 @@ --------- Conversion methods ------------------ +-- {-# SPECIALIZE toPow :: (Fact m, Reflects q Int64) => UCyc RT m D (ZqBasic q Int64) -> UCyc RT m P (ZqBasic q Int64) #-} +-- EAC: I can't specialize toPow due to the constraint synonym TElt. See GHC ticket 12068 +-- For future reference, it seemed to help in general to simplify constraints as much as possible +-- (i.e. replacing (Ring (ZqBasic q z)) with (Ring z, Reflects t z)) and +-- removing type synonyms wherever possible. + +{- +EAC: I tried specializing the function +toPow :: (Fact m, C) for C \subseteq [Tensor t , CRTEmbed r , CRTrans Maybe r , TElt t r , CRTrans Identity (CRTExt r) , TElt t (CRTExt r)] +using +{-# SPECIALIZE toPow :: (Fact m, Reflects q Int64) => UCyc RT m D (ZqBasic q Int64) -> UCyc RT m P (ZqBasic q Int64) #-} + +The results for subsets with (Tensor t) were identical to those without (Tensor t), so we ignore (Tensor t) in what follows + +There were three outcomes: +1. "Good": no warnings. +2. "NB": Warning: Forall'd constraint ‘Reflects k q Int64’ is not bound in RULE lhs +3. "Bad": Warning: RULE left-hand side too complicated to desugar + +BAD: CRTEmbed r, CRTrans Maybe r, TElt t r, CRTrans Identity (CRTExt r), TElt t (CRTExt r) +BAD: CRTEmbed r, CRTrans Maybe r, TElt t r, CRTrans Identity (CRTExt r) +BAD: CRTEmbed r, CRTrans Maybe r, TElt t r, TElt t (CRTExt r) +BAD: CRTEmbed r, CRTrans Maybe r, TElt t r +BAD: CRTEmbed r, CRTrans Maybe r, CRTrans Identity (CRTExt r), TElt t (CRTExt r) +good: CRTEmbed r, CRTrans Maybe r, CRTrans Identity (CRTExt r) +BAD: CRTEmbed r, CRTrans Maybe r, TElt t (CRTExt r) +good: CRTEmbed r, CRTrans Maybe r +BAD: CRTEmbed r, TElt t r, CRTrans Identity (CRTExt r), TElt t (CRTExt r) +BAD: CRTEmbed r, TElt t r, CRTrans Identity (CRTExt r) +BAD: CRTEmbed r, TElt t r, TElt t (CRTExt r) +good: CRTEmbed r, TElt t r +BAD: CRTEmbed r, CRTrans Identity (CRTExt r), TElt t (CRTExt r) +good: CRTEmbed r, CRTrans Identity (CRTExt r) +good: CRTEmbed r, TElt t (CRTExt r) +good: CRTEmbed r +BAD: CRTrans Maybe r, TElt t r, CRTrans Identity (CRTExt r), TElt t (CRTExt r) +good: CRTrans Maybe r, TElt t r, CRTrans Identity (CRTExt r) +BAD: CRTrans Maybe r, TElt t r, TElt t (CRTExt r) +good: CRTrans Maybe r, TElt t r +good: CRTrans Maybe r, CRTrans Identity (CRTExt r), TElt t (CRTExt r) +good: CRTrans Maybe r, CRTrans Identity (CRTExt r) +good: CRTrans Maybe r, TElt t (CRTExt r) +good: CRTrans Maybe r +NB: TElt t r, CRTrans Identity (CRTExt r), TElt t (CRTExt r) +NB: TElt t r, CRTrans Identity (CRTExt r) +NB: TElt t r, TElt t (CRTExt r) +NB: TElt t r +NB: CRTrans Identity (CRTExt r), TElt t (CRTExt r) +NB: CRTrans Identity (CRTExt r) +NB: TElt t (CRTExt r) +NB: + +Assigning variables to constraints as follows, + +A=CRTEmbed r +B=CRTrans Maybe r +C=TElt t r +D=CRTrans Identity (CRTExt r) +E=TElt t (CRTExt r) + +using outcome values + +BAD=0 +NB=0 +GOOD=1 + +the formula for results is + +y=(-A)*B*(-C) + (-A)*B*(-E) + A*(-C)*(-E) + A*(-B)*(-C)*(-D) + A*(-B)*(-D)*(-E) + +Below this line, I've reordered the subsets into logical groups. + +-- always nb if we don't have either of (CRTEmbed r) or (CRTrans Maybe r) +-- I think this error makes sense: type families aren't injective, so references +-- to TElt and CRTExt may not refer to 'r' on their RHS. +NB: TElt t r, CRTrans Identity (CRTExt r), TElt t (CRTExt r) +NB: TElt t r, CRTrans Identity (CRTExt r) +NB: TElt t r, TElt t (CRTExt r) +NB: TElt t r +NB: CRTrans Identity (CRTExt r), TElt t (CRTExt r) +NB: CRTrans Identity (CRTExt r) +NB: TElt t (CRTExt r) +NB: + +-- always bad if we have both TElt constraints. +BAD: CRTEmbed r, CRTrans Maybe r, TElt t r, TElt t (CRTExt r) +BAD: CRTEmbed r, CRTrans Maybe r, TElt t r, CRTrans Identity (CRTExt r), TElt t (CRTExt r) +BAD: CRTEmbed r, TElt t r, CRTrans Identity (CRTExt r), TElt t (CRTExt r) +BAD: CRTrans Maybe r, TElt t r, CRTrans Identity (CRTExt r), TElt t (CRTExt r) +BAD: CRTEmbed r, TElt t r, TElt t (CRTExt r) +BAD: CRTrans Maybe r, TElt t r, TElt t (CRTExt r) + +-- always good if we don't have either TElt constraint. +good: CRTEmbed r, CRTrans Maybe r +good: CRTEmbed r, CRTrans Maybe r, CRTrans Identity (CRTExt r) +good: CRTEmbed r, CRTrans Identity (CRTExt r) +good: CRTrans Maybe r, CRTrans Identity (CRTExt r) +good: CRTEmbed r +good: CRTrans Maybe r + +-- bad if we have both (CRTEmbed r) and (CRTrans Maybe r) with at least one of the TElt constraints +BAD: CRTEmbed r, CRTrans Maybe r, TElt t r, CRTrans Identity (CRTExt r) +BAD: CRTEmbed r, CRTrans Maybe r, TElt t r +BAD: CRTEmbed r, CRTrans Maybe r, CRTrans Identity (CRTExt r), TElt t (CRTExt r) +BAD: CRTEmbed r, CRTrans Maybe r, TElt t (CRTExt r) + +-- a few more good cases: symmetric for (CRTEmbed r) and (CRTrans Maybe r) +good: CRTEmbed r, TElt t r +good: CRTrans Maybe r, TElt t r +good: CRTEmbed r, TElt t (CRTExt r) +good: CRTrans Maybe r, TElt t (CRTExt r) + +-- strange cases: works for (CRTrans Maybe r), fails for (CRTEmbed r) +-- removing the (Ring (CRTExt r)) superclass constraint from CRTEmbed makes all four of these work. +-- (but doesn't change the behavior of other failing cases) +BAD: CRTEmbed r, TElt t r, CRTrans Identity (CRTExt r) +good: CRTrans Maybe r, TElt t r, CRTrans Identity (CRTExt r) +BAD: CRTEmbed r, CRTrans Identity (CRTExt r), TElt t (CRTExt r) +good: CRTrans Maybe r, CRTrans Identity (CRTExt r), TElt t (CRTExt r) + +-} -- | Convert to powerful-basis representation. -toPow :: (Fact m, UCElt t r) => UCyc t m rep r -> UCyc t m P r +toPow :: (Fact m, UCRTElt t r) => UCyc t m rep r -> UCyc t m P r {-# INLINABLE toPow #-} toPow x@(Pow _) = x toPow (Dec v) = Pow $ l v -toPow (CRTr v) = Pow $ fromJust' "UCyc.toPow CRTr" crtInv v -toPow (CRTe v) = - Pow $ fmapT fromExt $ fromJust' "UCyc.toPow CRTe" crtInv v +toPow (CRTC s v) = Pow $ crtInvCS s v +toPow (CRTE _ v) = Pow $ fmapT fromExt $ runIdentity crtInv v +-- | Convenient version of 'toPow' for 'Either' CRT basis type. +toPowCE :: (Fact m, UCRTElt t r) => UCycEC t m r -> UCyc t m P r +{-# INLINABLE toPowCE #-} +toPowCE (Left u) = toPow u +toPowCE (Right u) = toPow u + -- | Convert to decoding-basis representation. -toDec :: (Fact m, UCElt t r) => UCyc t m rep r -> UCyc t m D r +toDec :: (Fact m, UCRTElt t r) => UCyc t m rep r -> UCyc t m D r {-# INLINABLE toDec #-} toDec (Pow v) = Dec $ lInv v toDec x@(Dec _) = x -toDec x@(CRTr _) = toDec $ toPow x -toDec x@(CRTe _) = toDec $ toPow x +toDec x@(CRTC _ _) = toDec $ toPow x +toDec x@(CRTE _ _) = toDec $ toPow x -- | Convert to a CRT-basis representation. -toCRT :: forall t m rep r . (Fact m, UCElt t r) - => UCyc t m rep r -> UCyc t m C r +toCRT :: forall t m rep r . (Fact m, UCRTElt t r) + => UCyc t m rep r -> UCycEC t m r {-# INLINABLE toCRT #-} -toCRT = let crte = CRTe . fromJust' "UCyc.toCRT: no crt for Ext" crt - crtr = fmap (CRTr .) crt - fromPow :: t m r -> UCyc t m C r - fromPow v = fromMaybe (crte $ fmapT toExt v) (crtr <*> Just v) +toCRT = let fromPow :: t m r -> UCycEC t m r + fromPow = case crtSentinel of + Right s -> Right . CRTC s . crtCS s + Left s -> Left . CRTE s . runIdentity crt . fmapT toExt in \x -> case x of - (CRTr _) -> x - (CRTe _) -> x + (CRTC _ _) -> Right x + (CRTE _ _) -> Left x (Pow v) -> fromPow v (Dec v) -> fromPow $ l v ---------- Category-theoretic instances ---------- --- CJP: no Applicative, Foldable, Traversable for C because types --- (and math) don't work out for the CRTe case. +-- CJP: no instances for E because types (and math) don't make sense. +-- | apply coefficient-wise (with respect to powerful basis) instance (Tensor t, Fact m) => Functor (UCyc t m P) where -- Functor instance is implied by Applicative laws {-# INLINABLE fmap #-} fmap f x = pure f <*> x +-- | apply coefficient-wise (with respect to decoding basis) instance (Tensor t, Fact m) => Functor (UCyc t m D) where -- Functor instance is implied by Applicative laws {-# INLINABLE fmap #-} fmap f x = pure f <*> x +-- CJP: no Functor instance for C, because CRTrans for a doesn't imply +-- it for b. + instance (Tensor t, Fact m) => Applicative (UCyc t m P) where pure = Pow . pure \\ proxy entailIndexT (Proxy::Proxy (t m r)) (Pow f) <*> (Pow v) = Pow $ f <*> v \\ witness entailIndexT v @@ -531,6 +720,9 @@ {-# INLINABLE pure #-} {-# INLINABLE (<*>) #-} +-- CJP: no Applicative instance for C, because 'pure' would circumvent +-- the invariant. Moreover, having CRTrans for (a -> b) and for a +-- doesn't imply it for b. instance (Tensor t, Fact m) => Foldable (UCyc t m P) where {-# INLINABLE foldr #-} @@ -540,7 +732,11 @@ {-# INLINABLE foldr #-} foldr f b (Dec v) = F.foldr f b v \\ witness entailIndexT v +instance (Tensor t, Fact m) => Foldable (UCyc t m C) where + {-# INLINABLE foldr #-} + foldr f b (CRTC _ v) = F.foldr f b v \\ witness entailIndexT v + instance (Tensor t, Fact m) => Traversable (UCyc t m P) where {-# INLINABLE traverse #-} traverse f (Pow v) = Pow <$> traverse f v \\ witness entailIndexT v @@ -549,28 +745,38 @@ {-# INLINABLE traverse #-} traverse f (Dec v) = Dec <$> traverse f v \\ witness entailIndexT v +-- CJP: no Traversable instance for C, because CRTrans for a doesn't +-- imply it for b. + ---------- Utility instances ---------- -instance (Random r, Tensor t, Fact m, CRTElt t r) +instance (Random r, UCRTElt t r, Fact m) => Random (UCyc t m P r) where + + random g = let (v,g') = random g \\ witness entailRandomT v + in (Pow v, g') + + randomR _ = error "randomR non-sensical for UCyc" + +instance (Random r, UCRTElt t r, Fact m) => Random (UCyc t m D r) where + + random g = let (v,g') = random g \\ witness entailRandomT v + in (Dec v, g') + + randomR _ = error "randomR non-sensical for UCyc" + +instance (Random r, UCRTElt t r, Fact m) => Random (Either (UCyc t m P r) (UCyc t m C r)) where - -- create in CRTr basis if possible, otherwise in powerful - random = let cons = fromMaybe (Left . Pow) - (proxyT hasCRTFuncs (Proxy::Proxy (t m r)) - >> Just (Right . CRTr)) + -- create in CRTC basis if possible, otherwise in powerful + random = let cons = case crtSentinel of + Left _ -> Left . Pow + Right s -> Right . CRTC s in \g -> let (v,g') = random g \\ witness entailRandomT v in (cons v, g') randomR _ = error "randomR non-sensical for UCyc" -instance (Show r, Show (CRTExt r), Tensor t, Fact m, TElt t r, TElt t (CRTExt r)) - => Show (UCyc t m rep r) where - show (Pow v) = "UCyc Pow: " ++ show v \\ witness entailShowT v - show (Dec v) = "UCyc Dec: " ++ show v \\ witness entailShowT v - show (CRTr v) = "UCyc CRTr: " ++ show v \\ witness entailShowT v - show (CRTe v) = "UCyc CRTe: " ++ show v \\ witness entailShowT v - instance (Arbitrary (t m r)) => Arbitrary (UCyc t m P r) where arbitrary = Pow <$> arbitrary shrink = shrinkNothing @@ -579,13 +785,16 @@ arbitrary = Dec <$> arbitrary shrink = shrinkNothing -instance (Arbitrary (t m r)) => Arbitrary (UCyc t m C r) where - arbitrary = CRTr <$> arbitrary - shrink = shrinkNothing +-- no Arbitrary for C or E due to invariant instance (Tensor t, Fact m, NFElt r, TElt t r, TElt t (CRTExt r)) => NFData (UCyc t m rep r) where - rnf (Pow x) = rnf x \\ witness entailNFDataT x - rnf (Dec x) = rnf x \\ witness entailNFDataT x - rnf (CRTr x) = rnf x \\ witness entailNFDataT x - rnf (CRTe x) = rnf x \\ witness entailNFDataT x + rnf (Pow x) = rnf x \\ witness entailNFDataT x + rnf (Dec x) = rnf x \\ witness entailNFDataT x + rnf (CRTC _ x) = rnf x \\ witness entailNFDataT x + rnf (CRTE _ x) = rnf x \\ witness entailNFDataT x + +instance (Fact m, Protoable (t m r)) => Protoable (UCyc t m D r) where + type ProtoType (UCyc t m D r) = ProtoType (t m r) + toProto (Dec t) = toProto t + fromProto t = Dec <$> fromProto t diff --git a/Crypto/Lol/FactoredDefs.hs b/Crypto/Lol/FactoredDefs.hs --- a/Crypto/Lol/FactoredDefs.hs +++ b/Crypto/Lol/FactoredDefs.hs @@ -1,7 +1,8 @@ {-# LANGUAGE ConstraintKinds, DataKinds, ExplicitNamespaces, GADTs, InstanceSigs, KindSignatures, PolyKinds, ScopedTypeVariables, - TemplateHaskell, TypeFamilies, TypeOperators, + RankNTypes, TemplateHaskell, TypeFamilies, TypeOperators, UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-unused-binds #-} -- | This sub-module exists only because we can't define and use -- template Haskell splices in the same module. @@ -9,11 +10,14 @@ module Crypto.Lol.FactoredDefs ( -- * Factored natural numbers - Factored, SFactored, Fact, fType, fDec + reifyFact, reifyFactI +, Factored, SFactored, Fact, fType, fDec -- * Prime powers +, reifyPPow, reifyPPowI , PrimePower, SPrimePower, Sing(SPP), PPow, ppType, ppDec -- * Primes -, Prime, SPrime, Prim, pType, pDec +, reifyPrime, reifyPrimeI +, PrimeBin, SPrimeBin, Prime, pType, pDec -- * Constructors , pToPP, sPToPP, PToPP, ppToF, sPpToF, PpToF, pToF, sPToF, PToF -- * Unwrappers @@ -58,21 +62,21 @@ -- something about "escaped type variables" -- restrict to primes - newtype Prime = P Bin deriving (Eq,Ord,Show) + newtype PrimeBin = P Bin deriving (Eq,Ord,Show) - -- (prime, exponent) - newtype PrimePower = PP (Prime,Pos) deriving (Eq,Show) + -- (prime, exponent) + newtype PrimePower = PP (PrimeBin,Pos) deriving (Eq,Show) -- Invariant: primes appear in strictly increasing -- order (no duplicates). newtype Factored = F [PrimePower] deriving (Eq,Show) - -- Unwrap 'Prime' - unP :: Prime -> Bin + -- Unwrap 'PrimeBin' + unP :: PrimeBin -> Bin unP (P p) = p -- Unwrap 'PrimePower'. - unPP :: PrimePower -> (Prime,Pos) + unPP :: PrimePower -> (PrimeBin,Pos) unPP (PP pp) = pp -- Unwrap 'Factored' @@ -80,7 +84,7 @@ unF (F pps) = pps -- Prime component of a 'PrimePower'. - primePP :: PrimePower -> Prime + primePP :: PrimePower -> PrimeBin primePP = fst . unPP -- Exponent component of a 'PrimePower'. @@ -121,13 +125,13 @@ -- ARITHMETIC OPERATIONS singletons [d| - pToPP :: Prime -> PrimePower + pToPP :: PrimeBin -> PrimePower pToPP p = PP (p, O) ppToF :: PrimePower -> Factored ppToF pp = F [pp] - pToF :: Prime -> Factored + pToF :: PrimeBin -> Factored pToF = ppToF . pToPP fGCD, fLCM :: Factored -> Factored -> Factored @@ -189,7 +193,7 @@ singletons [d| -- Remove all @p@-factors from a 'Factored'. - pFree :: Prime -> Factored -> Factored + pFree :: PrimeBin -> Factored -> Factored pFree p (F pps) = F (go pps) where go [] = [] go (pp@(PP (p',_)) : ps) = @@ -206,7 +210,7 @@ -- convenience aliases: enforce kind, hide SingI -- | Kind-restricted synonym for 'SingI'. -type Prim (p :: Prime) = SingI p +type Prime (p :: PrimeBin) = SingI p -- | Kind-restricted synonym for 'SingI'. type PPow (pp :: PrimePower) = SingI pp @@ -214,6 +218,39 @@ -- | Kind-restricted synonym for 'SingI'. type Fact (m :: Factored) = SingI m +-- | Reify a 'PrimeBin' as a singleton. +reifyPrime :: Int -> (forall p . SPrimeBin p -> a) -> a +reifyPrime x _ | not $ prime x = error $ "reifyPrime: non-prime x = " ++ show x +reifyPrime x k = reifyBin x (k . SP) + +-- | Reify a 'PrimeBin' for a 'Prime' constraint. +reifyPrimeI :: Int -> (forall p proxy. Prime p => proxy p -> a) -> a +reifyPrimeI n k = + reifyPrime n (\(p::SPrimeBin p) -> withSingI p $ k (Proxy::Proxy p)) + +-- | Reify a 'PrimePower' as a singleton. +reifyPPow :: (Int,Int) -> (forall pp . SPrimePower pp -> a) -> a +reifyPPow (p,e) k = reifyPrime p (\sp -> reifyPos e (k . SPP . STuple2 sp)) + +-- | Reify a 'PrimePower' for a 'PPow' constraint. +reifyPPowI :: (Int,Int) -> (forall pp proxy. PPow pp => proxy pp -> a) -> a +reifyPPowI pp k = + reifyPPow pp $ (\(p::SPrimePower p) -> withSingI p $ k (Proxy::Proxy p)) + +-- | Reify a 'Factored' as a singleton. +reifyFact :: Int -> (forall m . SFactored m -> a) -> a +reifyFact m k = let pps = factorize m in reifyPPs pps $ k . SF + where reifyPPs :: [(Int,Int)] + -> (forall (pps :: [PrimePower]) . Sing pps -> a) -> a + reifyPPs [] c = c SNil + reifyPPs (pp:pps) c = + reifyPPow pp (\spp -> reifyPPs pps (\sm' -> c $ SCons spp sm')) + +-- | Reify a 'Factored' for a 'Fact' constraint. +reifyFactI :: Int -> (forall m proxy. Fact m => proxy m -> a) -> a +reifyFactI pps k = + reifyFact pps $ (\(m::SFactored m) -> withSingI m $ k (Proxy::Proxy m)) + -- | Constraint synonym for divisibility of 'Factored' types. type Divides m m' = (Fact m, Fact m', FDivides m m' ~ 'True) @@ -269,21 +306,21 @@ -- if @f@ is @m@ after removing all @p@-factors, then @f|m@ and -- @gcd(f,p)=1@. pSplitTheorems :: forall p m f . Proxy p -> Proxy m -> - ((Prim p, Fact m, f ~ PFree p m) :- + ((Prime p, Fact m, f ~ PFree p m) :- (f `Divides` m, Coprime (PToF p) f)) pSplitTheorems _ m = - Sub $ withSingI (sPFree (sing :: SPrime p) (sing :: SFactored m)) + Sub $ withSingI (sPFree (sing :: SPrimeBin p) (sing :: SFactored m)) Dict \\ coerceFDivs (Proxy::Proxy f) m \\ coerceGCD (Proxy::Proxy (PToF p)) (Proxy::Proxy f) (Proxy::Proxy F1) -- | Entailment for @p@-free division: -- if @m|m'@, then @p-free(m) | p-free(m')@. pFreeDivides :: forall p m m' . Proxy p -> Proxy m -> Proxy m' -> - ((Prim p, m `Divides` m') :- + ((Prime p, m `Divides` m') :- ((PFree p m) `Divides` (PFree p m'))) pFreeDivides _ _ _ = - Sub $ withSingI (sPFree (sing :: SPrime p) (sing :: SFactored m)) $ - withSingI (sPFree (sing :: SPrime p) (sing :: SFactored m')) $ + Sub $ withSingI (sPFree (sing :: SPrimeBin p) (sing :: SFactored m)) $ + withSingI (sPFree (sing :: SPrimeBin p) (sing :: SFactored m')) $ Dict \\ coerceFDivs (Proxy::Proxy (PFree p m)) (Proxy::Proxy (PFree p m')) -- | Type synonym for @(prime, exponent)@ pair. @@ -327,9 +364,9 @@ -- | The totient of a 'PrimePower' type's value. totientPPow = totientPP <$> ppPPow --- | The value of a 'Prime' type. -valuePrime :: forall p . Prim p => Tagged p Int -valuePrime = tag $ binToInt $ unP $ fromSing (sing :: SPrime p) +-- | The value of a 'PrimeBin' type. +valuePrime :: forall p . Prime p => Tagged p Int +valuePrime = tag $ binToInt $ unP $ fromSing (sing :: SPrimeBin p) -- | Return @m@ if @m@ is odd, and @m/2@ otherwise. valueHat :: Integral i => i -> i @@ -366,11 +403,11 @@ oddRadicalPPs = product . map oddRadicalPP --- | Template Haskell splice for the 'Prime' type corresponding to a +-- | Template Haskell splice for the 'PrimeBin' type corresponding to a -- given positive prime integer. (Uses 'prime' to enforce primality -- of the base, so should only be used on small-to-moderate-sized -- arguments.) This is the preferred (and only) way of constructing a --- concrete 'Prime' type (and is used to define the @Primep@ type +-- concrete 'PrimeBin' type (and is used to define the @Primep@ type -- synonyms). pType :: Int -> TypeQ pType p @@ -392,10 +429,10 @@ -- small-to-moderate-sized arguments (any reasonable cyclotomic index -- should be OK). fType :: Int -> TypeQ -fType n = conT 'F `appT` (foldr (\pp -> appT (promotedConsT `appT` ppType pp)) +fType n = conT 'F `appT` (foldr (\pp -> appT (promotedConsT `appT` ppType pp)) promotedNilT $ factorize n) --- | Template Haskell splice that defines the 'Prime' type synonym +-- | Template Haskell splice that defines the 'PrimeBin' type synonym -- @Primep@ for a positive prime integer @p@. pDec :: Int -> DecQ pDec p = tySynD (mkName $ "Prime" ++ show p) [] $ pType p @@ -411,16 +448,16 @@ fDec n = tySynD (mkName $ 'F' : show n) [] $ fType n -- | Factorize a positive integer into an ordered list of its prime --- divisors, with multiplicities. First argument is infinite list of --- primes left to consider. +-- divisors, with possible duplicates. First argument is infinite +-- list of primes left to consider. factorize' :: [Int] -> Int -> [Int] factorize' _ 1 = [] -factorize' ds@(d:ds') n +factorize' ds@(d:ds') n | n > 1 = if d * d > n then [n] else let (q,r) = n `divMod` d in if r == 0 then d : factorize' ds q else factorize' ds' n - | otherwise = error "can only factorize positive integers" +factorize' _ n = error $ "can't factorize non-positive n = " ++ show n -- | Factorize a positive integer into a list of (prime,exponent) -- pairs, in strictly increasing order by prime. diff --git a/Crypto/Lol/Gadget.hs b/Crypto/Lol/Gadget.hs --- a/Crypto/Lol/Gadget.hs +++ b/Crypto/Lol/Gadget.hs @@ -1,7 +1,14 @@ -{-# LANGUAGE ConstraintKinds, DataKinds, FlexibleContexts, - FlexibleInstances, MultiParamTypeClasses, NoImplicitPrelude, - PolyKinds, ScopedTypeVariables, TupleSections, TypeFamilies, - UndecidableInstances #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} -- | Interfaces for "gadgets," decomposition, and error correction. @@ -10,7 +17,7 @@ , TrivGad, BaseBGad ) where -import Crypto.Lol.LatticePrelude +import Crypto.Lol.Prelude import Control.Applicative import Control.Arrow @@ -51,18 +58,19 @@ correct :: Tagged gad [u] -> (u, [LiftOf u]) --- instances for products - +-- | Product ring: concatenate gadgets over component rings instance (Gadget gad a, Gadget gad b) => Gadget gad (a,b) where gadget = (++) <$> (map (,zero) <$> gadget) <*> (map (zero,) <$> gadget) +-- | Product ring: concatenate decompositions for component rings instance (Decompose gad a, Decompose gad b, DecompOf a ~ DecompOf b) => Decompose gad (a,b) where type DecompOf (a,b) = DecompOf a decompose (a,b) = (++) <$> decompose a <*> decompose b +-- | Product ring instance (Correct gad a, Correct gad b, Mod a, Mod b, Field a, Field b, Lift' a, Lift' b, ToInteger (LiftOf a), ToInteger (LiftOf b)) diff --git a/Crypto/Lol/GaussRandom.hs b/Crypto/Lol/GaussRandom.hs --- a/Crypto/Lol/GaussRandom.hs +++ b/Crypto/Lol/GaussRandom.hs @@ -5,10 +5,11 @@ module Crypto.Lol.GaussRandom ( realGaussian, realGaussians ) where -import Crypto.Lol.LatticePrelude +import Crypto.Lol.Prelude import qualified Data.Vector.Generic as V +import Control.Applicative import Control.Monad import Control.Monad.Random @@ -44,8 +45,8 @@ (ToRational svar, OrdFloat i, Random i, V.Vector v i, MonadRandom m) => svar -> Int -> m (v i) realGaussians var n - | odd n = liftM V.tail (realGaussians var (n+1)) -- O(1) tail - | otherwise = liftM (V.fromList . uncurry (++) . unzip) $ + | odd n = V.tail <$> realGaussians var (n+1) -- O(1) tail + | otherwise = (V.fromList . uncurry (++) . unzip) <$> replicateM (n `div` 2) (realGaussian var) @@ -63,7 +64,7 @@ -- | Analogue of @('Prelude.until')@ -- Yields the result of applying f until p holds. iterateUntilM :: (Monad m) => (a -> Bool) -> (a -> m a) -> a -> m a -iterateUntilM p f v +iterateUntilM p f v | p v = return v | otherwise = f v >>= iterateUntilM p f diff --git a/Crypto/Lol/LatticePrelude.hs b/Crypto/Lol/LatticePrelude.hs deleted file mode 100644 --- a/Crypto/Lol/LatticePrelude.hs +++ /dev/null @@ -1,276 +0,0 @@ -{-# LANGUAGE ConstraintKinds, DataKinds, FlexibleContexts, - FlexibleInstances, FunctionalDependencies, - GeneralizedNewtypeDeriving, MultiParamTypeClasses, - NoImplicitPrelude, PolyKinds, RankNTypes, RebindableSyntax, - ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, - TypeFamilies, TypeOperators, UndecidableInstances #-} - --- | A substitute for the Prelude that is more suitable for Lol. This --- module exports most of the Numeric Prelude and other frequently --- used modules, plus some low-level classes, missing instances, and --- assorted utility functions. - -module Crypto.Lol.LatticePrelude -( --- * Classes and families - Enumerable(..) -, Mod(..) -, Reduce(..), LiftOf, Lift, Lift'(..), Rescale(..), Encode(..), msdToLSD -, CharOf --- * Numeric -, module Crypto.Lol.Types.Numeric --- * Complex -, module Crypto.Lol.Types.Complex --- * Factored -, module Crypto.Lol.Factored --- * Miscellaneous -, rescaleMod, roundCoset -, fromJust', pureT, peelT, pasteT, withWitness, withWitnessT -, module Data.Functor.Trans.Tagged -, module Data.Proxy -) where - -import Crypto.Lol.Factored -import Crypto.Lol.Types.Complex -import Crypto.Lol.Types.Numeric - -import Algebra.Field as Field (C) -import Algebra.IntegralDomain as IntegralDomain (C) -import Algebra.Ring as Ring (C) - -import Control.Applicative -import Control.Arrow -import Control.DeepSeq -import Control.Monad.Identity -import Control.Monad.Random -import Data.Coerce -import Data.Default -import Data.Functor.Trans.Tagged -import Data.Maybe -import Data.Proxy -import Data.Singletons - --- for Unbox instance of Maybe a -import qualified Data.Vector.Unboxed as U -import Data.Vector.Unboxed.Deriving - -instance NFData (Proxy (a :: k)) where rnf Proxy = () - -deriving instance NFData (m a) => NFData (TaggedT s m a) -deriving instance (MonadRandom m) => MonadRandom (TaggedT (tag :: k) m) - -derivingUnbox "Maybe" - [t| forall a . (Default a, U.Unbox a) => Maybe a -> (Bool, a) |] - [| maybe (False, def) (\ x -> (True, x)) |] - [| \ (b, x) -> if b then Just x else Nothing |] - -instance Default Bool where def = False - --- | The characteristic of a ring, represented as a type. -type family CharOf fp :: k - --- | Poor man's 'Enum'. -class Enumerable a where - values :: [a] - --- | Represents a quotient group modulo some integer. -class (ToInteger (ModRep a), Additive a) => Mod a where - type ModRep a - modulus :: Tagged a (ModRep a) - --- | Represents that @b@ is a quotient group of @a@. -class (Additive a, Additive b) => Reduce a b where - reduce :: a -> b - --- | Represents that @b@ can be lifted to a "short" @a@ congruent to @b@. -type Lift b a = (Lift' b, LiftOf b ~ a) - --- | The type of representatives of @b@. -type family LiftOf b - --- | Fun-dep version of Lift. -class (Reduce (LiftOf b) b) => Lift' b where - lift :: b -> LiftOf b - --- | Represents that @a@ can be rescaled to @b@, as an "approximate" --- additive homomorphism. -class (Additive a, Additive b) => Rescale a b where - rescale :: a -> b - --- | Represents that the target ring can "noisily encode" values from --- the source ring, in either "most significant digit" (MSD) or "least --- significant digit" (LSD) encodings, and provides conversion factors --- between the two types of encodings. - -class (Field src, Field tgt) => Encode src tgt where - -- | The factor that converts an element from LSD to MSD encoding - -- in the target field, with associated scale factor to apply to - -- correct the resulting encoded value. - lsdToMSD :: (src, tgt) - --- | Inverted entries of 'lsdToMSD'. -msdToLSD :: (Encode src tgt) => (src, tgt) -msdToLSD = (recip *** recip) lsdToMSD -{-# INLINABLE msdToLSD #-} - --- | A default implementation of rescaling for 'Mod' types. -rescaleMod :: forall a b . - (Mod a, Mod b, (ModRep a) ~ (ModRep b), - Lift a (ModRep b), Ring b) - => a -> b -{-# INLINABLE rescaleMod #-} -rescaleMod = - let qval = proxy modulus (Proxy :: Proxy a) - q'val = proxy modulus (Proxy :: Proxy b) - in \x -> let (quot',_) = divModCent (q'val * lift x) qval - in fromIntegral quot' - --- | Deterministically round to a nearby value in the desired coset -roundCoset :: forall zp z r . - (Mod zp, z ~ ModRep zp, Lift zp z, RealField r) => zp -> r -> z -{-# INLINABLE roundCoset #-} -roundCoset = let pval = proxy modulus (Proxy::Proxy zp) - in \ zp x -> let rep = lift zp - in rep + roundMult pval (x - fromIntegral rep) - ----------- Instances for product groups/rings ---------- - -type instance LiftOf (a,b) = Integer - -instance (Mod a, Mod b, Lift' a, Lift' b, Reduce Integer (a,b), - ToInteger (LiftOf a), ToInteger (LiftOf b)) - => Lift' (a,b) where - - {-# INLINABLE lift #-} - lift (a,b) = - let moda = toInteger $ proxy modulus (Proxy::Proxy a) - modb = toInteger $ proxy modulus (Proxy::Proxy b) - q = moda * modb - ainv = fromMaybe (error "Lift' (a,b): moduli not coprime") $ moda `modinv` modb - lifta = toInteger $ lift a - liftb = toInteger $ lift b - -- put in [-q/2, q/2) - (_,r) = (moda * (liftb - lifta) * ainv + lifta) `divModCent` q - in r - - --- NP should define Ring and Field instances for pairs, but doesn't. --- So we do it here. -instance (Ring r1, Ring r2) => Ring.C (r1, r2) where - (x1, x2) * (y1, y2) = (x1*y1, x2*y2) - one = (one,one) - fromInteger x = (fromInteger x, fromInteger x) - - {-# INLINABLE (*) #-} - {-# INLINABLE one #-} - {-# INLINABLE fromInteger #-} - -instance (Field f1, Field f2) => Field.C (f1, f2) where - (x1, x2) / (y1, y2) = (x1 / y1, x2 / y2) - recip = recip *** recip - {-# INLINABLE (/) #-} - {-# INLINABLE recip #-} - -instance (IntegralDomain a, IntegralDomain b) => IntegralDomain.C (a,b) where - (a1,b1) `divMod` (a2,b2) = - let (da,ra) = (a1 `divMod` a2) - (db,rb) = (b1 `divMod` b2) - in ((da,db), (ra,rb)) - {-# INLINABLE divMod #-} - -instance (Mod a, Mod b) => Mod (a,b) where - type ModRep (a,b) = Integer - - modulus = tag $ fromIntegral (proxy modulus (Proxy::Proxy a)) * - fromIntegral (proxy modulus (Proxy::Proxy b)) - {-# INLINABLE modulus #-} - -instance (Reduce a b1, Reduce a b2) => Reduce a (b1, b2) where - reduce x = (reduce x, reduce x) - {-# INLINABLE reduce #-} - --- instances of Rescale for a product -instance (Mod a, Field b, Lift a (ModRep a), Reduce (LiftOf a) b) - => Rescale (a,b) b where - rescale = let q1val = proxy modulus (Proxy::Proxy a) - q1inv = recip $ reduce q1val - in \(x1,x2) -> q1inv * (x2 - reduce (lift x1)) - {-# INLINABLE rescale #-} - -instance (Mod b, Field a, Lift b (ModRep b), Reduce (LiftOf b) a) - => Rescale (a,b) a where - rescale = let q2val = proxy modulus (Proxy::Proxy b) - q2inv = recip $ reduce q2val - in \(x1,x2) -> q2inv * (x1 - reduce (lift x2)) - {-# INLINABLE rescale #-} - --- some multi-step scaledowns; could do this forever -instance (Rescale (a,(b,c)) (b,c), Rescale (b,c) c) - => Rescale (a,(b,c)) c where - rescale = (rescale :: (b,c) -> c) . rescale - {-# INLINABLE rescale #-} - -instance (Rescale ((a,b),c) (a,b), Rescale (a,b) a) - => Rescale ((a,b),c) a where - rescale = (rescale :: (a,b) -> a) . rescale - {-# INLINABLE rescale #-} - --- scaling up to a product -instance (Ring a, Mod b, Reduce (ModRep b) a) => Rescale a (a,b) where - -- multiply by q2 - rescale = let q2val = reduce $ proxy modulus (Proxy::Proxy b) - in \x -> (q2val * x, zero) - {-# INLINABLE rescale #-} - -instance (Ring b, Mod a, Reduce (ModRep a) b) => Rescale b (a,b) where - -- multiply by q1 - rescale = let q1val = reduce $ proxy modulus (Proxy::Proxy a) - in \x -> (zero, q1val * x) - {-# INLINABLE rescale #-} - --- Instance of 'Encode' for product ring. -instance (Encode s t1, Encode s t2, Field (t1, t2)) => Encode s (t1, t2) where - {-# INLINABLE lsdToMSD #-} - lsdToMSD = let (s1, t1conv) = lsdToMSD - (s2, t2conv) = lsdToMSD - in (negate s1 * s2, (t1conv,t2conv)) - --- Random could have defined this instance, but didn't, so we do it --- here. -instance (Random a, Random b) => Random (a,b) where - {-# INLINABLE random #-} - random g = let (a,g') = random g - (b, g'') = random g' - in ((a,b), g'') - - {-# INLINABLE randomR #-} - randomR ((loa,lob), (hia,hib)) g = let (a,g') = randomR (loa,hia) g - (b,g'') = randomR (lob,hib) g' - in ((a,b),g'') - --- | Version of 'fromJust' with an error message. -fromJust' :: String -> Maybe a -> a -fromJust' str = fromMaybe (error str) - --- | Apply any applicative to a Tagged value. -pureT :: Applicative f => TaggedT t Identity a -> TaggedT t f a -pureT = mapTaggedT (pure . runIdentity) - --- | Expose the monad of a tagged value. -peelT :: Tagged t (f a) -> TaggedT t f a -peelT = coerce - --- | Hide the monad of a tagged value. -pasteT :: TaggedT t f a -> Tagged t (f a) -pasteT = coerce - --- | Use a singleton as a witness to extract a value from a tagged value. -withWitness :: forall n r . (SingI n => Tagged n r) -> Sing n -> r -withWitness t wit = withSingI wit $ proxy t (Proxy::Proxy n) -{-# INLINABLE withWitness #-} - --- | Transformer version of 'withWitness'. -withWitnessT :: forall n mon r . - (SingI n => TaggedT n mon r) -> Sing n -> mon r -withWitnessT t wit = withSingI wit $ proxyT t (Proxy::Proxy n) -{-# INLINABLE withWitnessT #-} diff --git a/Crypto/Lol/PosBinDefs.hs b/Crypto/Lol/PosBinDefs.hs --- a/Crypto/Lol/PosBinDefs.hs +++ b/Crypto/Lol/PosBinDefs.hs @@ -1,5 +1,5 @@ {-# LANGUAGE ConstraintKinds, DataKinds, GADTs, InstanceSigs, - KindSignatures, NoImplicitPrelude, PolyKinds, + KindSignatures, NoImplicitPrelude, PolyKinds, RankNTypes, RebindableSyntax, ScopedTypeVariables, TemplateHaskell, TypeFamilies, UndecidableInstances #-} @@ -10,10 +10,12 @@ ( -- * Positive naturals in Peano representation Pos(..), Sing(SO, SS), SPos, PosC , posToInt, addPos, sAddPos, AddPos, subPos, sSubPos, SubPos +, reifyPos, reifyPosI , posType, posDec , OSym0, SSym0, SSym1, AddPosSym0, AddPosSym1, SubPosSym0, SubPosSym1 -- * Positive naturals in binary representation , Bin(..), Sing(SB1, SD0, SD1), SBin, BinC +, reifyBin, reifyBinI , binToInt, binType, binDec , B1Sym0, D0Sym0, D0Sym1, D1Sym0, D1Sym1 -- * Miscellaneous @@ -95,6 +97,27 @@ -- | Kind-restricted synonym for 'SingI'. type BinC (b :: Bin) = SingI b + +-- | Reify a 'Pos' as a singleton. +reifyPos :: Int -> (forall p . SPos p -> a) -> a +reifyPos x _ | x < 1 = error $ "reifyPos: non-positive x = " ++ show x +reifyPos 1 k = k SO +reifyPos n k = reifyPos (n-1) (k . SS) + +-- | Reify a 'Pos' for a 'SingI' constraint. +reifyPosI :: Int -> (forall p proxy . PosC p => proxy p -> a) -> a +reifyPosI n k = reifyPos n (\(p::SPos p) -> withSingI p $ k (Proxy::Proxy p)) + +-- | Reify a 'Bin' as a singleton. +reifyBin :: Int -> (forall b . SBin b -> a) -> a +reifyBin x _ | x < 1 = error $ "reifyBin: non-positive x = " ++ show x +reifyBin 1 k = k SB1 +reifyBin x k | even x = reifyBin (x `div` 2) (k . SD0) +reifyBin x k = reifyBin (x `div` 2) (k . SD1) + +-- | Reify a 'Bin' for a 'SingI' constraint. +reifyBinI :: Int -> (forall b proxy . BinC b => proxy b -> a) -> a +reifyBinI n k = reifyBin n (\(b::SBin b) -> withSingI b $ k (Proxy::Proxy b)) -- | Template Haskell splice for the 'Pos' type -- representing a given 'Int', e.g., @$(posType 8)@. diff --git a/Crypto/Lol/Prelude.hs b/Crypto/Lol/Prelude.hs new file mode 100644 --- /dev/null +++ b/Crypto/Lol/Prelude.hs @@ -0,0 +1,299 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | A substitute for the Prelude that is more suitable for Lol. This +-- module exports most of the Numeric Prelude and other frequently +-- used modules, plus some low-level classes, missing instances, and +-- assorted utility functions. + +module Crypto.Lol.Prelude +( +-- * Classes and families + Enumerable(..) +, Mod(..) +, Subgroup(..) +, Reduce(..), LiftOf, Lift, Lift'(..), Rescale(..), Encode(..), msdToLSD +, CharOf +-- * Numeric +, module Crypto.Lol.Types.Numeric +-- * Complex +, module Crypto.Lol.Types.Complex +-- * Factored +, module Crypto.Lol.Factored +-- * Miscellaneous +, rescaleMod, roundCoset +, fromJust', pureT, peelT, pasteT, withWitness, withWitnessT +, module Data.Functor.Trans.Tagged +, module Data.Proxy +) where + +import Crypto.Lol.Factored +import Crypto.Lol.Types.Complex +import Crypto.Lol.Types.Numeric + +import Algebra.Field as Field (C) +import Algebra.IntegralDomain as IntegralDomain (C) +import Algebra.Ring as Ring (C) + +import Control.Applicative +import Control.Arrow +import Control.DeepSeq +import Control.Monad.Identity +import Control.Monad.Random +import Data.Coerce +import Data.Default +import Data.Functor.Trans.Tagged +import Data.Maybe +import Data.Proxy +import Data.Singletons + +-- for Unbox instance of Maybe a +import qualified Data.Vector.Unboxed as U +import Data.Vector.Unboxed.Deriving + +instance NFData (Proxy (a :: k)) where rnf Proxy = () + +deriving instance NFData (m a) => NFData (TaggedT s m a) +deriving instance (MonadRandom m) => MonadRandom (TaggedT (tag :: k) m) + +derivingUnbox "Maybe" + [t| forall a . (Default a, U.Unbox a) => Maybe a -> (Bool, a) |] + [| maybe (False, def) (\ x -> (True, x)) |] + [| \ (b, x) -> if b then Just x else Nothing |] + +instance Default Bool where def = False + +-- | The characteristic of a ring, represented as a type. +type family CharOf fp :: k + +-- | Poor man's 'Enum'. +class Enumerable a where + values :: [a] + +-- | Represents a quotient group modulo some integer. +class (ToInteger (ModRep a), Additive a) => Mod a where + type ModRep a + modulus :: Tagged a (ModRep a) + +-- | Represents that @a@ is a subgroup of @b@. +class (Additive a, Additive b) => Subgroup a b where + fromSubgroup :: a -> b + +-- | Represents that @b@ is a quotient group of @a@. +class (Additive a, Additive b) => Reduce a b where + reduce :: a -> b + +-- | Represents that @b@ can be lifted to a "short" @a@ congruent to @b@. +type Lift b a = (Lift' b, LiftOf b ~ a) + +-- | The type of representatives of @b@. +type family LiftOf b + +-- | Fun-dep version of Lift. +class (Reduce (LiftOf b) b) => Lift' b where + lift :: b -> LiftOf b + +-- | Represents that @a@ can be rescaled to @b@, as an "approximate" +-- additive homomorphism. +class (Additive a, Additive b) => Rescale a b where + rescale :: a -> b + +-- | Represents that the target ring can "noisily encode" values from +-- the source ring, in either "most significant digit" (MSD) or "least +-- significant digit" (LSD) encodings, and provides conversion factors +-- between the two types of encodings. + +class (Field src, Field tgt) => Encode src tgt where + -- | The factor that converts an element from LSD to MSD encoding + -- in the target field, with associated scale factor to apply to + -- correct the resulting encoded value. + lsdToMSD :: (src, tgt) + +-- | Inverted entries of 'lsdToMSD'. +msdToLSD :: (Encode src tgt) => (src, tgt) +msdToLSD = (recip *** recip) lsdToMSD +{-# INLINABLE msdToLSD #-} + +-- | A default implementation of rescaling for 'Mod' types. +rescaleMod :: forall a b . + (Mod a, Mod b, (ModRep a) ~ (ModRep b), + Lift a (ModRep b), Ring b) + => a -> b +{-# INLINABLE rescaleMod #-} +rescaleMod = + let qval = proxy modulus (Proxy :: Proxy a) + q'val = proxy modulus (Proxy :: Proxy b) + in \x -> let (quot',_) = divModCent (q'val * lift x) qval + in fromIntegral quot' + +-- | Deterministically round to a nearby value in the desired coset +roundCoset :: forall zp z r . + (Mod zp, z ~ ModRep zp, Lift zp z, RealField r) => zp -> r -> z +{-# INLINABLE roundCoset #-} +roundCoset = let pval = proxy modulus (Proxy::Proxy zp) + in \ zp x -> let rep = lift zp + in rep + roundMult pval (x - fromIntegral rep) + +---------- Instances for product groups/rings ---------- + +type instance LiftOf (a,b) = Integer + +-- | Lift product ring of @Zq@s to 'Integer' +instance (Mod a, Mod b, Lift' a, Lift' b, Reduce Integer (a,b), + ToInteger (LiftOf a), ToInteger (LiftOf b)) + => Lift' (a,b) where + + {-# INLINABLE lift #-} + lift (a,b) = + let moda = toInteger $ proxy modulus (Proxy::Proxy a) + modb = toInteger $ proxy modulus (Proxy::Proxy b) + q = moda * modb + ainv = fromMaybe (error "Lift' (a,b): moduli not coprime") $ moda `modinv` modb + lifta = toInteger $ lift a + liftb = toInteger $ lift b + -- put in [-q/2, q/2) + (_,r) = (moda * (liftb - lifta) * ainv + lifta) `divModCent` q + in r + + +-- | Pair as product ring +instance (Ring r1, Ring r2) => Ring.C (r1, r2) where + (x1, x2) * (y1, y2) = (x1*y1, x2*y2) + one = (one,one) + fromInteger x = (fromInteger x, fromInteger x) + + {-# INLINABLE (*) #-} + {-# INLINABLE one #-} + {-# INLINABLE fromInteger #-} + +-- | Product ring as an (almost) field +instance (Field f1, Field f2) => Field.C (f1, f2) where + (x1, x2) / (y1, y2) = (x1 / y1, x2 / y2) + recip = recip *** recip + {-# INLINABLE (/) #-} + {-# INLINABLE recip #-} + +-- | Product ring as an (almost) integral domain +instance (IntegralDomain a, IntegralDomain b) => IntegralDomain.C (a,b) where + (a1,b1) `divMod` (a2,b2) = + let (da,ra) = (a1 `divMod` a2) + (db,rb) = (b1 `divMod` b2) + in ((da,db), (ra,rb)) + {-# INLINABLE divMod #-} + +-- | Product ring of @Zq@s as a @Zq@ (with 'Integer' modulus) +instance (Mod a, Mod b) => Mod (a,b) where + type ModRep (a,b) = Integer + + modulus = tag $ fromIntegral (proxy modulus (Proxy::Proxy a)) * + fromIntegral (proxy modulus (Proxy::Proxy b)) + {-# INLINABLE modulus #-} + +-- | Reduce into product ring. +instance (Reduce a b1, Reduce a b2) => Reduce a (b1, b2) where + reduce x = (reduce x, reduce x) + {-# INLINABLE reduce #-} + +-- | Rescale a product ring of @Zq@s +instance (Mod a, Field b, Lift a (ModRep a), Reduce (LiftOf a) b) + => Rescale (a,b) b where + rescale = let q1val = proxy modulus (Proxy::Proxy a) + q1inv = recip $ reduce q1val + in \(x1,x2) -> q1inv * (x2 - reduce (lift x1)) + {-# INLINABLE rescale #-} + +-- | Rescale a product ring of @Zq@s +instance (Mod b, Field a, Lift b (ModRep b), Reduce (LiftOf b) a) + => Rescale (a,b) a where + rescale = let q2val = proxy modulus (Proxy::Proxy b) + q2inv = recip $ reduce q2val + in \(x1,x2) -> q2inv * (x1 - reduce (lift x2)) + {-# INLINABLE rescale #-} + +-- | Rescale a (multi-)product ring of @Zq@s +instance (Rescale (a,(b,c)) (b,c), Rescale (b,c) c) + => Rescale (a,(b,c)) c where + rescale = (rescale :: (b,c) -> c) . rescale + {-# INLINABLE rescale #-} + +-- | Rescale a (multi-)product ring of @Zq@s +instance (Rescale ((a,b),c) (a,b), Rescale (a,b) a) + => Rescale ((a,b),c) a where + rescale = (rescale :: (a,b) -> a) . rescale + {-# INLINABLE rescale #-} + +-- | Rescale /up/ to a product ring of @Zq@s +instance (Ring a, Mod b, Reduce (ModRep b) a) => Rescale a (a,b) where + -- multiply by q2 + rescale = let q2val = reduce $ proxy modulus (Proxy::Proxy b) + in \x -> (q2val * x, zero) + {-# INLINABLE rescale #-} + +-- | Rescale /up/ to a product ring of @Zq@s +instance (Ring b, Mod a, Reduce (ModRep a) b) => Rescale b (a,b) where + -- multiply by q1 + rescale = let q1val = reduce $ proxy modulus (Proxy::Proxy a) + in \x -> (zero, q1val * x) + {-# INLINABLE rescale #-} + +-- | Encode for a product ring +instance (Encode s t1, Encode s t2, Field (t1, t2)) => Encode s (t1, t2) where + {-# INLINABLE lsdToMSD #-} + lsdToMSD = let (s1, t1conv) = lsdToMSD + (s2, t2conv) = lsdToMSD + in (negate s1 * s2, (t1conv,t2conv)) + +-- Random could have defined this instance, but didn't, so we do it +-- here. +instance (Random a, Random b) => Random (a,b) where + {-# INLINABLE random #-} + random g = let (a,g') = random g + (b, g'') = random g' + in ((a,b), g'') + + {-# INLINABLE randomR #-} + randomR ((loa,lob), (hia,hib)) g = let (a,g') = randomR (loa,hia) g + (b,g'') = randomR (lob,hib) g' + in ((a,b),g'') + +-- | Version of 'fromJust' with an error message. +fromJust' :: String -> Maybe a -> a +fromJust' str = fromMaybe (error str) + +-- | Apply any applicative to a Tagged value. +pureT :: Applicative f => Tagged t a -> TaggedT t f a +pureT = mapTaggedT (pure . runIdentity) + +-- | Expose the monad of a tagged value. +peelT :: Tagged t (f a) -> TaggedT t f a +peelT = coerce + +-- | Hide the monad of a tagged value. +pasteT :: TaggedT t f a -> Tagged t (f a) +pasteT = coerce + +-- | Use a singleton as a witness to extract a value from a tagged value. +withWitness :: forall n r . (SingI n => Tagged n r) -> Sing n -> r +withWitness t wit = withSingI wit $ proxy t (Proxy::Proxy n) +{-# INLINABLE withWitness #-} + +-- | Transformer version of 'withWitness'. +withWitnessT :: forall n mon r . + (SingI n => TaggedT n mon r) -> Sing n -> mon r +withWitnessT t wit = withSingI wit $ proxyT t (Proxy::Proxy n) +{-# INLINABLE withWitnessT #-} diff --git a/Crypto/Lol/RLWE/Continuous.hs b/Crypto/Lol/RLWE/Continuous.hs new file mode 100644 --- /dev/null +++ b/Crypto/Lol/RLWE/Continuous.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE ConstraintKinds, FlexibleContexts, MultiParamTypeClasses, + NoImplicitPrelude, RebindableSyntax, ScopedTypeVariables #-} + +-- | Functions and types for working with continuous ring-LWE samples. + +module Crypto.Lol.RLWE.Continuous where + +import Crypto.Lol.Cyclotomic.Cyc as C +import Crypto.Lol.Cyclotomic.Tensor (TElt) +import Crypto.Lol.Cyclotomic.UCyc as U +import Crypto.Lol.Prelude + +import Control.Applicative +import Control.Monad.Random + +-- | A continuous RLWE sample @(a,b) \in R_q \times K/qR@. (The +-- second component is a 'UCyc' because the base type @rrq@ +-- representing @RR/qZ@, the reals modulo @qZ@, is an additive group +-- but not a ring, so we can't usefully work with a 'Cyc' over it.) +type Sample t m zq rrq = (Cyc t m zq, UCyc t m D rrq) + +-- | Common constraints for working with continuous RLWE. +type RLWECtx t m zq rrq = + (Fact m, Ring zq, CElt t zq, Subgroup zq rrq, Lift' rrq, + TElt t rrq, TElt t (LiftOf rrq)) + +-- | A continuous RLWE sample with the given scaled variance and +-- secret. +sample :: forall rnd v t m zq rrq . + (RLWECtx t m zq rrq, Random zq, Random (LiftOf rrq), OrdFloat (LiftOf rrq), + MonadRandom rnd, ToRational v) + => v -> Cyc t m zq -> rnd (Sample t m zq rrq) +{-# INLINABLE sample #-} +sample svar s = let s' = adviseCRT s in do + a <- getRandom + e :: UCyc t m D (LiftOf rrq) <- U.tGaussian svar + let as = fmapDec fromSubgroup $ uncycDec $ a * s' :: UCyc t m D rrq + return (a, as + reduce e) + +-- | The error term of an RLWE sample, given the purported secret. +errorTerm :: (RLWECtx t m zq rrq) + => Cyc t m zq -> Sample t m zq rrq -> UCyc t m D (LiftOf rrq) +{-# INLINABLE errorTerm #-} +errorTerm s = let s' = adviseCRT s + in \(a,b) -> lift $ b - fmapDec fromSubgroup (uncycDec $ a * s') + +-- | The 'gSqNorm' of the error term of an RLWE sample, given the +-- purported secret. +errorGSqNorm :: (RLWECtx t m zq rrq, Ring (LiftOf rrq)) + => Cyc t m zq -> Sample t m zq rrq -> LiftOf rrq +{-# INLINABLE errorGSqNorm #-} +errorGSqNorm s = U.gSqNorm . errorTerm s + +-- | A bound such that the 'gSqNorm' of a continuous error generated +-- by 'tGaussian' with scaled variance @v@ (over the @m@th cyclotomic +-- field) is less than the bound except with probability approximately +-- @eps@. +errorBound :: (Ord v, Transcendental v, Fact m) + => v -- ^ the scaled variance + -> v -- ^ @eps@ + -> Tagged m v +errorBound v eps = do + n <- fromIntegral <$> totientFact + mhat <- fromIntegral <$> valueHatFact + let stabilize x = + let x' = (1/2 + log (2 * pi * x)/2 - log eps/n)/pi + in if x'-x < 0.0001 then x' else stabilize x' + return $ mhat * n * v * stabilize (1/(2*pi)) diff --git a/Crypto/Lol/RLWE/Discrete.hs b/Crypto/Lol/RLWE/Discrete.hs new file mode 100644 --- /dev/null +++ b/Crypto/Lol/RLWE/Discrete.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE ConstraintKinds, FlexibleContexts, MultiParamTypeClasses, + NoImplicitPrelude, RebindableSyntax, ScopedTypeVariables #-} + +-- | Functions and types for working with discretized ring-LWE samples. + +module Crypto.Lol.RLWE.Discrete where + +import Crypto.Lol.Cyclotomic.Cyc +import Crypto.Lol.Prelude +import Crypto.Lol.RLWE.Continuous as C (errorBound) + +import Control.Applicative +import Control.Monad.Random + +-- | A discrete RLWE sample @(a,b) \in R_q \times R_q@. +type Sample t m zq = (Cyc t m zq, Cyc t m zq) + +-- | Common constraints for working with discrete RLWE. +type RLWECtx t m zq = + (Fact m, Ring zq, Lift' zq, ToInteger (LiftOf zq), + CElt t zq, CElt t (LiftOf zq)) + +-- | A discrete RLWE sample with the given scaled variance and +-- secret. +sample :: forall rnd v t m zq . + (RLWECtx t m zq, Random zq, MonadRandom rnd, ToRational v) + => v -> Cyc t m zq -> rnd (Sample t m zq) +{-# INLINABLE sample #-} +sample svar s = let s' = adviseCRT s in do + a <- getRandom + e :: Cyc t m (LiftOf zq) <- errorRounded svar + return (a, a * s' + reduce e) + +-- | The error term of an RLWE sample, given the purported secret. +errorTerm :: (RLWECtx t m zq) + => Cyc t m zq -> Sample t m zq -> Cyc t m (LiftOf zq) +{-# INLINABLE errorTerm #-} +errorTerm s = let s' = adviseCRT s + in \(a,b) -> liftDec $ b - a * s' + +-- | The 'gSqNorm' of the error term of an RLWE sample, given the +-- purported secret. +errorGSqNorm :: (RLWECtx t m zq, Ring (LiftOf zq)) + => Cyc t m zq -> Sample t m zq -> LiftOf zq +{-# INLINABLE errorGSqNorm #-} +errorGSqNorm s = gSqNorm . errorTerm s + +-- | A bound such that the 'gSqNorm' of a discretized error term +-- generated by 'errorRounded' with scaled variance @v@ (over the @m@th +-- cyclotomic field) is less than the bound except with probability +-- approximately @eps@. +errorBound :: (RealRing v, Transcendental v, Fact m) + => v -- ^ the scaled variance + -> v -- ^ @eps@ + -> Tagged m Int64 +errorBound v eps = do + n <- fromIntegral <$> totientFact + cont <- C.errorBound v eps -- continuous bound + ps <- filter (/= 2) . fmap fst <$> ppsFact -- odd primes dividing m + let stabilize x = + let x' = (1/2 + log(2 * pi * x)/2 - log eps)/pi + in if x'-x < 0.0001 then x' else stabilize x' + return $ ceiling $ (2 ^ length ps) * n * stabilize (1/(2*pi)) + cont + diff --git a/Crypto/Lol/RLWE/RLWR.hs b/Crypto/Lol/RLWE/RLWR.hs new file mode 100644 --- /dev/null +++ b/Crypto/Lol/RLWE/RLWR.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE ConstraintKinds, FlexibleContexts, MultiParamTypeClasses, + NoImplicitPrelude, ScopedTypeVariables #-} + +-- | Functions and types for working with ring-LWR samples. + +module Crypto.Lol.RLWE.RLWR where + +import Crypto.Lol + +import Control.Monad.Random + +-- | An RLWR sample @(a,b) \in R_q \times R_p@. +type Sample t m zq zp = (Cyc t m zq, Cyc t m zp) + +-- | Common constraints for working with RLWR. +type RLWRCtx t m zq zp = + (Fact m, Ring zq, RescaleCyc (Cyc t) zq zp, CElt t zq, CElt t zp) + +-- | An RLWR sample with the given secret. +sample :: (RLWRCtx t m zq zp, Random zq, MonadRandom rnd) + => Cyc t m zq -> rnd (Sample t m zq zp) +sample s = let s' = adviseCRT s in do + a <- getRandom + return (a, roundedProd s' a) + +-- | The @b@ component of an RLWR sample for secret @s@ and given @a@, +-- produced by rounding @a*s@ in the decoding basis. +roundedProd :: (RLWRCtx t m zq zp) => Cyc t m zq -> Cyc t m zq -> Cyc t m zp +{-# INLINABLE roundedProd #-} +roundedProd s = let s' = adviseCRT s in \a -> rescaleCyc Dec $ a * s' + diff --git a/Crypto/Lol/Reflects.hs b/Crypto/Lol/Reflects.hs --- a/Crypto/Lol/Reflects.hs +++ b/Crypto/Lol/Reflects.hs @@ -5,10 +5,11 @@ -- | Generic interface for reflecting types to values. module Crypto.Lol.Reflects -( Reflects(..) +( Reflects(..), ) where import Algebra.ToInteger as ToInteger +import Algebra.Ring as Ring import NumericPrelude import Crypto.Lol.Factored @@ -40,18 +41,15 @@ -} --- CJP: need reflections for Prime and PrimePower types because we use --- them with ZqBasic - -instance (Prim p, ToInteger.C i) => Reflects p i where +instance (Prime p, ToInteger.C i) => Reflects p i where value = fromIntegral <$> valuePrime instance (PPow pp, ToInteger.C i) => Reflects pp i where value = fromIntegral <$> valuePPow --- CJP: need this for Types.ZmStar, where we use ZqBasic m Int instance (Fact m, ToInteger.C i) => Reflects m i where value = fromIntegral <$> valueFact -instance {-# OVERLAPS #-} (Reifies rei a) => Reflects (rei :: *) a where - value = tag $ reflect (Proxy::Proxy rei) +instance (Reifies q i, ToInteger.C i, Ring.C r) + => Reflects (q :: *) r where + value = tag $ fromIntegral $ reflect (Proxy::Proxy q) diff --git a/Crypto/Lol/Types/Complex.hs b/Crypto/Lol/Types/Complex.hs --- a/Crypto/Lol/Types/Complex.hs +++ b/Crypto/Lol/Types/Complex.hs @@ -1,8 +1,15 @@ -{-# LANGUAGE DataKinds, FlexibleContexts, FlexibleInstances, - GeneralizedNewtypeDeriving, MultiParamTypeClasses, - NoImplicitPrelude, RebindableSyntax, ScopedTypeVariables, - StandaloneDeriving, TemplateHaskell, TypeFamilies, - UndecidableInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} -- | Data type, functions, and instances for complex numbers. @@ -31,19 +38,18 @@ -- | Newtype wrapper (with slightly different instances) for -- . -newtype Complex a = Complex (C.T a) deriving (Additive.C, Ring.C, ZeroTestable.C, Field.C, Storable, Eq, Show, Arbitrary) +newtype Complex a = Complex (C.T a) + deriving (Additive.C, Ring.C, ZeroTestable.C, Field.C, Storable, Eq, Show, Arbitrary) derivingUnbox "Complex" [t| forall a . (Unbox a) => Complex a -> (a, a) |] [| \ (Complex x) -> (C.real x, C.imag x) |] [| \ (r, i) -> Complex $ r C.+: i |] --- a custom IntegralDomain instance, replacing the one provided by NP. --- it always returns 0 as the remainder of a division. If we were to --- use the NP instance, sometimes precision issues yield nonzero --- remainders, which makes, e.g., 'divGPow' think that division has --- failed, when it has not. This in turn causes 'divGCRT' to yield --- Nothing, among other problems. +-- | Custom instance replacing the one provided by numeric prelude: it +-- always returns 0 as the remainder of a division. (The NP instance +-- sometimes has precision issues, because it yields nonzero +-- remainders, which is a problem for 'divG' methods.) instance (Field a) => IntegralDomain.C (Complex a) where (Complex a) `divMod` (Complex b) = (Complex $ a / b, LP.zero) diff --git a/Crypto/Lol/Types/FiniteField.hs b/Crypto/Lol/Types/FiniteField.hs --- a/Crypto/Lol/Types/FiniteField.hs +++ b/Crypto/Lol/Types/FiniteField.hs @@ -1,8 +1,16 @@ -{-# LANGUAGE ConstraintKinds, DataKinds, FlexibleContexts, - GeneralizedNewtypeDeriving, MultiParamTypeClasses, - NoImplicitPrelude, PolyKinds, RebindableSyntax, - RoleAnnotations, ScopedTypeVariables, TypeFamilies, - UndecidableInstances #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} -- CJP: need PolyKinds to allow d to have non-* kind @@ -18,7 +26,7 @@ import Crypto.Lol.CRTrans import Crypto.Lol.Factored -import Crypto.Lol.LatticePrelude +import Crypto.Lol.Prelude import Crypto.Lol.Reflects import Algebra.Additive as Additive (C) @@ -44,9 +52,11 @@ -- the second argument, though phantom, affects representation type role GF representational representational +-- | Constraint synonym for a prime field. type PrimeField fp = (Enumerable fp, Field fp, Eq fp, ZeroTestable fp, - Prim (CharOf fp), IrreduciblePoly fp) + Prime (CharOf fp), IrreduciblePoly fp) +-- | Constraint synonym for a finite field. type GFCtx fp d = (PrimeField fp, Reflects d Int) instance (GFCtx fp d) => Enumerable (GF fp d) where @@ -69,26 +79,35 @@ in \(GF f) -> let (_,(a,_)) = extendedGCD f g in GF a -instance (GFCtx fp d) => CRTrans (GF fp d) where +instance (GFCtx fp d) => CRTrans Maybe (GF fp d) where - crtInfo m = (,) <$> omegaPow <*> scalarInv + crtInfo :: forall m . (Reflects m Int) => TaggedT m Maybe (CRTInfo (GF fp d)) + crtInfo = tagT $ (,) <$> omegaPow <*> scalarInv where + omegaPow :: Maybe (Int -> GF fp d) omegaPow = let size' = proxy size (Proxy :: Proxy (GF fp d)) - (q,r) = (size'-1) `quotRem` m + mval = proxy value (Proxy :: Proxy m) + (q,r) = (size'-1) `quotRem` mval gen = head $ filter isPrimitive values omega = gen^q - omegaPows = V.iterateN m (*omega) one + omegaPows = V.iterateN mval (*omega) one in if r == 0 - then Just $ (omegaPows V.!) . (`mod` m) + then Just $ (omegaPows V.!) . (`mod` mval) else Nothing - scalarInv = Just $ recip $ fromIntegral $ valueHat m + scalarInv :: Maybe (GF fp d) + scalarInv = Just $ recip $ fromIntegral $ valueHat + (proxy value (Proxy::Proxy m) :: Int) +-- | This wrapper for a list of coefficients is used to define a +-- @GF(p^d)@-module structure for tensors over @F_p@ of dimension @n@, where +-- @d | n@. newtype TensorCoeffs a = Coeffs {unCoeffs :: [a]} deriving (Additive.C) + instance (Additive fp, Ring (GF fp d), Reflects d Int) => Module.C (GF fp d) (TensorCoeffs fp) where - r *> (Coeffs fps) = + r *> (Coeffs fps) = let dval = proxy value (Proxy::Proxy d) n = length fps in if n `mod` dval /= 0 then @@ -103,18 +122,18 @@ | otherwise = error "chunksOf: non-positive n" -- | Yield a list of length exactly @d@ (i.e., including trailing zeros) --- of the @fp@-coefficients with respect to the power basis +-- of the @fp@-coefficients with respect to the power basis. toList :: forall fp d . (Reflects d Int, Additive fp) => GF fp d -> [fp] toList = let dval = proxy value (Proxy::Proxy d) in \(GF p) -> let l = coeffs p - in l ++ (replicate (dval - length l) zero) + in l ++ replicate (dval - length l) zero -- | Yield a field element given up to @d@ coefficients with respect -- to the power basis. fromList :: forall fp d . (Reflects d Int) => [fp] -> GF fp d fromList = let dval = proxy value (Proxy::Proxy d) in \cs -> if length cs <= dval then GF $ fromCoeffs cs - else error $ "FiniteField.fromList: length " ++ + else error $ "FiniteField.fromList: length " ++ show (length cs) ++ " > degree " ++ show dval sizePP :: forall fp d . (GFCtx fp d) => Tagged (GF fp d) PP @@ -148,7 +167,7 @@ -- ", d = " ++ show (proxy value (Proxy::Proxy d) :: Int)) $ let d = proxy value (Proxy :: Proxy d) in tag $ map trace' $ take d $ - iterate (* (GF (X ^^ 1))) (one :: GF fp d) + iterate (* GF (X ^^ 1)) (one :: GF fp d) -- helper that computes trace via brute force: sum frobenius -- automorphisms diff --git a/Crypto/Lol/Types/IZipVector.hs b/Crypto/Lol/Types/IZipVector.hs --- a/Crypto/Lol/Types/IZipVector.hs +++ b/Crypto/Lol/Types/IZipVector.hs @@ -16,8 +16,10 @@ import Control.DeepSeq import Data.Data import Data.Functor.Trans.Tagged -import Data.Vector as V +import Data.Vector as V + + -- | Indexed Zip Vector: a wrapper around a (boxed) 'Vector' that has -- zip-py 'Applicative' behavior, analogous to -- 'Control.Applicative.ZipList' for lists. The index @m@ enforces @@ -28,8 +30,7 @@ unIZipVector :: Vector a} -- not deriving Read, Monoid, Alternative, Monad[Plus], IsList -- because of different semantics and/or length restriction - deriving (Show, Eq, NFData, Functor, - Foldable, Traversable, ZeroTestable.C) + deriving (Show, Eq, NFData, Functor, Foldable, Traversable, ZeroTestable.C) -- the first argument, though phantom, affects representation type role IZipVector representational representational @@ -42,6 +43,7 @@ then Just $ IZipVector vec else Nothing +-- | Unzip an IZipVector. unzipIZV :: IZipVector m (a,b) -> (IZipVector m a, IZipVector m b) unzipIZV (IZipVector v) = let (va,vb) = V.unzip v in (IZipVector va, IZipVector vb) diff --git a/Crypto/Lol/Types/IrreducibleChar2.hs b/Crypto/Lol/Types/IrreducibleChar2.hs --- a/Crypto/Lol/Types/IrreducibleChar2.hs +++ b/Crypto/Lol/Types/IrreducibleChar2.hs @@ -6,62 +6,165 @@ module Crypto.Lol.Types.IrreducibleChar2 () where -import Crypto.Lol.LatticePrelude +import Crypto.Lol.Prelude hiding (lookup) import Crypto.Lol.Reflects -import Crypto.Lol.Types.FiniteField - --- | Convenience function. -taggedProxy :: Tagged s (Proxy s) -taggedProxy = tag Proxy +import Crypto.Lol.Types.FiniteField hiding (fromList) --- CJP: we should perhaps prefer ternary (or 5-ary) polynomials over --- Conway polynomials, because we don't use the special properties of --- Conways, and reduction modulo sparse polynomials should be faster. +import Data.Map hiding (map) +import Data.Maybe (fromMaybe) --- conway ---generate in Python (or choose any irreducible polynomial) --- to generate with Sage, start sage and type: --- conway_polynomial(p,e) --- then copy and paste instance (CharOf a ~ Prime2, Field a) => IrreduciblePoly a where irreduciblePoly = do - pn <- taggedProxy - let n = proxy value pn :: Int - return $ case n of - 1 -> X^^1 + 1 - 2 -> X^^2 + X^^1 + 1 - 3 -> X^^3 + X^^1 + 1 - 4 -> X^^4 + X^^1 + 1 - 5 -> X^^5 + X^^2 + 1 - 6 -> X^^6 + X^^4 + X^^3 + X^^1 + 1 - 7 -> X^^7 + X^^1 + 1 - 8 -> X^^8 + X^^4 + X^^3 + X^^2 + 1 - 9 -> X^^9 + X^^4 + 1 - 10 -> X^^10 + X^^6 + X^^5 + X^^3 + X^^2 + X^^1 + 1 - 11 -> X^^11 + X^^2 + 1 - 12 -> X^^12 + X^^7 + X^^6 + X^^5 + X^^3 + X^^1 + 1 - 13 -> X^^13 + X^^4 + X^^3 + X^^1 + 1 - 14 -> X^^14 + X^^7 + X^^5 + X^^3 + 1 - 15 -> X^^15 + X^^5 + X^^4 + X^^2 + 1 - 16 -> X^^16 + X^^5 + X^^3 + X^^2 + 1 - 17 -> X^^17 + X^^3 + 1 - 18 -> X^^18 + X^^12 + X^^10 + X^^1 + 1 - 19 -> X^^19 + X^^5 + X^^2 + X^^1 + 1 - 20 -> X^^20 + X^^10 + X^^9 + X^^7 + X^^6 + X^^5 + X^^4 + X^^1 + 1 - 21 -> X^^21 + X^^6 + X^^5 + X^^2 + 1 - 22 -> X^^22 + X^^12 + X^^11 + X^^10 + X^^9 + X^^8 + X^^6 + X^^5 + 1 - 23 -> X^^23 + X^^5 + 1 - 24 -> X^^24 + X^^16 + X^^15 + X^^14 + X^^13 + X^^10 + X^^9 + X^^7 + X^^5 + X^^3 + 1 - 25 -> X^^25 + X^^8 + X^^6 + X^^2 + 1 - 26 -> X^^26 + X^^14 + X^^10 + X^^8 + X^^7 + X^^6 + X^^4 + X^^1 + 1 - 27 -> X^^27 + X^^12 + X^^10 + X^^9 + X^^7 + X^^5 + X^^3 + X^^2 + 1 - 28 -> X^^28 + X^^13 + X^^7 + X^^6 + X^^5 + X^^2 + 1 - 29 -> X^^29 + X^^2 + 1 - 30 -> X^^30 + X^^17 + X^^16 + X^^13 + X^^11 + X^^7 + X^^5 + X^^3 + X^^2 + X^^1 + 1 - 31 -> X^^31 + X^^3 + 1 - 32 -> X^^32 + X^^15 + X^^9 + X^^7 + X^^4 + X^^3 + 1 - _ -> - error $ "The IrreduciblePoly instance for N2 included with the library (and exported by Crypto.Lol) only contains " ++ - "irreducible polynomials for characteristic-2 fields up to GF(2^^32). You need a polynomial " ++ - "for GF(2^^" ++ (show n) ++ "). Define your own instance of IrreduciblePoly and do " ++ - "not import Crypto.Lol." + n <- value + return $ flip fromMaybe (lookup n polyMap) $ + error $ + "The IrreduciblePoly instance for N2 included with the library " ++ + "(and exported by Crypto.Lol) only contains irreducible polynomials " ++ + "for characteristic-2 fields up to GF(2^^32). You need a polynomial " ++ + "for GF(2^^" ++ show n ++ "). Define your own instance of " ++ + "IrreduciblePoly and do not import Crypto.Lol." + +polyMap :: (Ring fp) => Map Int (Polynomial fp) +polyMap = fromList $ map (\xs -> (head xs, coeffsToPoly xs)) coeffs + +coeffsToPoly :: (Ring fp) => [Int] -> Polynomial fp +coeffsToPoly [a,b] = X^^a + X^^b + 1 +coeffsToPoly [a,b,c,d] = X^^a + X^^b + X^^c + X^^d + 1 + +-- The list below is small portion of the table +-- "Table of Low-Weight binary Irreducible Polynomials" at +-- http://www.hpl.hp.com/techreports/98/HPL-98-135.pdf?jumpid=reg_R1002_USEN +-- The lists are coefficients of minimal polynomials: +-- [a,b] is the irreducible trinomial X^a + X^b + 1 +-- [a,b,c,d] is the irreducible pentanomial X^a + X^b + X^c + X^d + 1 +coeffs :: [[Int]] +coeffs = [ + [1,1], + [2,1], + [3,1], + [4,1], + [5,2], + [6,1], + [7,1], + [8,4,3,1], + [9,1], + [10,3], + [11,2], + [12,3], + [13,4,3,1], + [14,5], + [15,1], + [16,5,3,1], + [17,3], + [18,3], + [19,5,2,1], + [20,3], + [21,2], + [22,1], + [23,5], + [24,4,3,1], + [25,3], + [26,4,3,1], + [27,5,2,1], + [28,1], + [29,2], + [30,1], + [31,3], + [32,7,3,2], + [33,10], + [34,7], + [35,2], + [36,9], + [37,6,4,1], + [38,6,5,1], + [39,4], + [40,5,4,3], + [41,3], + [42,7], + [43,6,4,3], + [44,5], + [45,4,3,1], + [46,1], + [47,5], + [48,5,3,2], + [49,9], + [50,4,3,2], + [51,6,3,1], + [52,3], + [53,6,2,1], + [54,9], + [55,7], + [56,7,4,2], + [57,4], + [58,19], + [59,7,4,2], + [60,1], + [61,5,2,1], + [62,29], + [63,1], + [64,4,3,1], + [65,18], + [66,3], + [67,5,2,1], + [68,9], + [69,6,5,2], + [70,5,3,1], + [71,6], + [72,10,9,3], + [73,25], + [74,35], + [75,6,3,1], + [76,21], + [77,6,5,2], + [78,6,5,3], + [79,9], + [80,9,4,2], + [81,4], + [82,8,3,1], + [83,7,4,2], + [84,5], + [85,8,2,1], + [86,21], + [87,13], + [88,7,6,2], + [89,38], + [90,27], + [91,8,5,1], + [92,21], + [93,2], + [94,21], + [95,11], + [96,10,9,6], + [97,6], + [98,11], + [99,6,3,1], + [100,15], + [101,7,6,1], + [102,29], + [103,9], + [104,4,3,1], + [105,4], + [106,15], + [107,9,7,4], + [108,17], + [109,5,4,2], + [110,33], + [111,10], + [112,5,4,3], + [113,9], + [114,5,3,2], + [115,8,7,5], + [116,4,2,1], + [117,5,2,1], + [118,33], + [119,8], + [120,4,3,1], + [121,18], + [122,6,2,1], + [123,2], + [124,19], + [125,7,6,5], + [126,21], + [127,1], + [128,7,2,1] + ] diff --git a/Crypto/Lol/Types/Numeric.hs b/Crypto/Lol/Types/Numeric.hs --- a/Crypto/Lol/Types/Numeric.hs +++ b/Crypto/Lol/Types/Numeric.hs @@ -131,7 +131,7 @@ -- | Sane synonym for 'MathObj.Polynomial.T'. type Polynomial a = MathObj.Polynomial.T a --- | IntegralDomain instance for Double +-- IntegralDomain instance for Double instance Algebra.IntegralDomain.C Double where _ `div` 0 = error "cannot divide Double by 0\n" a `div` b = a / b @@ -204,7 +204,7 @@ => i -- ^ dividend @a@ -> i -- ^ divisor @b@ -> (i,i) -- ^ (quotient, remainder) -divModCent = flip (\b -> +divModCent = flip (\b -> let shift = b `div` 2 in \a -> let (q,r) = (a+shift) `divMod` b in (q,r-shift)) diff --git a/Crypto/Lol/Types/Proto.hs b/Crypto/Lol/Types/Proto.hs new file mode 100644 --- /dev/null +++ b/Crypto/Lol/Types/Proto.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE FlexibleContexts, FlexibleInstances, PolyKinds, + ScopedTypeVariables, TypeFamilies #-} + +-- | Convenient interfaces for serialization with protocol buffers. + +module Crypto.Lol.Types.Proto where + +import Control.Monad.Except +import Data.ByteString.Lazy hiding (map) +import Data.Foldable (toList) +import Data.Sequence (fromList) + +import Text.ProtocolBuffers (messageGet, messagePut) +import Text.ProtocolBuffers.Header + +-- | Conversion between Haskell types and their protocol buffer representations. +class Protoable a where + -- | The protocol buffer type for @a@. + type ProtoType a + + -- | Convert from a type to its protocol buffer representation. + toProto :: a -> ProtoType a + -- | Convert from a protocol buffer representation. + fromProto :: MonadError String m => ProtoType a -> m a + +instance (Protoable a) => Protoable [a] where + type ProtoType [a] = Seq (ProtoType a) + toProto = fromList . map toProto + fromProto = mapM fromProto . toList + +instance (Protoable a, Protoable b) => Protoable (a,b) where + type ProtoType (a,b) = (ProtoType a, ProtoType b) + toProto (a,b) = (toProto a, toProto b) + fromProto (a,b) = do + a' <- fromProto a + b' <- fromProto b + return (a',b') + +-- | Serialize a Haskell type to its protocol buffer 'ByteString'. +msgPut :: (ReflectDescriptor (ProtoType a), Wire (ProtoType a), Protoable a) + => a -> ByteString +msgPut = messagePut . toProto + +-- | Read a protocol buffer 'ByteString' to a Haskell type. +msgGet :: (ReflectDescriptor (ProtoType a), Wire (ProtoType a), Protoable a) + => ByteString -> Either String (a, ByteString) +msgGet bs = do + (msg, bs') <- messageGet bs + p <- fromProto msg + return (p, bs') diff --git a/Crypto/Lol/Types/RRq.hs b/Crypto/Lol/Types/RRq.hs new file mode 100644 --- /dev/null +++ b/Crypto/Lol/Types/RRq.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE ConstraintKinds, FlexibleContexts, FlexibleInstances, + GeneralizedNewtypeDeriving, MultiParamTypeClasses, + NoImplicitPrelude, PolyKinds, RebindableSyntax, + ScopedTypeVariables, TypeFamilies, UndecidableInstances #-} + +-- | An implementation of the additive quotient group @RR/qZ@, where @RR@ +-- denotes the real numbers. + +module Crypto.Lol.Types.RRq +( RRq +) where + +import Algebra.Additive as Additive (C) +import Algebra.ZeroTestable as ZeroTestable (C) + +import Control.Applicative +import Control.DeepSeq + +import Crypto.Lol.Prelude +import Crypto.Lol.Reflects +import Crypto.Lol.Types.ZqBasic + +-- for the Elt instance +import qualified Data.Array.Repa.Eval as E + +-- for the Unbox instances +import qualified Data.Vector.Generic as G +import qualified Data.Vector.Generic.Mutable as M +import qualified Data.Vector.Unboxed as U + +import Foreign.Storable + +-- invariant: 0 <= x < q +-- | The ring @RR_q@ of reals modulo 'q', using underlying floating +-- type 'r'. +newtype RRq q r = RRq r + deriving (Eq, Ord, ZeroTestable.C, E.Elt, Show, NFData, Storable) + +{-# INLINABLE reduce' #-} +reduce' :: forall q r . (Reflects q r, RealField r) => r -> RRq q r +reduce' = let q = proxy value (Proxy::Proxy q) + in \x -> RRq $ x - q * floor (x / q) + +-- puts value in range [-q/2, q/2) +decode' :: forall q r . (Reflects q r, Ord r, Additive r, Ring r) + => RRq q r -> r +decode' = let qval = proxy value (Proxy::Proxy q) + in \(RRq x) -> if x + x < qval then x else x - qval + +instance (Reflects q r, RealField r, Additive (RRq q r)) + => Reduce r (RRq q r) where + reduce = reduce' + +type instance LiftOf (RRq q r) = r + +instance (Reflects q r, Reduce r (RRq q r), Ord r, Ring r) + => Lift' (RRq q r) where + lift = decode' + +-- instance of Additive +instance (Reflects q r, RealField r, Ord r) => Additive.C (RRq q r) where + + {-# INLINABLE zero #-} + zero = RRq zero + + {-# INLINABLE (+) #-} + (+) = let qval = proxy value (Proxy::Proxy q) + in \ (RRq x) (RRq y) -> + let z = x + y + in RRq (if z >= qval then z - qval else z) + + {-# INLINABLE negate #-} + negate (RRq x) = reduce' $ negate x + +instance (ToInteger i, RealField r, Reflects q i, Reflects q r) + => Subgroup (ZqBasic q i) (RRq q r) where + fromSubgroup = reduce' . fromIntegral . lift + +-- CJP: restored manual Unbox instances, until we have a better way +-- (NewtypeDeriving or TH) + +newtype instance U.MVector s (RRq q r) = MV_RRq (U.MVector s r) +newtype instance U.Vector (RRq q r) = V_RRq (U.Vector r) + +-- Unbox, when underlying representation is +instance U.Unbox r => U.Unbox (RRq q r) + +{- purloined and tweaked from code in `vector` package that defines +types as unboxed -} +instance U.Unbox r => M.MVector U.MVector (RRq q r) where + basicLength (MV_RRq v) = M.basicLength v + basicUnsafeSlice z n (MV_RRq v) = MV_RRq $ M.basicUnsafeSlice z n v + basicOverlaps (MV_RRq v1) (MV_RRq v2) = M.basicOverlaps v1 v2 + basicInitialize (MV_RRq v) = M.basicInitialize v + basicUnsafeNew n = MV_RRq <$> M.basicUnsafeNew n + basicUnsafeReplicate n (RRq x) = MV_RRq <$> M.basicUnsafeReplicate n x + basicUnsafeRead (MV_RRq v) z = RRq <$> M.basicUnsafeRead v z + basicUnsafeWrite (MV_RRq v) z (RRq x) = M.basicUnsafeWrite v z x + basicClear (MV_RRq v) = M.basicClear v + basicSet (MV_RRq v) (RRq x) = M.basicSet v x + basicUnsafeCopy (MV_RRq v1) (MV_RRq v2) = M.basicUnsafeCopy v1 v2 + basicUnsafeMove (MV_RRq v1) (MV_RRq v2) = M.basicUnsafeMove v1 v2 + basicUnsafeGrow (MV_RRq v) n = MV_RRq <$> M.basicUnsafeGrow v n + +instance U.Unbox r => G.Vector U.Vector (RRq q r) where + basicUnsafeFreeze (MV_RRq v) = V_RRq <$> G.basicUnsafeFreeze v + basicUnsafeThaw (V_RRq v) = MV_RRq <$> G.basicUnsafeThaw v + basicLength (V_RRq v) = G.basicLength v + basicUnsafeSlice z n (V_RRq v) = V_RRq $ G.basicUnsafeSlice z n v + basicUnsafeIndexM (V_RRq v) z = RRq <$> G.basicUnsafeIndexM v z + basicUnsafeCopy (MV_RRq mv) (V_RRq v) = G.basicUnsafeCopy mv v + elemseq _ = seq diff --git a/Crypto/Lol/Types/Random.hs b/Crypto/Lol/Types/Random.hs --- a/Crypto/Lol/Types/Random.hs +++ b/Crypto/Lol/Types/Random.hs @@ -1,44 +1,35 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, PackageImports #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} --- | Defines a newtype wrapper for crypto-api's 'CryptoRandomGen', and a corresponding 'RandomGen' instance. --- 'CryptoRandomGen' generators can only be used to get 'ByteString's; the 'RandomGen' instance allows them --- to be used to generate any 'Random' type. Typical usage is with Control.Monad.Random's 'RandT' monad. +-- | Defines a newtype wrapper 'CryptoRand' for crypto-api's +-- 'CryptoRandomGen', and a corresponding 'RandomGen' wrapper +-- instance. These are needed because 'CryptoRandomGen' generators +-- can only be used to get 'ByteString's; the 'RandomGen' wrapper +-- instance allows them to be used to generate any 'Random' type. -module Crypto.Lol.Types.Random (CryptoRand) where +module Crypto.Lol.Types.Random (CryptoRand, evalCryptoRandIO) where -import "crypto-api" Crypto.Random -import Data.Binary.Get -import Data.ByteString hiding (pack) -import Data.ByteString.Lazy (pack) +import Control.Arrow +import Control.Monad.CryptoRandom +import Control.Monad.IO.Class +import Control.Monad.Random (RandT, evalRandT) +import Crypto.Random import System.Random +-- | Turns a 'CryptoRandomGen' @g@ into a standard 'RandomGen'. newtype CryptoRand g = CryptoRand g deriving (CryptoRandomGen) -intBytes = - let bits = intLog 2 $ (1 + (fromIntegral (maxBound :: Int)) - (fromIntegral (minBound :: Int)) :: Integer) - in if (bits `mod` 8) == 0 then bits `div` 8 else error "invalid Int bits in `intBytes`" - -bytesToInt :: ByteString -> Int -bytesToInt bs = case intBytes of - 4 -> fromIntegral $ runGet getWord32host $ pack $ unpack bs - 8 -> fromIntegral $ runGet getWord64host $ pack $ unpack bs - _ -> error "Unsupported Int size in `bytesToInt`" - --- | Yield @log_b(n)@ when it is a non-negative integer (otherwise --- error). -intLog :: (Integral i) => i -> i -> Int -intLog _ 1 = 0 --- correct because ceil (lg (x)) == ceil (log (ceil (x))) -intLog b n | (n `mod` b) == 0 = 1 + intLog b (n `div` b) - | otherwise = error "invalid arguments to intLog" +-- | Evaluate a 'RandT' computation using a cryptographic generator +-- @g@, seeded by system entropy. Note that the updated generator is +-- not returned. +evalCryptoRandIO :: (CryptoRandomGen g, MonadIO io) => RandT g io a -> io a +evalCryptoRandIO x = do + gen <- liftIO newGenIO -- uses system entropy + evalRandT x gen +-- "standard" RNG interface wrapper for a cryptographic RNG instance (CryptoRandomGen g) => RandomGen (CryptoRand g) where - next (CryptoRand g) = case genBytes intBytes g of - Right (bs, g') -> (bytesToInt bs, CryptoRand g') - Left err -> error $ "Next error: " ++ show err - - genRange _ = (minBound, maxBound) + -- use 'CRandom' instance for 'Int' + next (CryptoRand g) = either (error . show) (second CryptoRand) $ crandom g - split (CryptoRand g) = case splitGen g of - Right (g1, g2) -> (CryptoRand g1, CryptoRand g2) - Left err -> error $ "Split error: " ++ show err + split (CryptoRand g) = + either (error . show) (CryptoRand *** CryptoRand) $ splitGen g diff --git a/Crypto/Lol/Types/ZPP.hs b/Crypto/Lol/Types/ZPP.hs --- a/Crypto/Lol/Types/ZPP.hs +++ b/Crypto/Lol/Types/ZPP.hs @@ -6,7 +6,7 @@ ( ZPP(..) ) where -import Crypto.Lol.LatticePrelude +import Crypto.Lol.Prelude import Crypto.Lol.Types.FiniteField -- | Represents integers modulo a prime power. diff --git a/Crypto/Lol/Types/ZmStar.hs b/Crypto/Lol/Types/ZmStar.hs --- a/Crypto/Lol/Types/ZmStar.hs +++ b/Crypto/Lol/Types/ZmStar.hs @@ -1,7 +1,7 @@ {-# LANGUAGE ConstraintKinds, DataKinds, FlexibleContexts, - NoImplicitPrelude, PolyKinds, RebindableSyntax, - ScopedTypeVariables, TypeFamilies, TypeOperators, - UndecidableInstances #-} + MultiParamTypeClasses, NoImplicitPrelude, PolyKinds, + RebindableSyntax, ScopedTypeVariables, TypeFamilies, + TypeOperators, UndecidableInstances #-} -- | A collection of helper functions for working with @Z_m^*@ @@ -10,7 +10,7 @@ ) where import Crypto.Lol.Factored -import Crypto.Lol.LatticePrelude as LP hiding (null) +import Crypto.Lol.Prelude as LP hiding (null) import Crypto.Lol.Reflects import Crypto.Lol.Types.ZqBasic @@ -26,8 +26,8 @@ let mval = proxy value (Proxy::Proxy m) in if gcd p mval /= 1 then error "p and m not coprime" - else 1 + (length $ takeWhile (/= one) $ - tail $ iterate (* (fromIntegral p)) (one :: ZqBasic m Int)) + else 1 + length (takeWhile (/= one) $ + tail $ iterate (* fromIntegral p) (one :: ZqBasic m Int)) -- given p, returns the cosets of Z_m^* /

cosets :: forall zm . (Mod zm, ModRep zm ~ Int, Ord zm, Ring zm) diff --git a/Crypto/Lol/Types/ZqBasic.hs b/Crypto/Lol/Types/ZqBasic.hs --- a/Crypto/Lol/Types/ZqBasic.hs +++ b/Crypto/Lol/Types/ZqBasic.hs @@ -2,17 +2,22 @@ FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, NoImplicitPrelude, PolyKinds, RebindableSyntax, RoleAnnotations, ScopedTypeVariables, - StandaloneDeriving, TypeFamilies, UndecidableInstances #-} + TypeFamilies, UndecidableInstances #-} --- | An implementation of modular arithmetic, i.e., the ring Zq. +-- | An implementation of the quotient ring Zq = Z/qZ. +-- EAC: It may help GHC do specialization at higher levels of the library +-- if we "simplify" constraints in this module. For example, replace the +-- (Additive (ZqBasic q z)) constraint on the Reduce instance with +-- (Additive z) + module Crypto.Lol.Types.ZqBasic ( ZqBasic -- export the type, but not the constructor (for safety) ) where import Crypto.Lol.CRTrans import Crypto.Lol.Gadget -import Crypto.Lol.LatticePrelude as LP +import Crypto.Lol.Prelude as LP import Crypto.Lol.Reflects import Crypto.Lol.Types.FiniteField import Crypto.Lol.Types.ZPP @@ -49,7 +54,7 @@ -- | The ring @Z_q@ of integers modulo 'q', using underlying integer -- type 'z'. newtype ZqBasic q z = ZqB z - deriving (Eq, Ord, ZeroTestable.C, E.Elt, Show, NFData, Storable) + deriving (Eq, Ord, ZeroTestable.C, E.Elt, Show, NFData, Storable) -- the q argument, though phantom, matters for safety type role ZqBasic nominal representational @@ -58,25 +63,20 @@ --deriving instance (U.Unbox i) => M.MVector U.MVector (ZqBasic q i) --deriving instance (U.Unbox i) => U.Unbox (ZqBasic q i) --- convenience synonym for many instances -type ReflectsTI q z = (Reflects q z, ToInteger z) - {-# INLINABLE reduce' #-} -reduce' :: forall q z . (ReflectsTI q z) => z -> ZqBasic q z +reduce' :: forall q z . (Reflects q z, ToInteger z) => z -> ZqBasic q z reduce' = ZqB . (`mod` proxy value (Proxy::Proxy q)) -- puts value in range [-q/2, q/2) -decode' :: forall q z . (ReflectsTI q z) => ZqBasic q z -> z +decode' :: forall q z . (Reflects q z, ToInteger z) => ZqBasic q z -> z decode' = let qval = proxy value (Proxy::Proxy q) - in \(ZqB x) -> if 2 * x < qval - then x - else x - qval + in \(ZqB x) -> if 2 * x < qval then x else x - qval -instance (ReflectsTI q z, Enum z) => Enumerable (ZqBasic q z) where +instance (Reflects q z, ToInteger z, Enum z) => Enumerable (ZqBasic q z) where values = let qval :: z = proxy value (Proxy::Proxy q) in coerce [0..(qval-1)] -instance (ReflectsTI q z) => Mod (ZqBasic q z) where +instance (Reflects q z, ToInteger z) => Mod (ZqBasic q z) where type ModRep (ZqBasic q z) = z modulus = retag (value :: Tagged q z) @@ -92,79 +92,78 @@ modulusZPP = retag (ppPPow :: Tagged pp PP) liftZp = coerce -instance (ReflectsTI q z) => Reduce z (ZqBasic q z) where +instance (Reflects q z, ToInteger z) => Reduce z (ZqBasic q z) where reduce = reduce' -instance (Reflects q z, Ring (ZqBasic q z)) => Reduce Integer (ZqBasic q z) where +instance (Reflects q z, ToInteger z, Additive (ZqBasic q z)) => Reduce Integer (ZqBasic q z) where reduce = fromInteger type instance LiftOf (ZqBasic q z) = z -instance (ReflectsTI q z) => Lift' (ZqBasic q z) where +instance (Reflects q z, ToInteger z) => Lift' (ZqBasic q z) where lift = decode' -instance (ReflectsTI q z, ReflectsTI q' z, Ring z) +instance (Reflects q z, ToInteger z, Reflects q' z, Ring z) => Rescale (ZqBasic q z) (ZqBasic q' z) where - rescale = rescaleMod + rescale = rescaleMod -instance (Reflects p z, ReflectsTI q z, - Field (ZqBasic p z), Field (ZqBasic q z)) +instance (Reflects p z, Reflects q z, ToInteger z, Field (ZqBasic q z), Field (ZqBasic p z)) => Encode (ZqBasic p z) (ZqBasic q z) where - lsdToMSD = let pval :: z = proxy value (Proxy::Proxy p) - negqval :: z = negate $ proxy value (Proxy::Proxy q) - in (reduce' negqval, recip $ reduce' pval) + lsdToMSD = let pval :: z = proxy value (Proxy::Proxy p) + negqval :: z = negate $ proxy value (Proxy::Proxy q) + in (reduce' negqval, recip $ reduce' pval) -- | Yield a /principal/ @m@th root of unity @omega_m \in @Z_q^*@. -- The implementation requires @q@ to be prime. It works by finding a -- generator of @Z_q^*@ and raising it to the @(q-1)/m@ power. -- Therefore, outputs for different values of @m@ are consistent, -- i.e., @omega_{m'}^(m'/m) = omega_m@. - -principalRootUnity :: forall q z . (ReflectsTI q z, Enumerable (ZqBasic q z)) - => Int -> Maybe (Int -> ZqBasic q z) +principalRootUnity :: + forall m q z . (Reflects m Int, Reflects q z, ToInteger z, Enumerable (ZqBasic q z)) + => TaggedT m Maybe (Int -> ZqBasic q z) principalRootUnity = -- use Integers for all intermediate calcs - let qval = fromIntegral $ (proxy value (Proxy::Proxy q) :: z) - -- order of Zq^* (assuming q prime) - order = qval-1 - -- the primes dividing the order of Zq^* - pfactors = fst <$> factorise order - -- the powers we need to check - exps = div order <$> pfactors - -- whether an element is a generator of Zq^* - isGen x = (x^order == one) && all (\e -> x^e /= one) exps - -- for simplicity, require q to be prime - in if isPrime qval - then \m -> let (mq,mr) = order `divMod` fromIntegral m - in if mr == 0 - then let omega = head (filter isGen values) ^ mq - omegaPows = V.iterateN m (*omega) one - in Just $ (omegaPows V.!) . (`mod` m) - else Nothing - else const Nothing -- fail if q composite + let qval = fromIntegral (proxy value (Proxy::Proxy q) :: z) + mval = proxy value (Proxy::Proxy m) + -- order of Zq^* (assuming q prime) + order = qval-1 + -- the primes dividing the order of Zq^* + pfactors = fst <$> factorise order + -- the powers we need to check + exps = div order <$> pfactors + -- whether an element is a generator of Zq^* + isGen x = (x^order == one) && all (\e -> x^e /= one) exps + in tagT $ if isPrime qval -- for simplicity, require q to be prime + then let (mq,mr) = order `divMod` fromIntegral mval + in if mr == 0 + then let omega = head (filter isGen values) ^ mq + omegaPows = V.iterateN mval (*omega) one + in Just $ (omegaPows V.!) . (`mod` mval) + else Nothing + else Nothing -- fail if q composite +mhatInv :: forall m q z . (Reflects m Int, Reflects q z, ToInteger z, PID z) + => TaggedT m Maybe (ZqBasic q z) +mhatInv = let qval = proxy value (Proxy::Proxy q) + in peelT $ (fmap reduce' . (`modinv` qval) . fromIntegral) <$> + valueHat <$> (value :: Tagged m Int) -- instance of CRTrans -instance (ReflectsTI q z, PID z, Enumerable (ZqBasic q z)) - => CRTrans (ZqBasic q z) where +instance (Reflects q z, ToInteger z, PID z, Enumerable (ZqBasic q z)) + => CRTrans Maybe (ZqBasic q z) where - crtInfo = - --DT.trace ("ZqBasic.crtInfo: q = " ++ - -- show (proxy value (Proxy::Proxy q) :: z)) $ - let qval :: z = proxy value (Proxy::Proxy q) - in \m -> (,) <$> principalRootUnity m <*> - (reduce' <$> fromIntegral (valueHat m) `modinv` qval) + crtInfo = (,) <$> principalRootUnity <*> mhatInv --- instance of CRTEmbed -instance (ReflectsTI q z, Ring (ZqBasic q z)) => CRTEmbed (ZqBasic q z) where +-- | Embeds into complex numbers +instance (Reflects q z, ToInteger z, Ring (ZqBasic q z)) => CRTEmbed (ZqBasic q z) where type CRTExt (ZqBasic q z) = Complex Double toExt (ZqB x) = fromReal $ fromIntegral x fromExt x = reduce' $ NP.round $ real x -- instance of Additive -instance (ReflectsTI q z, Additive z) => Additive.C (ZqBasic q z) where +instance (Reflects q z, ToInteger z, Additive z) => Additive.C (ZqBasic q z) where {-# INLINABLE zero #-} zero = ZqB zero @@ -179,10 +178,10 @@ negate (ZqB x) = reduce' $ negate x -- instance of Ring -instance (ReflectsTI q z, Ring z) => Ring.C (ZqBasic q z) where +instance (Reflects q z, ToInteger z, Ring z) => Ring.C (ZqBasic q z) where {-# INLINABLE (*) #-} (ZqB x) * (ZqB y) = reduce' $ x * y - + {-# INLINABLE fromInteger #-} fromInteger = let qval = toInteger (proxy value (Proxy::Proxy q) :: z) @@ -190,7 +189,7 @@ in \x -> ZqB $ fromInteger $ x `mod` qval -- instance of Field -instance (ReflectsTI q z, PID z, Show z) => Field.C (ZqBasic q z) where +instance (Reflects q z, ToInteger z, PID z, Show z) => Field.C (ZqBasic q z) where {-# INLINABLE recip #-} recip = let qval = proxy value (Proxy::Proxy q) @@ -200,18 +199,18 @@ show x ++ "\t" ++ show qval) $ modinv x qval -- (canonical) instance of IntegralDomain, needed for Cyclotomics -instance (Field (ZqBasic q z)) => IntegralDomain.C (ZqBasic q z) where +instance (Reflects q z, ToInteger z, Field (ZqBasic q z)) => IntegralDomain.C (ZqBasic q z) where divMod a b = (a/b, zero) -- Gadget-related instances -instance (ReflectsTI q z, Additive z) => Gadget TrivGad (ZqBasic q z) where +instance (Reflects q z, ToInteger z, Additive z) => Gadget TrivGad (ZqBasic q z) where gadget = tag [one] -instance (ReflectsTI q z, Ring z) => Decompose TrivGad (ZqBasic q z) where +instance (Reflects q z, ToInteger z, Ring z) => Decompose TrivGad (ZqBasic q z) where type DecompOf (ZqBasic q z) = z decompose x = tag [lift x] -instance (ReflectsTI q z, Ring z) => Correct TrivGad (ZqBasic q z) where +instance (Reflects q z, ToInteger z, Ring z) => Correct TrivGad (ZqBasic q z) where correct a = case untag a of [b] -> (b, [zero]) _ -> error "Correct TrivGad: wrong length" @@ -220,21 +219,21 @@ gadlen :: (RealIntegral z) => z -> z -> Int gadlen _ q | isZero q = 0 -gadlen b q = 1 + (gadlen b $ q `div` b) +gadlen b q = 1 + gadlen b (q `div` b) -- | The base-@b@ gadget for modulus @q@, over integers (not mod -- anything). gadgetZ :: (RealIntegral z) => z -> z -> [z] gadgetZ b q = take (gadlen b q) $ iterate (*b) one -instance (ReflectsTI q z, RealIntegral z, Reflects b z) +instance (Reflects q z, ToInteger z, RealIntegral z, Reflects b z) => Gadget (BaseBGad b) (ZqBasic q z) where gadget = let qval = proxy value (Proxy :: Proxy q) bval = proxy value (Proxy :: Proxy b) in tag $ reduce' <$> gadgetZ bval qval -instance (ReflectsTI q z, Ring z, ZeroTestable z, Reflects b z) +instance (Reflects q z, ToInteger z, Ring z, ZeroTestable z, Reflects b z) => Decompose (BaseBGad b) (ZqBasic q z) where type DecompOf (ZqBasic q z) = z decompose = let qval = proxy value (Proxy :: Proxy q) @@ -244,7 +243,7 @@ in tag . decomp radices . lift -- | Yield the error vector for a noisy multiple of the gadget (all --- over the integers). +-- over the integers). correctZ :: forall z . (RealIntegral z) => z -- ^ modulus @q@ -> z -- ^ base @b@ @@ -254,7 +253,7 @@ let gadZ = gadgetZ b q k = length gadZ gadlast = last gadZ - in \v -> + in \v -> if length v /= k then error $ "correctZ: wrong length: was " ++ show (length v) ++", expected " ++ show k else let (w, x) = barBtRnd (q `div` b) v @@ -266,7 +265,7 @@ -- | Yield @w = round(\bar{B}^t \cdot v / q)@, along with the inner -- product of @w@ with the top row of @q \bar{D}@. barBtRnd :: z -> [z] -> ([z], z) - barBtRnd _ (_:[]) = ([], zero) + barBtRnd _ [_] = ([], zero) barBtRnd q' (v1:vs@(v2:_)) = let quo = fst $ divModCent (b*v1-v2) q in (quo:) *** (quo*q' +) $ barBtRnd (q' `div` b) vs @@ -282,7 +281,7 @@ subLast [v0] [v'0] = let y = v0-v'0 in ([y], y) subLast (v0:vs) (v'0:v's) = first ((v0-v'0):) $ subLast vs v's -instance (ReflectsTI q z, Ring z, Reflects b z) +instance (Reflects q z, ToInteger z, Ring z, Reflects b z) => Correct (BaseBGad b) (ZqBasic q z) where correct = @@ -294,7 +293,7 @@ in (head v - reduce (head es), es) -- instance of Random -instance (ReflectsTI q z, Random z) => Random (ZqBasic q z) where +instance (Reflects q z, ToInteger z, Random z) => Random (ZqBasic q z) where random = let high = proxy value (Proxy::Proxy q) - 1 in \g -> let (x,g') = randomR (0,high) g in (ZqB x, g') @@ -302,7 +301,7 @@ randomR _ = error "randomR non-sensical for Zq types" -- instance of Arbitrary -instance (ReflectsTI q z, Random z) => Arbitrary (ZqBasic q z) where +instance (Reflects q z, ToInteger z, Random z) => Arbitrary (ZqBasic q z) where arbitrary = let qval :: z = proxy value (Proxy::Proxy q) in fromIntegral <$> choose (0, qval-1) diff --git a/Crypto/Proto/RLWE.hs b/Crypto/Proto/RLWE.hs new file mode 100644 --- /dev/null +++ b/Crypto/Proto/RLWE.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE BangPatterns, DeriveDataTypeable, DeriveGeneric, FlexibleInstances, MultiParamTypeClasses #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +module Crypto.Proto.RLWE (protoInfo, fileDescriptorProto) where +import Prelude ((+), (/)) +import qualified Prelude as Prelude' +import qualified Data.Typeable as Prelude' +import qualified GHC.Generics as Prelude' +import qualified Data.Data as Prelude' +import qualified Text.ProtocolBuffers.Header as P' +import Text.DescriptorProtos.FileDescriptorProto (FileDescriptorProto) +import Text.ProtocolBuffers.Reflections (ProtoInfo) +import qualified Text.ProtocolBuffers.WireMessage as P' (wireGet,getFromBS) + +protoInfo :: ProtoInfo +protoInfo + = Prelude'.read + "ProtoInfo {protoMod = ProtoName {protobufName = FIName \".RLWE\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [], baseName = MName \"RLWE\"}, protoFilePath = [\"Crypto\",\"Proto\",\"RLWE.hs\"], protoSource = \"RLWE.proto\", extensionKeys = fromList [], messages = [DescriptorInfo {descName = ProtoName {protobufName = FIName \".RLWE.SampleCont\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"RLWE\"], baseName = MName \"SampleCont\"}, descFilePath = [\"Crypto\",\"Proto\",\"RLWE\",\"SampleCont.hs\"], isGroup = False, fields = fromList [FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".RLWE.SampleCont.a\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"RLWE\",MName \"SampleCont\"], baseName' = FName \"a\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 1}, wireTag = WireTag {getWireTag = 10}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 11}, typeName = Just (ProtoName {protobufName = FIName \".RLWE.Rq\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"RLWE\"], baseName = MName \"Rq\"}), hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".RLWE.SampleCont.b\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"RLWE\",MName \"SampleCont\"], baseName' = FName \"b\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 2}, wireTag = WireTag {getWireTag = 18}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 11}, typeName = Just (ProtoName {protobufName = FIName \".RLWE.Kq\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"RLWE\"], baseName = MName \"Kq\"}), hsRawDefault = Nothing, hsDefault = Nothing}], descOneofs = fromList [], keys = fromList [], extRanges = [], knownKeys = fromList [], storeUnknown = False, lazyFields = False, makeLenses = False},DescriptorInfo {descName = ProtoName {protobufName = FIName \".RLWE.SampleDisc\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"RLWE\"], baseName = MName \"SampleDisc\"}, descFilePath = [\"Crypto\",\"Proto\",\"RLWE\",\"SampleDisc.hs\"], isGroup = False, fields = fromList [FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".RLWE.SampleDisc.a\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"RLWE\",MName \"SampleDisc\"], baseName' = FName \"a\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 1}, wireTag = WireTag {getWireTag = 10}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 11}, typeName = Just (ProtoName {protobufName = FIName \".RLWE.Rq\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"RLWE\"], baseName = MName \"Rq\"}), hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".RLWE.SampleDisc.b\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"RLWE\",MName \"SampleDisc\"], baseName' = FName \"b\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 2}, wireTag = WireTag {getWireTag = 18}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 11}, typeName = Just (ProtoName {protobufName = FIName \".RLWE.Rq\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"RLWE\"], baseName = MName \"Rq\"}), hsRawDefault = Nothing, hsDefault = Nothing}], descOneofs = fromList [], keys = fromList [], extRanges = [], knownKeys = fromList [], storeUnknown = False, lazyFields = False, makeLenses = False},DescriptorInfo {descName = ProtoName {protobufName = FIName \".RLWE.SampleRLWR\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"RLWE\"], baseName = MName \"SampleRLWR\"}, descFilePath = [\"Crypto\",\"Proto\",\"RLWE\",\"SampleRLWR.hs\"], isGroup = False, fields = fromList [FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".RLWE.SampleRLWR.a\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"RLWE\",MName \"SampleRLWR\"], baseName' = FName \"a\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 1}, wireTag = WireTag {getWireTag = 10}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 11}, typeName = Just (ProtoName {protobufName = FIName \".RLWE.Rq\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"RLWE\"], baseName = MName \"Rq\"}), hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".RLWE.SampleRLWR.b\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"RLWE\",MName \"SampleRLWR\"], baseName' = FName \"b\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 2}, wireTag = WireTag {getWireTag = 18}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 11}, typeName = Just (ProtoName {protobufName = FIName \".RLWE.Rq\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"RLWE\"], baseName = MName \"Rq\"}), hsRawDefault = Nothing, hsDefault = Nothing}], descOneofs = fromList [], keys = fromList [], extRanges = [], knownKeys = fromList [], storeUnknown = False, lazyFields = False, makeLenses = False},DescriptorInfo {descName = ProtoName {protobufName = FIName \".RLWE.Rq\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"RLWE\"], baseName = MName \"Rq\"}, descFilePath = [\"Crypto\",\"Proto\",\"RLWE\",\"Rq.hs\"], isGroup = False, fields = fromList [FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".RLWE.Rq.m\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"RLWE\",MName \"Rq\"], baseName' = FName \"m\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 1}, wireTag = WireTag {getWireTag = 8}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 13}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".RLWE.Rq.q\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"RLWE\",MName \"Rq\"], baseName' = FName \"q\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 2}, wireTag = WireTag {getWireTag = 16}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 4}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".RLWE.Rq.xs\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"RLWE\",MName \"Rq\"], baseName' = FName \"xs\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 3}, wireTag = WireTag {getWireTag = 24}, packedTag = Just (WireTag {getWireTag = 24},WireTag {getWireTag = 26}), wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = True, mightPack = True, typeCode = FieldType {getFieldType = 18}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing}], descOneofs = fromList [], keys = fromList [], extRanges = [], knownKeys = fromList [], storeUnknown = False, lazyFields = False, makeLenses = False},DescriptorInfo {descName = ProtoName {protobufName = FIName \".RLWE.Kq\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"RLWE\"], baseName = MName \"Kq\"}, descFilePath = [\"Crypto\",\"Proto\",\"RLWE\",\"Kq.hs\"], isGroup = False, fields = fromList [FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".RLWE.Kq.m\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"RLWE\",MName \"Kq\"], baseName' = FName \"m\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 1}, wireTag = WireTag {getWireTag = 8}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 13}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".RLWE.Kq.q\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"RLWE\",MName \"Kq\"], baseName' = FName \"q\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 2}, wireTag = WireTag {getWireTag = 17}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 1}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".RLWE.Kq.xs\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"RLWE\",MName \"Kq\"], baseName' = FName \"xs\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 3}, wireTag = WireTag {getWireTag = 25}, packedTag = Just (WireTag {getWireTag = 25},WireTag {getWireTag = 26}), wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = True, mightPack = True, typeCode = FieldType {getFieldType = 1}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing}], descOneofs = fromList [], keys = fromList [], extRanges = [], knownKeys = fromList [], storeUnknown = False, lazyFields = False, makeLenses = False}], enums = [], oneofs = [], knownKeyMap = fromList []}" + +fileDescriptorProto :: FileDescriptorProto +fileDescriptorProto + = P'.getFromBS (P'.wireGet 11) + (P'.pack + "\132\STX\n\nRLWE.proto\"6\n\nSampleCont\DC2\DC3\n\SOHa\CAN\SOH \STX(\v2\b.RLWE.Rq\DC2\DC3\n\SOHb\CAN\STX \STX(\v2\b.RLWE.Kq\"6\n\nSampleDisc\DC2\DC3\n\SOHa\CAN\SOH \STX(\v2\b.RLWE.Rq\DC2\DC3\n\SOHb\CAN\STX \STX(\v2\b.RLWE.Rq\"6\n\nSampleRLWR\DC2\DC3\n\SOHa\CAN\SOH \STX(\v2\b.RLWE.Rq\DC2\DC3\n\SOHb\CAN\STX \STX(\v2\b.RLWE.Rq\"&\n\STXRq\DC2\t\n\SOHm\CAN\SOH \STX(\r\DC2\t\n\SOHq\CAN\STX \STX(\EOT\DC2\n\n\STXxs\CAN\ETX \ETX(\DC2\"&\n\STXKq\DC2\t\n\SOHm\CAN\SOH \STX(\r\DC2\t\n\SOHq\CAN\STX \STX(\SOH\DC2\n\n\STXxs\CAN\ETX \ETX(\SOH") diff --git a/Crypto/Proto/RLWE/Kq.hs b/Crypto/Proto/RLWE/Kq.hs new file mode 100644 --- /dev/null +++ b/Crypto/Proto/RLWE/Kq.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE BangPatterns, DeriveDataTypeable, DeriveGeneric, FlexibleInstances, MultiParamTypeClasses #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +module Crypto.Proto.RLWE.Kq (Kq(..)) where +import Prelude ((+), (/)) +import qualified Prelude as Prelude' +import qualified Data.Typeable as Prelude' +import qualified GHC.Generics as Prelude' +import qualified Data.Data as Prelude' +import qualified Text.ProtocolBuffers.Header as P' + +data Kq = Kq{m :: !(P'.Word32), q :: !(P'.Double), xs :: !(P'.Seq P'.Double)} + deriving (Prelude'.Show, Prelude'.Eq, Prelude'.Ord, Prelude'.Typeable, Prelude'.Data, Prelude'.Generic) + +instance P'.Mergeable Kq where + mergeAppend (Kq x'1 x'2 x'3) (Kq y'1 y'2 y'3) = Kq (P'.mergeAppend x'1 y'1) (P'.mergeAppend x'2 y'2) (P'.mergeAppend x'3 y'3) + +instance P'.Default Kq where + defaultValue = Kq P'.defaultValue P'.defaultValue P'.defaultValue + +instance P'.Wire Kq where + wireSize ft' self'@(Kq x'1 x'2 x'3) + = case ft' of + 10 -> calc'Size + 11 -> P'.prependMessageSize calc'Size + _ -> P'.wireSizeErr ft' self' + where + calc'Size = (P'.wireSizeReq 1 13 x'1 + P'.wireSizeReq 1 1 x'2 + P'.wireSizeRep 1 1 x'3) + wirePut ft' self'@(Kq x'1 x'2 x'3) + = case ft' of + 10 -> put'Fields + 11 -> do + P'.putSize (P'.wireSize 10 self') + put'Fields + _ -> P'.wirePutErr ft' self' + where + put'Fields + = do + P'.wirePutReq 8 13 x'1 + P'.wirePutReq 17 1 x'2 + P'.wirePutRep 25 1 x'3 + wireGet ft' + = case ft' of + 10 -> P'.getBareMessageWith update'Self + 11 -> P'.getMessageWith update'Self + _ -> P'.wireGetErr ft' + where + update'Self wire'Tag old'Self + = case wire'Tag of + 8 -> Prelude'.fmap (\ !new'Field -> old'Self{m = new'Field}) (P'.wireGet 13) + 17 -> Prelude'.fmap (\ !new'Field -> old'Self{q = new'Field}) (P'.wireGet 1) + 25 -> Prelude'.fmap (\ !new'Field -> old'Self{xs = P'.append (xs old'Self) new'Field}) (P'.wireGet 1) + 26 -> Prelude'.fmap (\ !new'Field -> old'Self{xs = P'.mergeAppend (xs old'Self) new'Field}) (P'.wireGetPacked 1) + _ -> let (field'Number, wire'Type) = P'.splitWireTag wire'Tag in P'.unknown field'Number wire'Type old'Self + +instance P'.MessageAPI msg' (msg' -> Kq) Kq where + getVal m' f' = f' m' + +instance P'.GPB Kq + +instance P'.ReflectDescriptor Kq where + getMessageInfo _ = P'.GetMessageInfo (P'.fromDistinctAscList [8, 17]) (P'.fromDistinctAscList [8, 17, 25, 26]) + reflectDescriptorInfo _ + = Prelude'.read + "DescriptorInfo {descName = ProtoName {protobufName = FIName \".RLWE.Kq\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"RLWE\"], baseName = MName \"Kq\"}, descFilePath = [\"Crypto\",\"Proto\",\"RLWE\",\"Kq.hs\"], isGroup = False, fields = fromList [FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".RLWE.Kq.m\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"RLWE\",MName \"Kq\"], baseName' = FName \"m\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 1}, wireTag = WireTag {getWireTag = 8}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 13}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".RLWE.Kq.q\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"RLWE\",MName \"Kq\"], baseName' = FName \"q\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 2}, wireTag = WireTag {getWireTag = 17}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 1}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".RLWE.Kq.xs\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"RLWE\",MName \"Kq\"], baseName' = FName \"xs\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 3}, wireTag = WireTag {getWireTag = 25}, packedTag = Just (WireTag {getWireTag = 25},WireTag {getWireTag = 26}), wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = True, mightPack = True, typeCode = FieldType {getFieldType = 1}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing}], descOneofs = fromList [], keys = fromList [], extRanges = [], knownKeys = fromList [], storeUnknown = False, lazyFields = False, makeLenses = False}" + +instance P'.TextType Kq where + tellT = P'.tellSubMessage + getT = P'.getSubMessage + +instance P'.TextMsg Kq where + textPut msg + = do + P'.tellT "m" (m msg) + P'.tellT "q" (q msg) + P'.tellT "xs" (xs msg) + textGet + = do + mods <- P'.sepEndBy (P'.choice [parse'm, parse'q, parse'xs]) P'.spaces + Prelude'.return (Prelude'.foldl (\ v f -> f v) P'.defaultValue mods) + where + parse'm + = P'.try + (do + v <- P'.getT "m" + Prelude'.return (\ o -> o{m = v})) + parse'q + = P'.try + (do + v <- P'.getT "q" + Prelude'.return (\ o -> o{q = v})) + parse'xs + = P'.try + (do + v <- P'.getT "xs" + Prelude'.return (\ o -> o{xs = P'.append (xs o) v})) diff --git a/Crypto/Proto/RLWE/Rq.hs b/Crypto/Proto/RLWE/Rq.hs new file mode 100644 --- /dev/null +++ b/Crypto/Proto/RLWE/Rq.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE BangPatterns, DeriveDataTypeable, DeriveGeneric, FlexibleInstances, MultiParamTypeClasses #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +module Crypto.Proto.RLWE.Rq (Rq(..)) where +import Prelude ((+), (/)) +import qualified Prelude as Prelude' +import qualified Data.Typeable as Prelude' +import qualified GHC.Generics as Prelude' +import qualified Data.Data as Prelude' +import qualified Text.ProtocolBuffers.Header as P' + +data Rq = Rq{m :: !(P'.Word32), q :: !(P'.Word64), xs :: !(P'.Seq P'.Int64)} + deriving (Prelude'.Show, Prelude'.Eq, Prelude'.Ord, Prelude'.Typeable, Prelude'.Data, Prelude'.Generic) + +instance P'.Mergeable Rq where + mergeAppend (Rq x'1 x'2 x'3) (Rq y'1 y'2 y'3) = Rq (P'.mergeAppend x'1 y'1) (P'.mergeAppend x'2 y'2) (P'.mergeAppend x'3 y'3) + +instance P'.Default Rq where + defaultValue = Rq P'.defaultValue P'.defaultValue P'.defaultValue + +instance P'.Wire Rq where + wireSize ft' self'@(Rq x'1 x'2 x'3) + = case ft' of + 10 -> calc'Size + 11 -> P'.prependMessageSize calc'Size + _ -> P'.wireSizeErr ft' self' + where + calc'Size = (P'.wireSizeReq 1 13 x'1 + P'.wireSizeReq 1 4 x'2 + P'.wireSizeRep 1 18 x'3) + wirePut ft' self'@(Rq x'1 x'2 x'3) + = case ft' of + 10 -> put'Fields + 11 -> do + P'.putSize (P'.wireSize 10 self') + put'Fields + _ -> P'.wirePutErr ft' self' + where + put'Fields + = do + P'.wirePutReq 8 13 x'1 + P'.wirePutReq 16 4 x'2 + P'.wirePutRep 24 18 x'3 + wireGet ft' + = case ft' of + 10 -> P'.getBareMessageWith update'Self + 11 -> P'.getMessageWith update'Self + _ -> P'.wireGetErr ft' + where + update'Self wire'Tag old'Self + = case wire'Tag of + 8 -> Prelude'.fmap (\ !new'Field -> old'Self{m = new'Field}) (P'.wireGet 13) + 16 -> Prelude'.fmap (\ !new'Field -> old'Self{q = new'Field}) (P'.wireGet 4) + 24 -> Prelude'.fmap (\ !new'Field -> old'Self{xs = P'.append (xs old'Self) new'Field}) (P'.wireGet 18) + 26 -> Prelude'.fmap (\ !new'Field -> old'Self{xs = P'.mergeAppend (xs old'Self) new'Field}) (P'.wireGetPacked 18) + _ -> let (field'Number, wire'Type) = P'.splitWireTag wire'Tag in P'.unknown field'Number wire'Type old'Self + +instance P'.MessageAPI msg' (msg' -> Rq) Rq where + getVal m' f' = f' m' + +instance P'.GPB Rq + +instance P'.ReflectDescriptor Rq where + getMessageInfo _ = P'.GetMessageInfo (P'.fromDistinctAscList [8, 16]) (P'.fromDistinctAscList [8, 16, 24, 26]) + reflectDescriptorInfo _ + = Prelude'.read + "DescriptorInfo {descName = ProtoName {protobufName = FIName \".RLWE.Rq\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"RLWE\"], baseName = MName \"Rq\"}, descFilePath = [\"Crypto\",\"Proto\",\"RLWE\",\"Rq.hs\"], isGroup = False, fields = fromList [FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".RLWE.Rq.m\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"RLWE\",MName \"Rq\"], baseName' = FName \"m\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 1}, wireTag = WireTag {getWireTag = 8}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 13}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".RLWE.Rq.q\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"RLWE\",MName \"Rq\"], baseName' = FName \"q\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 2}, wireTag = WireTag {getWireTag = 16}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 4}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".RLWE.Rq.xs\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"RLWE\",MName \"Rq\"], baseName' = FName \"xs\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 3}, wireTag = WireTag {getWireTag = 24}, packedTag = Just (WireTag {getWireTag = 24},WireTag {getWireTag = 26}), wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = True, mightPack = True, typeCode = FieldType {getFieldType = 18}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing}], descOneofs = fromList [], keys = fromList [], extRanges = [], knownKeys = fromList [], storeUnknown = False, lazyFields = False, makeLenses = False}" + +instance P'.TextType Rq where + tellT = P'.tellSubMessage + getT = P'.getSubMessage + +instance P'.TextMsg Rq where + textPut msg + = do + P'.tellT "m" (m msg) + P'.tellT "q" (q msg) + P'.tellT "xs" (xs msg) + textGet + = do + mods <- P'.sepEndBy (P'.choice [parse'm, parse'q, parse'xs]) P'.spaces + Prelude'.return (Prelude'.foldl (\ v f -> f v) P'.defaultValue mods) + where + parse'm + = P'.try + (do + v <- P'.getT "m" + Prelude'.return (\ o -> o{m = v})) + parse'q + = P'.try + (do + v <- P'.getT "q" + Prelude'.return (\ o -> o{q = v})) + parse'xs + = P'.try + (do + v <- P'.getT "xs" + Prelude'.return (\ o -> o{xs = P'.append (xs o) v})) diff --git a/Crypto/Proto/RLWE/SampleCont.hs b/Crypto/Proto/RLWE/SampleCont.hs new file mode 100644 --- /dev/null +++ b/Crypto/Proto/RLWE/SampleCont.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE BangPatterns, DeriveDataTypeable, DeriveGeneric, FlexibleInstances, MultiParamTypeClasses #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +module Crypto.Proto.RLWE.SampleCont (SampleCont(..)) where +import Prelude ((+), (/)) +import qualified Prelude as Prelude' +import qualified Data.Typeable as Prelude' +import qualified GHC.Generics as Prelude' +import qualified Data.Data as Prelude' +import qualified Text.ProtocolBuffers.Header as P' +import qualified Crypto.Proto.RLWE.Kq as RLWE (Kq) +import qualified Crypto.Proto.RLWE.Rq as RLWE (Rq) + +data SampleCont = SampleCont{a :: !(RLWE.Rq), b :: !(RLWE.Kq)} + deriving (Prelude'.Show, Prelude'.Eq, Prelude'.Ord, Prelude'.Typeable, Prelude'.Data, Prelude'.Generic) + +instance P'.Mergeable SampleCont where + mergeAppend (SampleCont x'1 x'2) (SampleCont y'1 y'2) = SampleCont (P'.mergeAppend x'1 y'1) (P'.mergeAppend x'2 y'2) + +instance P'.Default SampleCont where + defaultValue = SampleCont P'.defaultValue P'.defaultValue + +instance P'.Wire SampleCont where + wireSize ft' self'@(SampleCont x'1 x'2) + = case ft' of + 10 -> calc'Size + 11 -> P'.prependMessageSize calc'Size + _ -> P'.wireSizeErr ft' self' + where + calc'Size = (P'.wireSizeReq 1 11 x'1 + P'.wireSizeReq 1 11 x'2) + wirePut ft' self'@(SampleCont x'1 x'2) + = case ft' of + 10 -> put'Fields + 11 -> do + P'.putSize (P'.wireSize 10 self') + put'Fields + _ -> P'.wirePutErr ft' self' + where + put'Fields + = do + P'.wirePutReq 10 11 x'1 + P'.wirePutReq 18 11 x'2 + wireGet ft' + = case ft' of + 10 -> P'.getBareMessageWith update'Self + 11 -> P'.getMessageWith update'Self + _ -> P'.wireGetErr ft' + where + update'Self wire'Tag old'Self + = case wire'Tag of + 10 -> Prelude'.fmap (\ !new'Field -> old'Self{a = P'.mergeAppend (a old'Self) (new'Field)}) (P'.wireGet 11) + 18 -> Prelude'.fmap (\ !new'Field -> old'Self{b = P'.mergeAppend (b old'Self) (new'Field)}) (P'.wireGet 11) + _ -> let (field'Number, wire'Type) = P'.splitWireTag wire'Tag in P'.unknown field'Number wire'Type old'Self + +instance P'.MessageAPI msg' (msg' -> SampleCont) SampleCont where + getVal m' f' = f' m' + +instance P'.GPB SampleCont + +instance P'.ReflectDescriptor SampleCont where + getMessageInfo _ = P'.GetMessageInfo (P'.fromDistinctAscList [10, 18]) (P'.fromDistinctAscList [10, 18]) + reflectDescriptorInfo _ + = Prelude'.read + "DescriptorInfo {descName = ProtoName {protobufName = FIName \".RLWE.SampleCont\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"RLWE\"], baseName = MName \"SampleCont\"}, descFilePath = [\"Crypto\",\"Proto\",\"RLWE\",\"SampleCont.hs\"], isGroup = False, fields = fromList [FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".RLWE.SampleCont.a\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"RLWE\",MName \"SampleCont\"], baseName' = FName \"a\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 1}, wireTag = WireTag {getWireTag = 10}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 11}, typeName = Just (ProtoName {protobufName = FIName \".RLWE.Rq\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"RLWE\"], baseName = MName \"Rq\"}), hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".RLWE.SampleCont.b\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"RLWE\",MName \"SampleCont\"], baseName' = FName \"b\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 2}, wireTag = WireTag {getWireTag = 18}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 11}, typeName = Just (ProtoName {protobufName = FIName \".RLWE.Kq\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"RLWE\"], baseName = MName \"Kq\"}), hsRawDefault = Nothing, hsDefault = Nothing}], descOneofs = fromList [], keys = fromList [], extRanges = [], knownKeys = fromList [], storeUnknown = False, lazyFields = False, makeLenses = False}" + +instance P'.TextType SampleCont where + tellT = P'.tellSubMessage + getT = P'.getSubMessage + +instance P'.TextMsg SampleCont where + textPut msg + = do + P'.tellT "a" (a msg) + P'.tellT "b" (b msg) + textGet + = do + mods <- P'.sepEndBy (P'.choice [parse'a, parse'b]) P'.spaces + Prelude'.return (Prelude'.foldl (\ v f -> f v) P'.defaultValue mods) + where + parse'a + = P'.try + (do + v <- P'.getT "a" + Prelude'.return (\ o -> o{a = v})) + parse'b + = P'.try + (do + v <- P'.getT "b" + Prelude'.return (\ o -> o{b = v})) diff --git a/Crypto/Proto/RLWE/SampleDisc.hs b/Crypto/Proto/RLWE/SampleDisc.hs new file mode 100644 --- /dev/null +++ b/Crypto/Proto/RLWE/SampleDisc.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE BangPatterns, DeriveDataTypeable, DeriveGeneric, FlexibleInstances, MultiParamTypeClasses #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +module Crypto.Proto.RLWE.SampleDisc (SampleDisc(..)) where +import Prelude ((+), (/)) +import qualified Prelude as Prelude' +import qualified Data.Typeable as Prelude' +import qualified GHC.Generics as Prelude' +import qualified Data.Data as Prelude' +import qualified Text.ProtocolBuffers.Header as P' +import qualified Crypto.Proto.RLWE.Rq as RLWE (Rq) + +data SampleDisc = SampleDisc{a :: !(RLWE.Rq), b :: !(RLWE.Rq)} + deriving (Prelude'.Show, Prelude'.Eq, Prelude'.Ord, Prelude'.Typeable, Prelude'.Data, Prelude'.Generic) + +instance P'.Mergeable SampleDisc where + mergeAppend (SampleDisc x'1 x'2) (SampleDisc y'1 y'2) = SampleDisc (P'.mergeAppend x'1 y'1) (P'.mergeAppend x'2 y'2) + +instance P'.Default SampleDisc where + defaultValue = SampleDisc P'.defaultValue P'.defaultValue + +instance P'.Wire SampleDisc where + wireSize ft' self'@(SampleDisc x'1 x'2) + = case ft' of + 10 -> calc'Size + 11 -> P'.prependMessageSize calc'Size + _ -> P'.wireSizeErr ft' self' + where + calc'Size = (P'.wireSizeReq 1 11 x'1 + P'.wireSizeReq 1 11 x'2) + wirePut ft' self'@(SampleDisc x'1 x'2) + = case ft' of + 10 -> put'Fields + 11 -> do + P'.putSize (P'.wireSize 10 self') + put'Fields + _ -> P'.wirePutErr ft' self' + where + put'Fields + = do + P'.wirePutReq 10 11 x'1 + P'.wirePutReq 18 11 x'2 + wireGet ft' + = case ft' of + 10 -> P'.getBareMessageWith update'Self + 11 -> P'.getMessageWith update'Self + _ -> P'.wireGetErr ft' + where + update'Self wire'Tag old'Self + = case wire'Tag of + 10 -> Prelude'.fmap (\ !new'Field -> old'Self{a = P'.mergeAppend (a old'Self) (new'Field)}) (P'.wireGet 11) + 18 -> Prelude'.fmap (\ !new'Field -> old'Self{b = P'.mergeAppend (b old'Self) (new'Field)}) (P'.wireGet 11) + _ -> let (field'Number, wire'Type) = P'.splitWireTag wire'Tag in P'.unknown field'Number wire'Type old'Self + +instance P'.MessageAPI msg' (msg' -> SampleDisc) SampleDisc where + getVal m' f' = f' m' + +instance P'.GPB SampleDisc + +instance P'.ReflectDescriptor SampleDisc where + getMessageInfo _ = P'.GetMessageInfo (P'.fromDistinctAscList [10, 18]) (P'.fromDistinctAscList [10, 18]) + reflectDescriptorInfo _ + = Prelude'.read + "DescriptorInfo {descName = ProtoName {protobufName = FIName \".RLWE.SampleDisc\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"RLWE\"], baseName = MName \"SampleDisc\"}, descFilePath = [\"Crypto\",\"Proto\",\"RLWE\",\"SampleDisc.hs\"], isGroup = False, fields = fromList [FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".RLWE.SampleDisc.a\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"RLWE\",MName \"SampleDisc\"], baseName' = FName \"a\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 1}, wireTag = WireTag {getWireTag = 10}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 11}, typeName = Just (ProtoName {protobufName = FIName \".RLWE.Rq\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"RLWE\"], baseName = MName \"Rq\"}), hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".RLWE.SampleDisc.b\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"RLWE\",MName \"SampleDisc\"], baseName' = FName \"b\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 2}, wireTag = WireTag {getWireTag = 18}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 11}, typeName = Just (ProtoName {protobufName = FIName \".RLWE.Rq\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"RLWE\"], baseName = MName \"Rq\"}), hsRawDefault = Nothing, hsDefault = Nothing}], descOneofs = fromList [], keys = fromList [], extRanges = [], knownKeys = fromList [], storeUnknown = False, lazyFields = False, makeLenses = False}" + +instance P'.TextType SampleDisc where + tellT = P'.tellSubMessage + getT = P'.getSubMessage + +instance P'.TextMsg SampleDisc where + textPut msg + = do + P'.tellT "a" (a msg) + P'.tellT "b" (b msg) + textGet + = do + mods <- P'.sepEndBy (P'.choice [parse'a, parse'b]) P'.spaces + Prelude'.return (Prelude'.foldl (\ v f -> f v) P'.defaultValue mods) + where + parse'a + = P'.try + (do + v <- P'.getT "a" + Prelude'.return (\ o -> o{a = v})) + parse'b + = P'.try + (do + v <- P'.getT "b" + Prelude'.return (\ o -> o{b = v})) diff --git a/Crypto/Proto/RLWE/SampleRLWR.hs b/Crypto/Proto/RLWE/SampleRLWR.hs new file mode 100644 --- /dev/null +++ b/Crypto/Proto/RLWE/SampleRLWR.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE BangPatterns, DeriveDataTypeable, DeriveGeneric, FlexibleInstances, MultiParamTypeClasses #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +module Crypto.Proto.RLWE.SampleRLWR (SampleRLWR(..)) where +import Prelude ((+), (/)) +import qualified Prelude as Prelude' +import qualified Data.Typeable as Prelude' +import qualified GHC.Generics as Prelude' +import qualified Data.Data as Prelude' +import qualified Text.ProtocolBuffers.Header as P' +import qualified Crypto.Proto.RLWE.Rq as RLWE (Rq) + +data SampleRLWR = SampleRLWR{a :: !(RLWE.Rq), b :: !(RLWE.Rq)} + deriving (Prelude'.Show, Prelude'.Eq, Prelude'.Ord, Prelude'.Typeable, Prelude'.Data, Prelude'.Generic) + +instance P'.Mergeable SampleRLWR where + mergeAppend (SampleRLWR x'1 x'2) (SampleRLWR y'1 y'2) = SampleRLWR (P'.mergeAppend x'1 y'1) (P'.mergeAppend x'2 y'2) + +instance P'.Default SampleRLWR where + defaultValue = SampleRLWR P'.defaultValue P'.defaultValue + +instance P'.Wire SampleRLWR where + wireSize ft' self'@(SampleRLWR x'1 x'2) + = case ft' of + 10 -> calc'Size + 11 -> P'.prependMessageSize calc'Size + _ -> P'.wireSizeErr ft' self' + where + calc'Size = (P'.wireSizeReq 1 11 x'1 + P'.wireSizeReq 1 11 x'2) + wirePut ft' self'@(SampleRLWR x'1 x'2) + = case ft' of + 10 -> put'Fields + 11 -> do + P'.putSize (P'.wireSize 10 self') + put'Fields + _ -> P'.wirePutErr ft' self' + where + put'Fields + = do + P'.wirePutReq 10 11 x'1 + P'.wirePutReq 18 11 x'2 + wireGet ft' + = case ft' of + 10 -> P'.getBareMessageWith update'Self + 11 -> P'.getMessageWith update'Self + _ -> P'.wireGetErr ft' + where + update'Self wire'Tag old'Self + = case wire'Tag of + 10 -> Prelude'.fmap (\ !new'Field -> old'Self{a = P'.mergeAppend (a old'Self) (new'Field)}) (P'.wireGet 11) + 18 -> Prelude'.fmap (\ !new'Field -> old'Self{b = P'.mergeAppend (b old'Self) (new'Field)}) (P'.wireGet 11) + _ -> let (field'Number, wire'Type) = P'.splitWireTag wire'Tag in P'.unknown field'Number wire'Type old'Self + +instance P'.MessageAPI msg' (msg' -> SampleRLWR) SampleRLWR where + getVal m' f' = f' m' + +instance P'.GPB SampleRLWR + +instance P'.ReflectDescriptor SampleRLWR where + getMessageInfo _ = P'.GetMessageInfo (P'.fromDistinctAscList [10, 18]) (P'.fromDistinctAscList [10, 18]) + reflectDescriptorInfo _ + = Prelude'.read + "DescriptorInfo {descName = ProtoName {protobufName = FIName \".RLWE.SampleRLWR\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"RLWE\"], baseName = MName \"SampleRLWR\"}, descFilePath = [\"Crypto\",\"Proto\",\"RLWE\",\"SampleRLWR.hs\"], isGroup = False, fields = fromList [FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".RLWE.SampleRLWR.a\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"RLWE\",MName \"SampleRLWR\"], baseName' = FName \"a\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 1}, wireTag = WireTag {getWireTag = 10}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 11}, typeName = Just (ProtoName {protobufName = FIName \".RLWE.Rq\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"RLWE\"], baseName = MName \"Rq\"}), hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".RLWE.SampleRLWR.b\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"RLWE\",MName \"SampleRLWR\"], baseName' = FName \"b\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 2}, wireTag = WireTag {getWireTag = 18}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 11}, typeName = Just (ProtoName {protobufName = FIName \".RLWE.Rq\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"RLWE\"], baseName = MName \"Rq\"}), hsRawDefault = Nothing, hsDefault = Nothing}], descOneofs = fromList [], keys = fromList [], extRanges = [], knownKeys = fromList [], storeUnknown = False, lazyFields = False, makeLenses = False}" + +instance P'.TextType SampleRLWR where + tellT = P'.tellSubMessage + getT = P'.getSubMessage + +instance P'.TextMsg SampleRLWR where + textPut msg + = do + P'.tellT "a" (a msg) + P'.tellT "b" (b msg) + textGet + = do + mods <- P'.sepEndBy (P'.choice [parse'a, parse'b]) P'.spaces + Prelude'.return (Prelude'.foldl (\ v f -> f v) P'.defaultValue mods) + where + parse'a + = P'.try + (do + v <- P'.getT "a" + Prelude'.return (\ o -> o{a = v})) + parse'b + = P'.try + (do + v <- P'.getT "b" + Prelude'.return (\ o -> o{b = v})) diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/benchmarks/CycBenches.hs b/benchmarks/CycBenches.hs --- a/benchmarks/CycBenches.hs +++ b/benchmarks/CycBenches.hs @@ -1,12 +1,12 @@ -{-# LANGUAGE DataKinds, FlexibleContexts, - NoImplicitPrelude, RebindableSyntax, - ScopedTypeVariables, TypeFamilies, +{-# LANGUAGE DataKinds, FlexibleContexts, + NoImplicitPrelude, RebindableSyntax, + ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-} module CycBenches (cycBenches) where +import Apply.Cyc import Benchmarks -import Harness.Cyc import Utils import Control.Monad.Random @@ -16,27 +16,38 @@ import Crypto.Random.DRBG import Data.Singletons -import Data.Promotion.Prelude.List import Data.Promotion.Prelude.Eq -import Data.Singletons.TypeRepStar +import Data.Singletons.TypeRepStar () -cycBenches :: (MonadRandom m) => m Benchmark +cycBenches :: IO Benchmark cycBenches = benchGroup "Cyc" [ - benchGroup "*" $ applyBasic (Proxy::Proxy AllParams) $ hideArgs bench_mul, - benchGroup "crt" $ applyBasic (Proxy::Proxy AllParams) $ hideArgs bench_crt, - benchGroup "crtInv" $ applyBasic (Proxy::Proxy AllParams) $ hideArgs bench_crtInv, - benchGroup "l" $ applyBasic (Proxy::Proxy AllParams) $ hideArgs bench_l, - benchGroup "*g Pow" $ applyBasic (Proxy::Proxy AllParams) $ hideArgs bench_mulgPow, - benchGroup "*g CRT" $ applyBasic (Proxy::Proxy AllParams) $ hideArgs bench_mulgCRT, - benchGroup "lift" $ applyLift (Proxy::Proxy LiftParams) $ hideArgs bench_liftPow, - benchGroup "error" $ applyError (Proxy::Proxy ErrorParams) $ hideArgs $ bench_errRounded 0.1, - benchGroup "twace" $ applyTwoIdx (Proxy::Proxy TwoIdxParams) $ hideArgs bench_twacePow, - benchGroup "embed" $ applyTwoIdx (Proxy::Proxy TwoIdxParams) $ hideArgs bench_embedPow + benchGroup "unzipCycPow" $ applyBasic allParams $ hideArgs bench_unzipCycPow, + benchGroup "unzipCycCRT" $ applyBasic allParams $ hideArgs bench_unzipCycCRT, + benchGroup "*" $ applyBasic allParams $ hideArgs bench_mul, + benchGroup "crt" $ applyBasic allParams $ hideArgs bench_crt, + benchGroup "crtInv" $ applyBasic allParams $ hideArgs bench_crtInv, + benchGroup "l" $ applyBasic allParams $ hideArgs bench_l, + benchGroup "*g Pow" $ applyBasic allParams $ hideArgs bench_mulgPow, + benchGroup "*g CRT" $ applyBasic allParams $ hideArgs bench_mulgCRT, + benchGroup "lift" $ applyLift liftParams $ hideArgs bench_liftPow, + benchGroup "error" $ applyError errorParams $ hideArgs $ bench_errRounded 0.1, + benchGroup "twace" $ applyTwoIdx twoIdxParams $ hideArgs bench_twacePow, + benchGroup "embed" $ applyTwoIdx twoIdxParams $ hideArgs bench_embedPow ] +bench_unzipCycPow :: (BasicCtx t m r, BasicCtx t m (r,r)) => Cyc t m (r,r) -> Bench '(t,m,r) +bench_unzipCycPow a = + let a' = advisePow a + in bench unzipCyc a' + +bench_unzipCycCRT :: (BasicCtx t m r, BasicCtx t m (r,r)) => Cyc t m (r,r) -> Bench '(t,m,r) +bench_unzipCycCRT a = + let a' = adviseCRT a + in bench unzipCyc a' + -- no CRT conversion, just coefficient-wise multiplication bench_mul :: (BasicCtx t m r) => Cyc t m r -> Cyc t m r -> Bench '(t,m,r) -bench_mul a b = +bench_mul a b = let a' = adviseCRT a b' = adviseCRT b in bench (a' *) b' @@ -66,50 +77,58 @@ bench_mulgCRT x = let y = adviseCRT x in bench mulG y -- generate a rounded error term -bench_errRounded :: forall t m r gen . (ErrorCtx t m r gen) +bench_errRounded :: forall t m r gen . (ErrorCtx t m r gen) => Double -> Bench '(t,m,r,gen) bench_errRounded v = benchIO $ do gen <- newGenIO return $ evalRand (errorRounded v :: Rand (CryptoRand gen) (Cyc t m (LiftOf r))) gen -bench_twacePow :: forall t m m' r . (TwoIdxCtx t m m' r) +bench_twacePow :: forall t m m' r . (TwoIdxCtx t m m' r) => Cyc t m' r -> Bench '(t,m,m',r) -bench_twacePow x = - let y = advisePow x +bench_twacePow x = + let y = advisePow x in bench (twace :: Cyc t m' r -> Cyc t m r) y -bench_embedPow :: forall t m m' r . (TwoIdxCtx t m m' r) +bench_embedPow :: forall t m m' r . (TwoIdxCtx t m m' r) => Cyc t m r -> Bench '(t,m,m',r) -bench_embedPow x = - let y = advisePow x +bench_embedPow x = + let y = advisePow x in bench (embed :: Cyc t m r -> Cyc t m' r) y type Tensors = '[CT,RT] -type MM'RCombos = - '[ '(F4, F128, Zq 257), - '(F1, PToF Prime281, Zq 563), - '(F12, F32 * F9, Zq 512), - '(F12, F32 * F9, Zq 577), - '(F12, F32 * F9, Zq (577 ** 1153)), - '(F12, F32 * F9, Zq (577 ** 1153 ** 2017)), - '(F12, F32 * F9, Zq (577 ** 1153 ** 2017 ** 2593)), - '(F12, F32 * F9, Zq (577 ** 1153 ** 2017 ** 2593 ** 3169)), - '(F12, F32 * F9, Zq (577 ** 1153 ** 2017 ** 2593 ** 3169 ** 3457)), - '(F12, F32 * F9, Zq (577 ** 1153 ** 2017 ** 2593 ** 3169 ** 3457 ** 6337)), - '(F12, F32 * F9, Zq (577 ** 1153 ** 2017 ** 2593 ** 3169 ** 3457 ** 6337 ** 7489)), - '(F12, F32 * F9 * F25, Zq 14401) +type MRCombos = + '[ '(F1024, Zq 1051649), -- 1024 / 512 + '(F2048, Zq 1054721), -- 2048 / 1024 + '(F64 * F27, Zq 1048897), -- 1728 / 576 + '(F64 * F81, Zq 1073089), -- 5184 / 1728 + '(F64*F9*F25, Zq 1065601) -- 14400 / 3840 ] + +type MM'RCombos = + '[ '(F8 * F91, F8 * F91 * F4, Zq 8737), + '(F8 * F91, F8 * F91 * F5, Zq 14561), + '(F128, F128 * F91, Zq 23297) + ] + -- EAC: must be careful where we use Nub: apparently TypeRepStar doesn't work well with the Tensor constructors type AllParams = ( '(,) <$> Tensors) <*> (Nub (Map RemoveM MM'RCombos)) +allParams :: Proxy AllParams +allParams = Proxy + type LiftParams = ( '(,) <$> Tensors) <*> (Nub (Filter Liftable (Map RemoveM MM'RCombos))) +liftParams :: Proxy LiftParams +liftParams = Proxy + type TwoIdxParams = ( '(,) <$> Tensors) <*> MM'RCombos +twoIdxParams :: Proxy TwoIdxParams +twoIdxParams = Proxy type ErrorParams = ( '(,) <$> '[HashDRBG]) <*> LiftParams +errorParams :: Proxy ErrorParams +errorParams = Proxy data Liftable :: TyFun (Factored, *) Bool -> * type instance Apply Liftable '(m',r) = Int64 :== (LiftOf r) data RemoveM :: TyFun (Factored, Factored, *) (Factored, *) -> * type instance Apply RemoveM '(m,m',r) = '(m',r) - - diff --git a/benchmarks/Main.hs b/benchmarks/Main.hs --- a/benchmarks/Main.hs +++ b/benchmarks/Main.hs @@ -1,12 +1,15 @@ import CycBenches +import TensorBenches +import UCycBenches import ZqBenches import Criterion.Main -import Control.Monad main :: IO () -main = defaultMain =<< (sequence [ +main = defaultMain =<< sequence [ zqBenches, + tensorBenches, + ucycBenches, cycBenches - ]) + ] diff --git a/benchmarks/TensorBenches.hs b/benchmarks/TensorBenches.hs new file mode 100644 --- /dev/null +++ b/benchmarks/TensorBenches.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE DataKinds, FlexibleContexts, + NoImplicitPrelude, RebindableSyntax, + ScopedTypeVariables, TypeFamilies, + TypeOperators, UndecidableInstances #-} + +module TensorBenches (tensorBenches) where + +import Apply.Cyc +import Benchmarks +import Utils + +import Crypto.Lol +import Crypto.Lol.Cyclotomic.Tensor + +tensorBenches :: IO Benchmark +tensorBenches = benchGroup "Tensor" [ + benchGroup "l" $ applyBasic (Proxy::Proxy QuickParams) $ hideArgs bench_l] + +-- convert input from Dec basis to Pow basis +bench_l :: (Tensor t, Fact m, Additive r, TElt t r, NFData (t m r)) => t m r -> Bench '(t,m,r) +bench_l = bench l + +type QuickTest = '[ '(F128, Zq 257), + '(F32 * F9, Zq 577), + '(F32 * F9, Int64) ] +type Tensors = '[CT,RT] +type QuickParams = ( '(,) <$> Tensors) <*> QuickTest diff --git a/benchmarks/UCycBenches.hs b/benchmarks/UCycBenches.hs new file mode 100644 --- /dev/null +++ b/benchmarks/UCycBenches.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE DataKinds, FlexibleContexts, + NoImplicitPrelude, RebindableSyntax, + ScopedTypeVariables, TypeFamilies, + TypeOperators, UndecidableInstances #-} + +module UCycBenches (ucycBenches) where + +import Apply.Cyc +import Benchmarks +import Utils + +import Crypto.Lol +import Crypto.Lol.Cyclotomic.UCyc + +ucycBenches :: IO Benchmark +ucycBenches = benchGroup "UCyc" [ + benchGroup "l" $ applyBasic (Proxy::Proxy QuickParams) $ hideArgs bench_l, + benchGroup "twace" $ applyTwoIdx twoIdxParams $ hideArgs bench_twacePow, + benchGroup "embed" $ applyTwoIdx twoIdxParams $ hideArgs bench_embedPow + ] + +-- convert input from Dec basis to Pow basis +bench_l :: (BasicCtx t m r) => UCyc t m D r -> Bench '(t,m,r) +bench_l = bench toPow + +bench_twacePow :: forall t m m' r . (TwoIdxCtx t m m' r) + => UCyc t m' P r -> Bench '(t,m,m',r) +bench_twacePow = bench (twacePow :: UCyc t m' P r -> UCyc t m P r) + +bench_embedPow :: forall t m m' r . (TwoIdxCtx t m m' r) + => UCyc t m P r -> Bench '(t,m,m',r) +bench_embedPow = bench (embedPow :: UCyc t m P r -> UCyc t m' P r) + +type QuickTest = '[ '(F128, Zq 257), + '(F32 * F9, Zq 577), + '(F32 * F9, Int64) ] +type Tensors = '[CT,RT] +type QuickParams = ( '(,) <$> Tensors) <*> QuickTest + +type MM'RCombos = + '[ '(F8 * F91, F8 * F91 * F4, Zq 8737), + '(F8 * F91, F8 * F91 * F5, Zq 14561), + '(F128, F128 * F91, Zq 23297) + ] +type TwoIdxParams = ( '(,) <$> Tensors) <*> MM'RCombos +twoIdxParams :: Proxy TwoIdxParams +twoIdxParams = Proxy diff --git a/benchmarks/ZqBenches.hs b/benchmarks/ZqBenches.hs --- a/benchmarks/ZqBenches.hs +++ b/benchmarks/ZqBenches.hs @@ -10,27 +10,27 @@ import Control.Monad.Random import qualified Data.Vector.Unboxed as U import qualified Data.Array.Repa as R -import GHC.TypeLits import Utils -import Gen +import GenArgs import Benchmarks type Arr = R.Array R.U R.DIM1 -zqBenches :: MonadRandom rnd => rnd Benchmark +zqBenches :: IO Benchmark zqBenches = benchGroup "ZqBasic" [ hideArgs bench_mul_unb (Proxy::Proxy (Zq 577)), - hideArgs bench_mul_repa $ (Proxy::Proxy (Zq 577)) + hideArgs bench_mul_repa (Proxy::Proxy (Zq 577)) ] bench_mul_repa :: (Ring zq, U.Unbox zq) => Arr zq -> Arr zq -> Bench zq -bench_mul_repa a b = bench (R.computeUnboxedS . R.zipWith (*) a) b +bench_mul_repa a = bench (R.computeUnboxedS . R.zipWith (*) a) bench_mul_unb :: (Ring zq, U.Unbox zq) => U.Vector zq -> U.Vector zq -> Bench zq -bench_mul_unb a b = bench (U.zipWith (*) a) b +bench_mul_unb a = bench (U.zipWith (*) a) -vecLen = 100 :: Int +vecLen :: Int +vecLen = 100 instance (U.Unbox zq, Random zq, MonadRandom rnd) => Generatable rnd (Arr zq) where genArg = R.fromListUnboxed (R.Z R.:. vecLen) <$> replicateM vecLen getRandom diff --git a/lol.cabal b/lol.cabal --- a/lol.cabal +++ b/lol.cabal @@ -1,11 +1,11 @@ name: lol --- The package version. See the Haskell package versioning policy (PVP) +-- The package version. See the Haskell package versioning policy (PVP) -- for standards guiding when and how versions should be incremented. -- http://www.haskell.org/haskellwiki/Package_versioning_policy -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.2.0.1 +version: 0.3.0.0 synopsis: A library for lattice cryptography. homepage: https://github.com/cpeikert/Lol Bug-Reports: https://github.com/cpeikert/Lol/issues @@ -19,22 +19,27 @@ build-type: Simple extra-source-files: README, CHANGES.md, benchmarks/CycBenches.hs, + benchmarks/TensorBenches.hs, + benchmarks/UCycBenches.hs, benchmarks/ZqBenches.hs, tests/CycTests.hs, - tests/ZqTests.hs, tests/TensorTests.hs, + tests/ZqTests.hs, utils/Apply.hs, + utils/Apply/Cyc.hs, + utils/Apply/Zq.hs, utils/Benchmarks.hs, - utils/Gen.hs, + utils/GenArgs.hs, + utils/GenArgs/Zq.hs, utils/Tests.hs, utils/TestTypes.hs, utils/Utils.hs, - utils/Harness/Cyc.hs, - Crypto/Lol/Cyclotomic/Tensor/CTensor/tensorTypes.h + Crypto/Lol/Cyclotomic/Tensor/CTensor/*.h, + Crypto/Lol/Cyclotomic/Tensor/CTensor/*.cpp cabal-version: >= 1.10 -description: +description: Λ ○ λ (Lol) is a general-purpose library for ring-based lattice cryptography. - For a detailed description of interfaces and functionality, see + For a detailed description of interfaces and functionality, see . For example cryptographic applications, see . source-repository head @@ -43,74 +48,83 @@ -- For information on compiling C with cabal: http://blog.ezyang.com/2010/06/setting-up-cabal-the-ffi-and-c2hs/ -Flag useICC - Description: Use ICC instead of GCC to compile C backend. - Default: False - Flag llvm Description: Compile via LLVM. This produces much better object code, but you need to have the LLVM compiler installed. - + -- If you enable this and get errors like "Error: can't resolve `.rodata' {.rodata section}" + -- then GHC doesn't like your version of LLVM! Default: False Flag opt Description: Turn on library optimizations Default: True - Manual: False library - Include-dirs: Crypto/Lol/Cyclotomic/Tensor/CTensor - C-sources: Crypto/Lol/Cyclotomic/Tensor/CTensor/basic.c, - Crypto/Lol/Cyclotomic/Tensor/CTensor/crt.c, - Crypto/Lol/Cyclotomic/Tensor/CTensor/g.c, - Crypto/Lol/Cyclotomic/Tensor/CTensor/generalfuncs.c, - Crypto/Lol/Cyclotomic/Tensor/CTensor/l.c, - Crypto/Lol/Cyclotomic/Tensor/CTensor/norm.c, - Crypto/Lol/Cyclotomic/Tensor/CTensor/random.c - Includes: Crypto/Lol/Cyclotomic/Tensor/CTensor/tensorTypes.h default-language: Haskell2010 - - if flag(useICC) - ghc-options: -pgml icc -optc-O3 - cc-options: -std=gnu99 -Wall -DSTATS -DCINTRIN - else - ghc-options: -pgml gcc -fPIC -optc-O3 - cc-options: -std=gnu99 -fPIC -Wall + ghc-options: -fwarn-dodgy-imports + cc-options: -std=c++11 + Include-dirs: Crypto/Lol/Cyclotomic/Tensor/CTensor + -- Due to #12152, the file containing the definition of `Zq::q` must be linked first, + -- otherwise dynamic linking (`cabal repl` or `stack ghci`) results in the error: + -- "Loading temp shared object failed: /tmp/ghc54651_0/libghc_1.so: undefined symbol _ZN2Zq1qE" + -- For `cabal repl`, we can simply reorder the list so that the file that should be linked + -- first comes first in the list. However `stack ghci` always links alphabetically, + -- so we really just have to define `Zq::q` in the first file alphabetically. + C-sources: Crypto/Lol/Cyclotomic/Tensor/CTensor/common.cpp, + Crypto/Lol/Cyclotomic/Tensor/CTensor/crt.cpp, + Crypto/Lol/Cyclotomic/Tensor/CTensor/g.cpp, + Crypto/Lol/Cyclotomic/Tensor/CTensor/l.cpp, + Crypto/Lol/Cyclotomic/Tensor/CTensor/mul.cpp, + Crypto/Lol/Cyclotomic/Tensor/CTensor/norm.cpp, + Crypto/Lol/Cyclotomic/Tensor/CTensor/random.cpp, + Crypto/Lol/Cyclotomic/Tensor/CTensor/zq.cpp if flag(llvm) ghc-options: -fllvm -optlo-O3 -- ghc optimizations if flag(opt) - ghc-options: -O3 -Odph -funbox-strict-fields -fwarn-dodgy-imports -rtsopts - ghc-options: -fno-liberate-case -funfolding-use-threshold1000 -funfolding-keeness-factor1000 + ghc-options: -O3 -Odph -funbox-strict-fields -fno-liberate-case -funfolding-use-threshold1000 -funfolding-keeness-factor1000 - exposed-modules: + exposed-modules: Crypto.Lol Crypto.Lol.PosBin Crypto.Lol.Factored Crypto.Lol.Reflects Crypto.Lol.CRTrans Crypto.Lol.Gadget - Crypto.Lol.LatticePrelude + Crypto.Lol.Prelude Crypto.Lol.Cyclotomic.Cyc Crypto.Lol.Cyclotomic.UCyc Crypto.Lol.Cyclotomic.RescaleCyc Crypto.Lol.Cyclotomic.Linear + Crypto.Lol.RLWE.Continuous + Crypto.Lol.RLWE.Discrete + Crypto.Lol.RLWE.RLWR + Crypto.Lol.Cyclotomic.Tensor Crypto.Lol.Cyclotomic.Tensor.CTensor Crypto.Lol.Cyclotomic.Tensor.RepaTensor - + Crypto.Lol.Types.Random Crypto.Lol.Types.FiniteField Crypto.Lol.Types.IrreducibleChar2 + Crypto.Lol.Types.Proto + Crypto.Lol.Types.RRq Crypto.Lol.Types.ZPP Crypto.Lol.Types.ZqBasic + Crypto.Proto.RLWE + Crypto.Proto.RLWE.Rq + Crypto.Proto.RLWE.Kq + Crypto.Proto.RLWE.SampleCont + Crypto.Proto.RLWE.SampleDisc + Crypto.Proto.RLWE.SampleRLWR + other-modules: - + Crypto.Lol.FactoredDefs Crypto.Lol.PosBinDefs Crypto.Lol.GaussRandom @@ -118,6 +132,7 @@ Crypto.Lol.Types.Complex Crypto.Lol.Types.Numeric Crypto.Lol.Types.IZipVector + Crypto.Lol.Cyclotomic.CRTSentinel Crypto.Lol.Cyclotomic.Tensor.RepaTensor.CRT Crypto.Lol.Cyclotomic.Tensor.RepaTensor.Extension Crypto.Lol.Cyclotomic.Tensor.RepaTensor.Dec @@ -134,21 +149,24 @@ constraints, containers >= 0.5.6.2 && < 0.6, crypto-api, - data-default >= 0.3.0 && < 0.6, + data-default >= 0.3.0 && < 0.8, deepseq >= 1.4.1.1 && <1.5, + monadcryptorandom, MonadRandom >= 0.2 && < 0.5, mtl >= 2.2.1 && < 2.3, numeric-prelude >= 0.4.2 && < 0.5, QuickCheck >= 2.8 && < 2.9, + protocol-buffers, + protocol-buffers-descriptor, random >= 1.1 && < 1.2, reflection >= 1.5.1 && < 2.2, repa==3.4.*, - singletons >= 1.1.2.1 && < 2.1, + singletons >= 1.1.2.1 && < 2.2, storable-record >= 0.0.3 && < 0.1, - th-desugar >= 1.5.4 && < 1.6, + th-desugar >= 1.5.4 && < 1.7, tagged-transformer >= 0.7 && < 0.9, template-haskell >= 2.2.0.0, - transformers >= 0.4.2.0 && < 0.5, + transformers >= 0.4.2.0 && < 0.6, vector==0.11.*, vector-th-unbox >= 0.2.1.0 && < 0.3 @@ -184,9 +202,10 @@ default-language: Haskell2010 main-is: Main.hs - -- if flag(llvm) - -- ghc-options: -fllvm -optlo-O3 - ghc-options: -threaded -rtsopts + if flag(llvm) + ghc-options: -fllvm -optlo-O3 + -- ghc-options: -threaded -rtsopts + ghc-options: -O3 -Odph -funbox-strict-fields -fno-liberate-case -funfolding-use-threshold1000 -funfolding-keeness-factor1000 -- ghc-options: -O2 -Odph -funbox-strict-fields -fwarn-dodgy-imports -rtsopts -- ghc-options: -fno-liberate-case -funfolding-use-threshold1000 -funfolding-keeness-factor1000 @@ -201,4 +220,4 @@ singletons, transformers, vector, - repa + repa diff --git a/tests/CycTests.hs b/tests/CycTests.hs --- a/tests/CycTests.hs +++ b/tests/CycTests.hs @@ -7,38 +7,39 @@ import Crypto.Lol import Crypto.Lol.Types.ZPP -import Test.Framework (buildTest) - import Utils -import Harness.Cyc +import Apply.Cyc import Tests +import qualified Test.Framework as TF + +cycTests :: [TF.Test] cycTests = [ - testGroupM "coeffsPow" $ applyTwoIdx (Proxy::Proxy '[]) $ hideArgs prop_coeffsBasis, - testGroupM "mulGPow" $ applyBasic (Proxy::Proxy AllParams) $ hideArgs prop_mulgPow, - testGroupM "mulGDec" $ applyBasic (Proxy::Proxy AllParams) $ hideArgs prop_mulgDec, - testGroupM "mulGCRT" $ applyBasic (Proxy::Proxy AllParams) $ hideArgs prop_mulgCRT, - testGroupM "crtSet" $ applyBasis (Proxy::Proxy BasisParams) $ hideArgs prop_crtSet_pairs + testGroupM "mulGPow" $ applyBasic allParams $ hideArgs prop_mulgPow, + testGroupM "mulGDec" $ applyBasic allParams $ hideArgs prop_mulgDec, + testGroupM "mulGCRT" $ applyBasic allParams $ hideArgs prop_mulgCRT, + testGroupM "crtSet" $ applyBasis basisParams $ hideArgs prop_crtSet_pairs, + testGroupM "coeffsPow" $ applyTwoIdx basisParams $ hideArgs prop_coeffsBasis ] -prop_mulgPow :: (CElt t r, Fact m, Eq r) => Cyc t m r -> Test '(t,m,r) +prop_mulgPow :: (CElt t r, Fact m, Eq r, IntegralDomain r) => Cyc t m r -> Test '(t,m,r) prop_mulgPow x = let y = advisePow x in test $ y == (fromJust' "prop_mulgPow failed divisibility!" $ divG $ mulG y) -prop_mulgDec :: (CElt t r, Fact m, Eq r) => Cyc t m r -> Test '(t,m,r) -prop_mulgDec x = +prop_mulgDec :: (CElt t r, Fact m, Eq r, IntegralDomain r) => Cyc t m r -> Test '(t,m,r) +prop_mulgDec x = let y = adviseDec x in test $ y == (fromJust' "prop_mulgDec failed divisibility!" $ divG $ mulG y) -prop_mulgCRT :: (CElt t r, Fact m, Eq r) => Cyc t m r -> Test '(t,m,r) -prop_mulgCRT x = +prop_mulgCRT :: (CElt t r, Fact m, Eq r, IntegralDomain r) => Cyc t m r -> Test '(t,m,r) +prop_mulgCRT x = let y = adviseCRT x in test $ y == (fromJust' "prop_mulgCRT failed divisibility!" $ divG $ mulG y) prop_coeffsBasis :: forall t m m' r . (m `Divides` m', CElt t r, Eq r) => Cyc t m' r -> Test '(t,m,m',r) -prop_coeffsBasis x = +prop_coeffsBasis x = let xs = map embed (coeffsCyc Pow x :: [Cyc t m r]) bs = proxy powBasis (Proxy::Proxy m) in test $ (sum $ zipWith (*) xs bs) == x @@ -47,13 +48,13 @@ -- necessary (but not sufficient) condition prop_crtSet_pairs :: forall t m m' r . (m `Divides` m', ZPP r, Eq r, CElt t r, CElt t (ZpOf r)) => Test '(t,m,m',r) -prop_crtSet_pairs = +prop_crtSet_pairs = let crtset = proxy crtSet (Proxy::Proxy m) :: [Cyc t m' r] pairs = join (liftM2 (,)) crtset in test $ and $ map (\(a,b) -> if a == b then a*b == a else a*b == zero) pairs type Tensors = '[CT,RT] -type MRCombos = +type MRCombos = '[ '(F7, Zq 29), '(F7, Zq 32), '(F12, Zq 2148249601), @@ -75,18 +76,9 @@ ] type AllParams = ( '(,) <$> Tensors) <*> MRCombos -type BasisParams = ( '(,) <$> Tensors) <*> MM'RCombos - --- for crtSet, take all pairwise products --- if elts are equal, id --- if not, zero - --- also do a cardinality check +allParams :: Proxy AllParams +allParams = Proxy --- checks cardinality of the CRT set -{- -prop_crtSet_card pm _ - let inferLen = length $ (proxy crtSetDec pm :: [t m' r]) - expectLen = - in --} +type BasisParams = ( '(,) <$> Tensors) <*> MM'RCombos +basisParams :: Proxy BasisParams +basisParams = Proxy diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -6,7 +6,7 @@ import Test.Framework main :: IO () -main = do +main = flip defaultMainWithArgs ["--threads=1","--maximum-generated-tests=100"] [ testGroup "Tensor Tests" tensorTests ,testGroup "Cyc Tests" cycTests diff --git a/tests/TensorTests.hs b/tests/TensorTests.hs --- a/tests/TensorTests.hs +++ b/tests/TensorTests.hs @@ -1,10 +1,10 @@ -{-# LANGUAGE ConstraintKinds, FlexibleContexts, DataKinds, NoImplicitPrelude, +{-# LANGUAGE ConstraintKinds, FlexibleContexts, DataKinds, NoImplicitPrelude, RebindableSyntax, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-} module TensorTests (tensorTests) where -import Harness.Cyc +import Apply.Cyc import Tests import Utils @@ -15,24 +15,24 @@ import Crypto.Lol.Cyclotomic.Tensor import Control.Applicative -import Control.Monad.Random import Data.Maybe import Data.Singletons -import Data.Promotion.Prelude.List import Data.Promotion.Prelude.Eq -import Data.Singletons.TypeRepStar +import Data.Singletons.TypeRepStar () -tensorTests = - [testGroupM "fmapT comparison" $ applyBasic (Proxy::Proxy TMRParams) $ hideArgs prop_fmapT, - testGroupM "fmap comparison" $ applyBasic (Proxy::Proxy TMRParams) $ hideArgs prop_fmap, +import qualified Test.Framework as TF + +tensorTests :: [TF.Test] +tensorTests = + [testGroupM "fmapT comparison" $ applyBasic tmrParams $ hideArgs prop_fmapT, + testGroupM "fmap comparison" $ applyBasic tmrParams $ hideArgs prop_fmap, testGroup "GInv.G == id" gInvGTests, - testGroupM "CRTInv.CRT == id" $ applyBasic (Proxy::Proxy TMRParams) $ hideArgs prop_crt_inv, - testGroupM "LInv.L == id" $ applyBasic (Proxy::Proxy TMRParams) $ hideArgs prop_l_inv, - testGroupM "Scalar" $ applyBasic (Proxy::Proxy TMRParams) $ hideArgs prop_scalar_crt, + testGroupM "CRTInv.CRT == id" $ applyBasic tmrParams $ hideArgs prop_crt_inv, + testGroupM "LInv.L == id" $ applyBasic tmrParams $ hideArgs prop_l_inv, + testGroupM "Scalar" $ applyBasic tmrParams $ hideArgs prop_scalar_crt, testGroup "G commutes with L" gCommuteTests, - testGroupM "Extension Mult" $ applyBasic (Proxy::Proxy ExtParams) $ hideArgs prop_mul_ext, testGroupM "GSqNormDec" $ applyLift (Proxy::Proxy NormParams) $ hideArgs prop_gsqnorm, testGroup "Tw.Em == id" tremTests, testGroup "Em commutes with L" embedCommuteTests, @@ -47,35 +47,36 @@ prop_fmap x = test $ (fmap id x) == x \\ witness entailEqT x \\ witness entailIndexT x -- divG . mulG == id in Pow basis -prop_ginv_pow :: (Tensor t, TElt t r, Fact m, Eq r, Ring r, ZeroTestable r, IntegralDomain r) +prop_ginv_pow :: (Tensor t, TElt t r, Fact m, Eq r, Ring r, ZeroTestable r, IntegralDomain r) => t m r -> Test '(t,m,r) -prop_ginv_pow x = test $ (fromMaybe (error "could not divide by G in prop_ginv_pow") $ +prop_ginv_pow x = test $ (fromMaybe (error "could not divide by G in prop_ginv_pow") $ divGPow $ mulGPow x) == x \\ witness entailEqT x -- divG . mulG == id in Dec basis -prop_ginv_dec :: (Tensor t, TElt t r, Fact m, Eq r, Ring r, ZeroTestable r, IntegralDomain r) +prop_ginv_dec :: (Tensor t, TElt t r, Fact m, Eq r, Ring r, ZeroTestable r, IntegralDomain r) => t m r -> Test '(t,m,r) -prop_ginv_dec x = test $ (fromMaybe (error "could not divide by G in prop_ginv_dec") $ +prop_ginv_dec x = test $ (fromMaybe (error "could not divide by G in prop_ginv_dec") $ divGDec $ mulGDec x) == x \\ witness entailEqT x -- divG . mulG == id in CRT basis -prop_ginv_crt :: (Tensor t, TElt t r, Fact m, Eq r, ZeroTestable r, IntegralDomain r, CRTrans r) +prop_ginv_crt :: (Tensor t, TElt t r, Fact m, Eq r, CRTrans Maybe r) => t m r -> Test '(t,m,r) prop_ginv_crt x = test $ fromMaybe (error "no CRT in prop_ginv_crt") $ do divGCRT' <- divGCRT mulGCRT' <- mulGCRT return $ (divGCRT' $ mulGCRT' x) == x \\ witness entailEqT x +gInvGTests :: [TF.Test] gInvGTests = [ - testGroupM "Pow basis" $ applyBasic (Proxy::Proxy TMRParams) $ hideArgs prop_ginv_pow, - testGroupM "Dec basis" $ applyBasic (Proxy::Proxy TMRParams) $ hideArgs prop_ginv_dec, - testGroupM "CRT basis" $ applyBasic (Proxy::Proxy TMRParams) $ hideArgs prop_ginv_crt] + testGroupM "Pow basis" $ applyBasic tmrParams $ hideArgs prop_ginv_pow, + testGroupM "Dec basis" $ applyBasic tmrParams $ hideArgs prop_ginv_dec, + testGroupM "CRT basis" $ applyBasic tmrParams $ hideArgs prop_ginv_crt] -- mulGDec == lInv. mulGPow . l prop_g_dec :: (Tensor t, Ring r, Fact m, TElt t r, Eq r) => t m r -> Test '(t,m,r) prop_g_dec x = test $ (mulGDec x) == (lInv $ mulGPow $ l x) \\ witness entailEqT x -prop_g_crt :: (Tensor t, TElt t r, Fact m, Eq r, ZeroTestable r, IntegralDomain r, CRTrans r) +prop_g_crt :: (Tensor t, TElt t r, Fact m, Eq r, CRTrans Maybe r) => t m r -> Test '(t,m,r) prop_g_crt x = test $ fromMaybe (error "no CRT in prop_g_crt") $ do mulGCRT' <- mulGCRT @@ -83,12 +84,13 @@ crtInv' <- crtInv return $ (mulGCRT' x) == (crt' $ mulGPow $ crtInv' x) \\ witness entailEqT x +gCommuteTests :: [TF.Test] gCommuteTests = [ - testGroupM "Dec basis" $ applyBasic (Proxy::Proxy TMRParams) $ hideArgs prop_g_dec, - testGroupM "CRT basis" $ applyBasic (Proxy::Proxy TMRParams) $ hideArgs prop_g_crt] + testGroupM "Dec basis" $ applyBasic tmrParams $ hideArgs prop_g_dec, + testGroupM "CRT basis" $ applyBasic tmrParams $ hideArgs prop_g_crt] -- crtInv . crt == id -prop_crt_inv :: (Tensor t, TElt t r, Fact m, Eq r, ZeroTestable r, IntegralDomain r, CRTrans r) +prop_crt_inv :: (Tensor t, TElt t r, Fact m, Eq r, CRTrans Maybe r) => t m r -> Test '(t,m,r) prop_crt_inv x = test $ fromMaybe (error "no CRT in prop_crt_inv") $ do crt' <- crt @@ -100,7 +102,7 @@ prop_l_inv x = test $ (lInv $ l x) == x \\ witness entailEqT x -- scalarCRT = crt . scalarPow -prop_scalar_crt :: forall t m r . (Tensor t, TElt t r, Fact m, Eq r, ZeroTestable r, IntegralDomain r, CRTrans r) +prop_scalar_crt :: forall t m r . (Tensor t, TElt t r, Fact m, Eq r, CRTrans Maybe r) => r -> Test '(t,m,r) prop_scalar_crt r = test $ fromMaybe (error "no CRT in prop_scalar_crt") $ do scalarCRT' <- scalarCRT @@ -108,30 +110,16 @@ return $ (scalarCRT' r :: t m r) == (crt' $ scalarPow r) \\ proxy entailEqT (Proxy::Proxy (t m r)) - - --- tests that multiplication in the extension ring matches CRT multiplication -prop_mul_ext :: forall t m r . (Tensor t, Fact m, TElt t r, TElt t (CRTExt r), CRTrans r, CRTEmbed r, Ring r, Eq r) - => t m r -> t m r -> Test '(t,m,r) -prop_mul_ext x y = test $ - let m = proxy valueFact (Proxy::Proxy m) - in case (crtInfo m :: Maybe (CRTInfo r)) of - Nothing -> error "mul have a CRT to call prop_mul_ext" - Just _ -> (let z = zipWithT (*) x y - z' = fmapT fromExt $ zipWithT (*) (fmapT toExt x) (fmapT toExt y) - in z == z') \\ witness entailEqT x - \\ witness entailIndexT x - -type NormCtx t m r = (TElt t r, TElt t (LiftOf r), - Fact m, Lift' r, CRTrans r, Eq (LiftOf r), +type NormCtx t m r = (TElt t r, TElt t (LiftOf r), + Fact m, Lift' r, CRTrans Maybe r, Eq (LiftOf r), ZeroTestable r, Ring (LiftOf r), Ring r, IntegralDomain r) type NormWrapCtx m r = (NormCtx CT m r, NormCtx RT m r) -- tests that gSqNormDec of two "random-looking" vectors agrees for RT and CT -- t is a dummy param -prop_gsqnorm :: forall t m r . - (NormWrapCtx m r, NormCtx t m r) +prop_gsqnorm :: forall t m r . + (NormWrapCtx m r, NormCtx t m r) => r -> Test '(t,m,r) prop_gsqnorm x = test $ let crtCT = fromJust crt @@ -142,15 +130,16 @@ in gSqNormDec ct == gSqNormDec rt -type TMM'RCtx t m m' r = - (Tensor t, m `Divides` m', TElt t r, Ring r, - CRTrans r, Eq r, ZeroTestable r, IntegralDomain r) +type TMM'RCtx t m m' r = + (Tensor t, m `Divides` m', TElt t r, Ring r, + CRTrans Maybe r, Eq r, ZeroTestable r, IntegralDomain r) -- groups related tests +tremTests :: [TF.Test] tremTests = [ - testGroupM "Pow basis" $ applyTwoIdx (Proxy::Proxy TrEmParams) $ hideArgs prop_trem_pow, - testGroupM "Dec basis" $ applyTwoIdx (Proxy::Proxy TrEmParams) $ hideArgs prop_trem_dec, - testGroupM "CRT basis" $ applyTwoIdx (Proxy::Proxy TrEmParams) $ hideArgs prop_trem_crt] + testGroupM "Pow basis" $ applyTwoIdx tremParams $ hideArgs prop_trem_pow, + testGroupM "Dec basis" $ applyTwoIdx tremParams $ hideArgs prop_trem_dec, + testGroupM "CRT basis" $ applyTwoIdx tremParams $ hideArgs prop_trem_crt] -- tests that twace . embed == id in the Pow basis prop_trem_pow :: forall t m m' r . (TMM'RCtx t m m' r) @@ -169,14 +158,14 @@ (x==) <$> (twaceCRT <*> (embedCRT <*> pure x :: Maybe (t m' r))) \\ witness entailEqT x - +embedCommuteTests :: [TF.Test] embedCommuteTests = [ - testGroupM "Dec basis" $ applyTwoIdx (Proxy::Proxy TrEmParams) $ hideArgs prop_embed_dec, - testGroupM "CRT basis" $ applyTwoIdx (Proxy::Proxy TrEmParams) $ hideArgs prop_embed_crt] + testGroupM "Dec basis" $ applyTwoIdx tremParams $ hideArgs prop_embed_dec, + testGroupM "CRT basis" $ applyTwoIdx tremParams $ hideArgs prop_embed_crt] -- embedDec == lInv . embedPow . l prop_embed_dec :: forall t m m' r . (TMM'RCtx t m m' r) => t m r -> Test '(t,m,m',r) -prop_embed_dec x = test $ (embedDec x :: t m' r) == (lInv $ embedPow $ l x) +prop_embed_dec x = test $ (embedDec x :: t m' r) == (lInv $ embedPow $ l x) \\ proxy entailEqT (Proxy::Proxy (t m' r)) -- embedCRT = crt . embedPow . crtInv @@ -185,12 +174,13 @@ crt' <- crt crtInv' <- crtInv embedCRT' <- embedCRT - return $ (embedCRT' x :: t m' r) == (crt' $ embedPow $ crtInv' x) + return $ (embedCRT' x :: t m' r) == (crt' $ embedPow $ crtInv' x) \\ proxy entailEqT (Proxy::Proxy (t m' r)) +twaceCommuteTests :: [TF.Test] twaceCommuteTests = [ - testGroupM "Dec basis" $ applyTwoIdx (Proxy::Proxy TrEmParams) $ hideArgs prop_twace_dec, - testGroupM "CRT basis" $ applyTwoIdx (Proxy::Proxy TrEmParams) $ hideArgs prop_twace_crt] + testGroupM "Dec basis" $ applyTwoIdx tremParams $ hideArgs prop_twace_dec, + testGroupM "CRT basis" $ applyTwoIdx tremParams $ hideArgs prop_twace_crt] -- twacePowDec = lInv . twacePowDec . l prop_twace_dec :: forall t m m' r . (TMM'RCtx t m m' r) => t m' r -> Test '(t,m,m',r) @@ -206,26 +196,27 @@ return $ (twaceCRT' x :: t m r) == (crt' $ twacePowDec $ crtInv' x) \\ proxy entailEqT (Proxy::Proxy (t m r)) +twaceInvarTests :: [TF.Test] twaceInvarTests = [ - testGroupM "Tw and Em ID for equal indices" $ applyBasic (Proxy::Proxy TMRParams) $ hideArgs prop_twEmID, - testGroupM "Invar1 Pow basis" $ applyTwoIdx (Proxy::Proxy TrEmParams) $ hideArgs prop_twace_invar1_pow, - testGroupM "Invar1 Dec basis" $ applyTwoIdx (Proxy::Proxy TrEmParams) $ hideArgs prop_twace_invar1_dec, - testGroupM "Invar1 CRT basis" $ applyTwoIdx (Proxy::Proxy TrEmParams) $ hideArgs prop_twace_invar1_crt, - testGroupM "Invar2 Pow/Dec basis" $ applyTwoIdx (Proxy::Proxy TrEmParams) $ hideArgs prop_twace_invar2_powdec, - testGroupM "Invar2 CRT basis" $ applyTwoIdx (Proxy::Proxy TrEmParams) $ hideArgs prop_twace_invar2_crt + testGroupM "Tw and Em ID for equal indices" $ applyBasic tmrParams $ hideArgs prop_twEmID, + testGroupM "Invar1 Pow basis" $ applyTwoIdx tremParams $ hideArgs prop_twace_invar1_pow, + testGroupM "Invar1 Dec basis" $ applyTwoIdx tremParams $ hideArgs prop_twace_invar1_dec, + testGroupM "Invar1 CRT basis" $ applyTwoIdx tremParams $ hideArgs prop_twace_invar1_crt, + testGroupM "Invar2 Pow/Dec basis" $ applyTwoIdx tremParams $ hideArgs prop_twace_invar2_powdec, + testGroupM "Invar2 CRT basis" $ applyTwoIdx tremParams $ hideArgs prop_twace_invar2_crt ] -prop_twEmID :: forall t m r . (Tensor t, TElt t r, CRTrans r, Fact m, m `Divides` m, Eq r, ZeroTestable r, IntegralDomain r) +prop_twEmID :: forall t m r . (Tensor t, TElt t r, CRTrans Maybe r, Fact m, m `Divides` m, Eq r, ZeroTestable r, IntegralDomain r) => t m r -> Test '(t,m,r) -prop_twEmID x = test $ +prop_twEmID x = test $ ((twacePowDec x) == x) && - (((fromMaybe (error "twemid_crt") twaceCRT) x) == x) && - ((embedPow x) == x) && - ((embedDec x) == x) && - (((fromMaybe (error "twemid_crt") embedCRT) x) == x) \\ witness entailEqT x + (((fromMaybe (error "twemid_crt") twaceCRT) x) == x) && + ((embedPow x) == x) && + ((embedDec x) == x) && + (((fromMaybe (error "twemid_crt") embedCRT) x) == x) \\ witness entailEqT x -- twace mhat'/g' = mhat*totm'/totm/g (Pow basis) -prop_twace_invar1_pow :: forall t m m' r . (TMM'RCtx t m m' r) +prop_twace_invar1_pow :: forall t m m' r . (TMM'RCtx t m m' r) => Test '(t,m,m',r) prop_twace_invar1_pow = test $ fromMaybe (error "could not divide by G in prop_twace_invar1_pow") $ do let mhat = proxy valueHatFact (Proxy::Proxy m) @@ -279,10 +270,6 @@ output = scalarCRT2 one :: t m r return $ (twacePowDec input) == output \\ proxy entailEqT (Proxy::Proxy (t m r)) - - - - type Tensors = '[CT,RT] type MRCombos = '[ '(F7, Zq 29), @@ -305,7 +292,7 @@ -- we can't include a large modulus here because there is not enough -- precision in Doubles to handle the error -type MRExtCombos = '[ +{-type MRExtCombos = '[ '(F7, Zq 29), '(F1, Zq 17), '(F2, Zq 17), @@ -316,7 +303,7 @@ '(F42, ZQ1), '(F42, ZQ2), '(F89, Zq 179) - ] + ]-} type MM'RCombos = '[ '(F1, F7, Zq 29), @@ -335,8 +322,14 @@ ] type TMRParams = ( '(,) <$> Tensors) <*> MRCombos -type ExtParams = ( '(,) <$> Tensors) <*> MRExtCombos +tmrParams :: Proxy TMRParams +tmrParams = Proxy + +--type ExtParams = ( '(,) <$> Tensors) <*> MRExtCombos type TrEmParams = ( '(,) <$> Tensors) <*> MM'RCombos +tremParams :: Proxy TrEmParams +tremParams = Proxy + type NormParams = ( '(,) <$> '[RT]) <*> (Filter Liftable MRCombos) data Liftable :: TyFun (Factored, *) Bool -> * diff --git a/tests/ZqTests.hs b/tests/ZqTests.hs --- a/tests/ZqTests.hs +++ b/tests/ZqTests.hs @@ -1,56 +1,47 @@ -{-# LANGUAGE NoImplicitPrelude, RebindableSyntax, ScopedTypeVariables, DataKinds, TypeOperators, PolyKinds, FlexibleContexts, RankNTypes, KindSignatures, MultiParamTypeClasses #-} +{-# LANGUAGE DataKinds, FlexibleContexts, NoImplicitPrelude, + ScopedTypeVariables, TypeOperators #-} module ZqTests (zqTests) where -import Crypto.Lol.Types.ZqBasic -import Crypto.Lol.LatticePrelude hiding (Nat) -import Crypto.Lol.Reflects - -import Control.Monad - -import GHC.TypeLits - -import Test.Framework -import Test.Framework.Providers.QuickCheck2 -import Test.QuickCheck - - -prop_add :: forall (q :: Nat) . (Reflects q Int, KnownNat q) => Proxy q -> Int -> Int -> Bool -prop_add _ x y = (fromIntegral $ x + y) == ((fromIntegral x) + (fromIntegral y :: ZqBasic q Int)) +import Apply.Zq +import Tests +import Utils -prop_mul :: forall (q :: Nat) . (Reflects q Int, KnownNat q) => Proxy q -> Int -> Int -> Bool -prop_mul _ x y = (fromIntegral $ x * y) == ((fromIntegral x) * (fromIntegral y :: ZqBasic q Int)) +import Crypto.Lol +import Crypto.Lol.CRTrans -prop_recip :: forall (q :: Nat) . (Reflects q Int, KnownNat q) => Proxy q -> Int -> Bool -prop_recip _ x = let qval = proxy value (Proxy::Proxy q) - y = fromIntegral x :: ZqBasic q Int - in if (x `mod` qval) == 0 - then True - else (fromIntegral (1::Int)) == (y * (recip y)) +import qualified Test.Framework as TF -type ZqModuli = '[7, 13, 17, 11, 13, 29] +zqTests :: [TF.Test] +zqTests = [ + testGroupM "(+)" $ applyBasic zqTypes $ hideArgs prop_add, + testGroupM "(*)" $ applyBasic zqTypes $ hideArgs prop_mul, + testGroupM "^-1" $ applyBasic zqTypes $ hideArgs prop_recip, + testGroupM "extension ring (*)" $ applyBasic zqTypes $ hideArgs prop_mul_ext + ] -class CallZqProp xs where - callProp :: Proxy xs -> Gen Int -> (forall (q :: Nat) . (Reflects q Int, KnownNat q) => Proxy q -> Int -> Int -> Bool) -> [Test] +prop_add :: forall r . (Ring r, Eq r) => LiftedMod r -> LiftedMod r -> Test r +prop_add (LMod x) (LMod y) = test $ fromIntegral (x + y) == (fromIntegral x + fromIntegral y :: r) - callProp2 :: Proxy xs - -> Gen Int - -> (forall (q :: Nat) . (Reflects q Int, KnownNat q) => Proxy q -> Int -> Bool) - -> [Test] +prop_mul :: forall r . (Ring r, Eq r) => LiftedInvertible r -> LiftedInvertible r -> Test r +prop_mul (LInv x) (LInv y) = test $ fromIntegral (x * y) == (fromIntegral x * fromIntegral y :: r) -instance CallZqProp '[] where - callProp _ _ _ = [] - callProp2 _ _ _ = [] +prop_recip :: forall r . (Field r, Eq r) => Invertible r -> Test r +prop_recip (Invertible x) = test $ one == (x * recip x) -instance (CallZqProp qs, KnownNat q) => CallZqProp (q ': qs) where - callProp _ gen f = (testProperty ("q = " ++ (show $ (proxy value (Proxy::Proxy q) :: Int))) $ property $ liftM2 (f (Proxy::Proxy q)) gen gen) : (callProp (Proxy::Proxy qs) gen f) - callProp2 _ gen f = (testProperty ("q = " ++ (show $ (proxy value (Proxy::Proxy q) :: Int))) $ property $ liftM (f (Proxy::Proxy q)) gen) : (callProp2 (Proxy::Proxy qs) gen f) +-- tests that multiplication in the extension ring matches CRT multiplication +prop_mul_ext :: forall r . (CRTEmbed r, Ring r, Eq r) + => Invertible r -> Invertible r -> Test r +prop_mul_ext (Invertible x) (Invertible y) = test $ + let z = x * y + z' = fromExt $ toExt x * toExt y + in z == z' -zqModuli :: Proxy ZqModuli -zqModuli = Proxy +type ZqTypes = [ + Zq 3, + Zq 7, + Zq (3 ** 5), + Zq (3 ** 5 ** 7)] -zqTests :: [Test] -zqTests = - [testGroup "ZqBasic +" $ callProp zqModuli (choose (-100,100)) prop_add, - testGroup "ZqBasic *" $ callProp zqModuli (choose (-100,100)) prop_mul, - testGroup "ZqBasic recip" $ callProp2 zqModuli (choose (-100,100)) prop_recip] +zqTypes :: Proxy ZqTypes +zqTypes = Proxy diff --git a/utils/Apply.hs b/utils/Apply.hs --- a/utils/Apply.hs +++ b/utils/Apply.hs @@ -1,17 +1,17 @@ -{-# LANGUAGE DataKinds, FlexibleInstances, MultiParamTypeClasses, PolyKinds, +{-# LANGUAGE DataKinds, FlexibleInstances, MultiParamTypeClasses, PolyKinds, TypeFamilies, TypeOperators #-} -- applies functions to proxy arguments module Apply where -class (params :: [k]) `Satisfy` (ctx :: *) where - data ArgsCtx ctx +-- not associated due to the generic instance below: +-- any definition of ArgsCtx would conflict with specific instances +data family ArgsCtx ctx +class (params :: [k]) `Satisfy` (ctx :: *) where run :: proxy params - -> (ArgsCtx ctx -> rnd res) + -> (ArgsCtx ctx -> rnd res) -> [rnd res] instance '[] `Satisfy` ctx where - -- any implementation of ArgsCtx would conflict with concrete instances, - -- so skip run _ _ = [] diff --git a/utils/Apply/Cyc.hs b/utils/Apply/Cyc.hs new file mode 100644 --- /dev/null +++ b/utils/Apply/Cyc.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module Apply.Cyc where + +import Control.DeepSeq +import Control.Monad.Random + +import Crypto.Lol +import Crypto.Lol.Cyclotomic.Tensor +import Crypto.Lol.Types.ZPP +import Crypto.Random.DRBG + +import Apply +import GenArgs +import Utils + +data BasicCtxD +type BasicCtx t m r = + (CElt t r, Fact m, IntegralDomain r, Random r, Eq r, NFElt r, ShowType '(t,m,r), Random (t m r), m `Divides` m, NFData (t m r)) +data instance ArgsCtx BasicCtxD where + BC :: (BasicCtx t m r, BasicCtx t m (r,r)) => Proxy '(t,m,r) -> ArgsCtx BasicCtxD +instance (params `Satisfy` BasicCtxD, BasicCtx t m r, BasicCtx t m (r,r)) + => ( '(t, '(m,r)) ': params) `Satisfy` BasicCtxD where + run _ f = f (BC (Proxy::Proxy '(t,m,r))) : run (Proxy::Proxy params) f + +applyBasic :: (params `Satisfy` BasicCtxD, MonadRandom rnd) => + Proxy params + -> (forall t m r . (BasicCtx t m r, BasicCtx t m (r,r), Generatable rnd r, Generatable rnd (t m r)) + => Proxy '(t,m,r) -> rnd res) + -> [rnd res] +applyBasic params g = run params $ \(BC p) -> g p + +-- r is Liftable +data LiftCtxD +type LiftCtx t m r = + (BasicCtx t m r, Lift' r, CElt t (LiftOf r), NFElt (LiftOf r), ToInteger (LiftOf r), + TElt CT r, TElt RT r, TElt CT (LiftOf r), TElt RT (LiftOf r)) +data instance ArgsCtx LiftCtxD where + LC :: (LiftCtx t m r) => Proxy '(t,m,r) -> ArgsCtx LiftCtxD +instance (params `Satisfy` LiftCtxD, LiftCtx t m r) + => ( '(t, '(m,r)) ': params) `Satisfy` LiftCtxD where + run _ f = f (LC (Proxy::Proxy '(t,m,r))) : run (Proxy::Proxy params) f + +applyLift :: (params `Satisfy` LiftCtxD, MonadRandom rnd) => + Proxy params + -> (forall t m r . (LiftCtx t m r, Generatable rnd r) => Proxy '(t,m,r) -> rnd res) + -> [rnd res] +applyLift params g = run params $ \(LC p) -> g p + +-- similar to LiftCtxD, but with a `gen` param +data ErrorCtxD +type ErrorCtx t m r gen = (CElt t r, Fact m, ShowType '(t,m,r,gen), + CElt t (LiftOf r), NFElt (LiftOf r), Lift' r, + ToInteger (LiftOf r), CryptoRandomGen gen) +data instance ArgsCtx ErrorCtxD where + EC :: (ErrorCtx t m r gen) => Proxy '(t,m,r,gen) -> ArgsCtx ErrorCtxD +instance (params `Satisfy` ErrorCtxD, ErrorCtx t m r gen) + => ( '(gen, '(t, '(m,r))) ': params) `Satisfy` ErrorCtxD where + run _ f = f (EC (Proxy::Proxy '(t,m,r,gen))) : run (Proxy::Proxy params) f + +applyError :: (params `Satisfy` ErrorCtxD, Monad rnd) => + Proxy params + -> (forall t m r gen . (ErrorCtx t m r gen) => Proxy '(t,m,r,gen) -> rnd res) + -> [rnd res] +applyError params g = run params $ \(EC p) -> g p + + +data TwoIdxCtxD +type TwoIdxCtx t m m' r = (m `Divides` m', CElt t r, IntegralDomain r, Eq r, Random r, NFElt r, + ShowType '(t,m,m',r), Random (t m r), Random (t m' r)) +data instance ArgsCtx TwoIdxCtxD where + TI :: (TwoIdxCtx t m m' r) => Proxy '(t,m,m',r) -> ArgsCtx TwoIdxCtxD +instance (params `Satisfy` TwoIdxCtxD, TwoIdxCtx t m m' r) + => ( '(t, '(m,m',r)) ': params) `Satisfy` TwoIdxCtxD where + run _ f = f (TI (Proxy::Proxy '(t,m,m',r))) : run (Proxy::Proxy params) f + +applyTwoIdx :: (params `Satisfy` TwoIdxCtxD, MonadRandom rnd) => + Proxy params + -> (forall t m m' r . (TwoIdxCtx t m m' r, Generatable rnd (t m r), Generatable rnd (t m' r)) + => Proxy '(t,m,m',r) -> rnd res) + -> [rnd res] +applyTwoIdx params g = run params $ \(TI p) -> g p + +-- similar to TwoIdxCtxD, but r must be a prime-power +data BasisCtxD +type BasisCtx t m m' r = (m `Divides` m', Eq r, ZPP r, CElt t r, CElt t (ZpOf r), ShowType '(t,m,m',r)) +data instance ArgsCtx BasisCtxD where + BsC :: (BasisCtx t m m' r) => Proxy '(t,m,m',r) -> ArgsCtx BasisCtxD +instance (params `Satisfy` BasisCtxD, BasisCtx t m m' r) + => ( '(t, '(m,m',r)) ': params) `Satisfy` BasisCtxD where + run _ f = f (BsC (Proxy::Proxy '(t,m,m',r))) : run (Proxy::Proxy params) f + +applyBasis :: (params `Satisfy` BasisCtxD) => + Proxy params + -> (forall t m m' r . (BasisCtx t m m' r) => Proxy '(t,m,m',r) -> rnd res) + -> [rnd res] +applyBasis params g = run params $ \(BsC p) -> g p diff --git a/utils/Apply/Zq.hs b/utils/Apply/Zq.hs new file mode 100644 --- /dev/null +++ b/utils/Apply/Zq.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE ConstraintKinds, DataKinds, FlexibleContexts, FlexibleInstances, + GADTs, MultiParamTypeClasses, NoImplicitPrelude, RankNTypes, + RebindableSyntax, ScopedTypeVariables, TypeFamilies, TypeOperators, + UndecidableInstances #-} + +module Apply.Zq +(applyBasic +,LiftedMod(..) +,LiftedInvertible(..) +,Invertible(..)) where + +import Apply +import GenArgs +import GenArgs.Zq +import Utils + +import Control.Monad.Random + +import Crypto.Lol +import Crypto.Lol.CRTrans + +data BasicCtxD +type BasicCtx r = + (Field r, Eq r, Random r, Random (ModRep r), ToInteger (ModRep r), + PID (ModRep r), ShowType r, CRTEmbed r, Mod r) +data instance ArgsCtx BasicCtxD where + BC :: (BasicCtx r) => Proxy r -> ArgsCtx BasicCtxD +instance (params `Satisfy` BasicCtxD, BasicCtx r) + => ( r ': params) `Satisfy` BasicCtxD where + run _ f = f (BC (Proxy::Proxy r)) : run (Proxy::Proxy params) f + +applyBasic :: (params `Satisfy` BasicCtxD, MonadRandom rnd) => + Proxy params + -> (forall r . (BasicCtx r, Generatable rnd r, Generatable rnd (Invertible r)) + => Proxy r -> rnd res) + -> [rnd res] +applyBasic params g = run params $ \(BC p) -> g p diff --git a/utils/Benchmarks.hs b/utils/Benchmarks.hs --- a/utils/Benchmarks.hs +++ b/utils/Benchmarks.hs @@ -1,7 +1,7 @@ -{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, +{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, PolyKinds, RankNTypes, ScopedTypeVariables, TypeFamilies #-} -module Benchmarks +module Benchmarks (Benchmarks.bench ,benchIO ,benchGroup @@ -10,12 +10,10 @@ ,Benchmark ,NFData) where -import Gen +import GenArgs import Utils import Control.DeepSeq -import Control.Monad.Random -import Control.Monad.State import Criterion as C import Data.Proxy @@ -28,11 +26,11 @@ benchIO :: NFData b => IO b -> Bench params benchIO = Bench . nfIO --- wrapper for Criterion's +-- wrapper for Criterion's benchGroup :: (Monad rnd) => String -> [rnd Benchmark] -> rnd Benchmark benchGroup str = (bgroup str <$>) . sequence --- normalizes any function resulting in a Benchmark to +-- normalizes any function resulting in a Benchmark to -- one that takes a proxy for its arguments hideArgs :: (GenArgs rnd bnch, Monad rnd, ShowType a, ResultOf bnch ~ Bench a) diff --git a/utils/Gen.hs b/utils/Gen.hs deleted file mode 100644 --- a/utils/Gen.hs +++ /dev/null @@ -1,27 +0,0 @@ -{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TypeFamilies #-} - --- generates arguments to functions -module Gen where - -import Control.Monad.Random - --- bnch represents a function whose arguments can be generated, --- resulting in a "NFValue" -class GenArgs rnd bnch where - type ResultOf bnch - genArgs :: bnch -> rnd (ResultOf bnch) - -instance (Generatable rnd a, GenArgs rnd b, - Monad rnd, ResultOf b ~ ResultOf (a -> b)) - => GenArgs rnd (a -> b) where - type ResultOf (a -> b) = ResultOf b - genArgs f = do - x <- genArg - genArgs $ f x - --- a parameter that can be generated using a particular monad -class Generatable rnd arg where - genArg :: rnd arg - -instance {-# Overlappable #-} (Random a, MonadRandom rnd) => Generatable rnd a where - genArg = getRandom diff --git a/utils/GenArgs.hs b/utils/GenArgs.hs new file mode 100644 --- /dev/null +++ b/utils/GenArgs.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TypeFamilies #-} + +-- generates arguments to functions +module GenArgs where + +import Control.Monad.Random +import Data.Proxy + +-- bnch represents a function whose arguments can be generated, +-- resulting in a "NFValue" +class GenArgs rnd bnch where + type ResultOf bnch + genArgs :: bnch -> rnd (ResultOf bnch) + +instance (Generatable rnd a, GenArgs rnd b, + Monad rnd, ResultOf b ~ ResultOf (a -> b)) + => GenArgs rnd (a -> b) where + type ResultOf (a -> b) = ResultOf b + genArgs f = do + x <- genArg + genArgs $ f x + +-- a parameter that can be generated using a particular monad +class Generatable rnd arg where + genArg :: rnd arg + +instance {-# Overlappable #-} (Random a, MonadRandom rnd) => Generatable rnd a where + genArg = getRandom + +instance (Monad rnd) => Generatable rnd (Proxy a) where + genArg = return Proxy diff --git a/utils/GenArgs/Zq.hs b/utils/GenArgs/Zq.hs new file mode 100644 --- /dev/null +++ b/utils/GenArgs/Zq.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE FlexibleContexts, FlexibleInstances, GADTs, MultiParamTypeClasses, + NoImplicitPrelude, RebindableSyntax, ScopedTypeVariables, + UndecidableInstances #-} + +module GenArgs.Zq where + +import GenArgs + +import Control.Applicative +import Control.Monad.Random + +import Crypto.Lol + +data LiftedMod r where + LMod :: (ToInteger (ModRep r)) => ModRep r -> LiftedMod r + +data LiftedInvertible r where + LInv :: (ToInteger (ModRep r)) => ModRep r -> LiftedInvertible r + +newtype Invertible r = Invertible r + +instance (MonadRandom rnd, Mod r, Random (ModRep r), ToInteger (ModRep r)) + => Generatable rnd (LiftedMod r) where + genArg = + let q = proxy modulus (Proxy::Proxy r) + in LMod <$> getRandomR (0,q-1) + +instance (MonadRandom rnd, Mod r, Random (ModRep r), PID (ModRep r), ToInteger (ModRep r)) + => Generatable rnd (LiftedInvertible r) where + genArg = + let q = proxy modulus (Proxy::Proxy r) + go = do + x <- getRandomR (1,q-1) + if gcd x q == 1 + then return $ LInv x + else go + in go + +instance (MonadRandom rnd, Generatable rnd (LiftedInvertible r), Ring r) + => Generatable rnd (Invertible r) where + genArg = do + (LInv x) :: LiftedInvertible r <- genArg + return $ Invertible $ fromIntegral x diff --git a/utils/Harness/Cyc.hs b/utils/Harness/Cyc.hs deleted file mode 100644 --- a/utils/Harness/Cyc.hs +++ /dev/null @@ -1,102 +0,0 @@ -{-# LANGUAGE ConstraintKinds, DataKinds, FlexibleContexts, FlexibleInstances, - GADTs, MultiParamTypeClasses, NoImplicitPrelude, PolyKinds, RankNTypes, - ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-} - -module Harness.Cyc where - -import Control.Applicative -import Control.Monad.Random - -import Crypto.Lol -import Crypto.Lol.Cyclotomic.Tensor -import Crypto.Lol.Types.ZPP -import Crypto.Random.DRBG - -import Data.Vector.Storable - -import Utils -import Gen -import Apply - -data BasicCtxD -type BasicCtx t m r = - (CElt t r, Fact m, Random r, Eq r, NFElt r, ShowType '(t,m,r), Random (t m r), m `Divides` m) -instance (params `Satisfy` BasicCtxD, BasicCtx t m r) - => ( '(t, '(m,r)) ': params) `Satisfy` BasicCtxD where - data ArgsCtx BasicCtxD where - BC :: (BasicCtx t m r) => Proxy '(t,m,r) -> ArgsCtx BasicCtxD - run _ f = (f $ BC (Proxy::Proxy '(t,m,r))) : (run (Proxy::Proxy params) f) - -applyBasic :: (params `Satisfy` BasicCtxD, MonadRandom rnd) => - Proxy params - -> (forall t m r . (BasicCtx t m r, Generatable rnd r, Generatable rnd (t m r)) - => Proxy '(t,m,r) -> rnd res) - -> [rnd res] -applyBasic params g = run params $ \(BC p) -> g p - --- r is Liftable -data LiftCtxD -type LiftCtx t m r = - (BasicCtx t m r, Lift' r, CElt t (LiftOf r), NFElt (LiftOf r), ToInteger (LiftOf r), - TElt CT r, TElt RT r, TElt CT (LiftOf r), TElt RT (LiftOf r)) -instance (params `Satisfy` LiftCtxD, LiftCtx t m r) - => ( '(t, '(m,r)) ': params) `Satisfy` LiftCtxD where - data ArgsCtx LiftCtxD where - LC :: (LiftCtx t m r) => Proxy '(t,m,r) -> ArgsCtx LiftCtxD - run _ f = (f $ LC (Proxy::Proxy '(t,m,r))) : (run (Proxy::Proxy params) f) - -applyLift :: (params `Satisfy` LiftCtxD, MonadRandom rnd) => - Proxy params - -> (forall t m r . (LiftCtx t m r, Generatable rnd r) => Proxy '(t,m,r) -> rnd res) - -> [rnd res] -applyLift params g = run params $ \(LC p) -> g p - --- similar to LiftCtxD, but with a `gen` param -data ErrorCtxD -type ErrorCtx t m r gen = (CElt t r, Fact m, ShowType '(t,m,r,gen), - CElt t (LiftOf r), NFElt (LiftOf r), Lift' r, - ToInteger (LiftOf r), CryptoRandomGen gen) -instance (params `Satisfy` ErrorCtxD, ErrorCtx t m r gen) - => ( '(gen, '(t, '(m,r))) ': params) `Satisfy` ErrorCtxD where - data ArgsCtx ErrorCtxD where - EC :: (ErrorCtx t m r gen) => Proxy '(t,m,r,gen) -> ArgsCtx ErrorCtxD - run _ f = (f $ EC (Proxy::Proxy '(t,m,r,gen))) : (run (Proxy::Proxy params) f) - -applyError :: (params `Satisfy` ErrorCtxD, Monad rnd) => - Proxy params - -> (forall t m r gen . (ErrorCtx t m r gen) => Proxy '(t,m,r,gen) -> rnd res) - -> [rnd res] -applyError params g = run params $ \(EC p) -> g p - - -data TwoIdxCtxD -type TwoIdxCtx t m m' r = (m `Divides` m', CElt t r, Eq r, Random r, NFElt r, ShowType '(t,m,m',r), Random (t m r), Random (t m' r)) - -instance (params `Satisfy` TwoIdxCtxD, TwoIdxCtx t m m' r) - => ( '(t, '(m,m',r)) ': params) `Satisfy` TwoIdxCtxD where - data ArgsCtx TwoIdxCtxD where - TI :: (TwoIdxCtx t m m' r) => Proxy '(t,m,m',r) -> ArgsCtx TwoIdxCtxD - run _ f = (f $ TI (Proxy::Proxy '(t,m,m',r))) : (run (Proxy::Proxy params) f) - -applyTwoIdx :: (params `Satisfy` TwoIdxCtxD, MonadRandom rnd) => - Proxy params - -> (forall t m m' r . (TwoIdxCtx t m m' r, Generatable rnd (t m r), Generatable rnd (t m' r)) - => Proxy '(t,m,m',r) -> rnd res) - -> [rnd res] -applyTwoIdx params g = run params $ \(TI p) -> g p - --- similar to TwoIdxCtxD, but r must be a prime-power -data BasisCtxD -type BasisCtx t m m' r = (m `Divides` m', Eq r, ZPP r, CElt t r, CElt t (ZpOf r), ShowType '(t,m,m',r)) - -instance (params `Satisfy` BasisCtxD, BasisCtx t m m' r) - => ( '(t, '(m,m',r)) ': params) `Satisfy` BasisCtxD where - data ArgsCtx BasisCtxD where - BsC :: (BasisCtx t m m' r) => Proxy '(t,m,m',r) -> ArgsCtx BasisCtxD - run _ f = (f $ BsC (Proxy::Proxy '(t,m,m',r))) : (run (Proxy::Proxy params) f) - -applyBasis :: (params `Satisfy` BasisCtxD) => - Proxy params - -> (forall t m m' r . (BasisCtx t m m' r) => Proxy '(t,m,m',r) -> rnd res) - -> [rnd res] -applyBasis params g = run params $ \(BsC p) -> g p diff --git a/utils/TestTypes.hs b/utils/TestTypes.hs --- a/utils/TestTypes.hs +++ b/utils/TestTypes.hs @@ -1,18 +1,17 @@ {-# LANGUAGE ConstraintKinds, DataKinds, FlexibleContexts, - FlexibleInstances, KindSignatures, MultiParamTypeClasses, + FlexibleInstances, MultiParamTypeClasses, NoImplicitPrelude, PolyKinds, RankNTypes, RebindableSyntax, ScopedTypeVariables, TypeFamilies, TypeOperators #-} -module TestTypes ( - -SmoothZQ1, SmoothZQ2, SmoothZQ3 -, Zq, ZQ1, ZQ2, ZQ3) where +module TestTypes +(SmoothQ1, SmoothQ2, SmoothQ3 +,SmoothZQ1, SmoothZQ2, SmoothZQ3 +,Zq +,ZQ1,ZQ2,ZQ3) where -import Control.Monad import Control.Monad.Random import Crypto.Lol -import Crypto.Lol.Reflects import Utils diff --git a/utils/Tests.hs b/utils/Tests.hs --- a/utils/Tests.hs +++ b/utils/Tests.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleContexts, FlexibleInstances, GADTs, MultiParamTypeClasses, +{-# LANGUAGE FlexibleContexts, FlexibleInstances, GADTs, MultiParamTypeClasses, PolyKinds, RankNTypes, ScopedTypeVariables, TypeFamilies #-} module Tests (test @@ -8,17 +8,15 @@ ,hideArgs ,Test(..)) where -import Gen +import GenArgs import Utils import Control.Monad.Random -import Control.Monad.State import Data.Proxy import qualified Test.Framework as TF import Test.Framework.Providers.QuickCheck2 -import Test.QuickCheck test :: Bool -> Test params test = Test @@ -29,7 +27,7 @@ testGroupM :: String -> [IO TF.Test] -> TF.Test testGroupM str = TF.buildTest . (TF.testGroup str <$>) . sequence --- normalizes any function resulting in a Benchmark to +-- normalizes any function resulting in a Benchmark to -- one that takes a proxy for its arguments hideArgs :: (GenArgs rnd bnch, MonadRandom rnd, ShowType a, ResultOf bnch ~ Test a) diff --git a/utils/Utils.hs b/utils/Utils.hs --- a/utils/Utils.hs +++ b/utils/Utils.hs @@ -1,10 +1,9 @@ -{-# LANGUAGE DataKinds, FlexibleContexts, FlexibleInstances, GADTs, - GeneralizedNewtypeDeriving, MultiParamTypeClasses, - PolyKinds, RankNTypes, ConstraintKinds, ScopedTypeVariables, - KindSignatures, - TypeFamilies, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE ConstraintKinds, DataKinds, FlexibleContexts, FlexibleInstances, + GADTs, KindSignatures, MultiParamTypeClasses, PolyKinds, + RankNTypes, ScopedTypeVariables, TypeFamilies, TypeOperators, + UndecidableInstances #-} -module Utils +module Utils (Zq ,type (**) ,type (<$>) @@ -15,13 +14,7 @@ ,showType ,ShowType) where -import Control.Monad.Random -import Control.Monad (liftM) -import Control.Monad.State - -import Control.DeepSeq - -import Crypto.Lol (Int64,Fact,Factored,valueFact,Mod(..), Proxy(..), proxy, Cyc, RT, CT, LiftOf, TrivGad, BaseBGad) +import Crypto.Lol (Int64,Fact,valueFact,Mod(..), Proxy(..), proxy, RT, CT, TrivGad, BaseBGad) import Crypto.Lol.Reflects import Crypto.Lol.Types.ZqBasic import Crypto.Random.DRBG @@ -78,10 +71,10 @@ show _ = "HashDRBG" instance (Fact m) => Show (ArgType m) where - show _ = "F" ++ (show $ proxy valueFact (Proxy::Proxy m)) + show _ = "F" ++ show (proxy valueFact (Proxy::Proxy m)) instance (Mod (ZqBasic q i), Show i) => Show (ArgType (ZqBasic q i)) where - show _ = "Q" ++ (show $ proxy modulus (Proxy::Proxy (ZqBasic q i))) + show _ = "Q" ++ show (proxy modulus (Proxy::Proxy (ZqBasic q i))) instance Show (ArgType RT) where show _ = "RT" @@ -96,38 +89,38 @@ show _ = "TrivGad" instance (Reflects b Integer) => Show (ArgType (BaseBGad (b :: k))) where - show _ = "Base" ++ (show $ (proxy value (Proxy::Proxy b) :: Integer)) ++ "Gad" + show _ = "Base" ++ show (proxy value (Proxy::Proxy b) :: Integer) ++ "Gad" -- for RNS-style moduli instance (Show (ArgType a), Show (ArgType b)) => Show (ArgType (a,b)) where - show _ = (show (AT :: ArgType a)) ++ "*" ++ (show (AT :: ArgType b)) + show _ = show (AT :: ArgType a) ++ "*" ++ show (AT :: ArgType b) -- we use tuples rather than lists because types in a list must have the same kind, -- but tuples permit different kinds -instance (Show (ArgType a), Show (ArgType b)) +instance (Show (ArgType a), Show (ArgType b)) => Show (ArgType '(a,b)) where - show _ = (show (AT :: ArgType a)) ++ " " ++ (show (AT :: ArgType b)) + show _ = show (AT :: ArgType a) ++ " " ++ show (AT :: ArgType b) -instance (Show (ArgType a), Show (ArgType '(b,c))) +instance (Show (ArgType a), Show (ArgType '(b,c))) => Show (ArgType '(a,b,c)) where - show _ = (show (AT :: ArgType a)) ++ " " ++ (show (AT :: ArgType '(b,c))) + show _ = show (AT :: ArgType a) ++ " " ++ show (AT :: ArgType '(b,c)) -instance (Show (ArgType a), Show (ArgType '(b,c,d))) +instance (Show (ArgType a), Show (ArgType '(b,c,d))) => Show (ArgType '(a,b,c,d)) where - show _ = (show (AT :: ArgType a)) ++ " " ++ (show (AT :: ArgType '(b,c,d))) + show _ = show (AT :: ArgType a) ++ " " ++ show (AT :: ArgType '(b,c,d)) -instance (Show (ArgType a), Show (ArgType '(b,c,d,e))) +instance (Show (ArgType a), Show (ArgType '(b,c,d,e))) => Show (ArgType '(a,b,c,d,e)) where - show _ = (show (AT :: ArgType a)) ++ " " ++ (show (AT :: ArgType '(b,c,d,e))) + show _ = show (AT :: ArgType a) ++ " " ++ show (AT :: ArgType '(b,c,d,e)) -instance (Show (ArgType a), Show (ArgType '(b,c,d,e,f))) +instance (Show (ArgType a), Show (ArgType '(b,c,d,e,f))) => Show (ArgType '(a,b,c,d,e,f)) where - show _ = (show (AT :: ArgType a)) ++ " " ++ (show (AT :: ArgType '(b,c,d,e,f))) + show _ = show (AT :: ArgType a) ++ " " ++ show (AT :: ArgType '(b,c,d,e,f)) -instance (Show (ArgType a), Show (ArgType '(b,c,d,e,f,g))) +instance (Show (ArgType a), Show (ArgType '(b,c,d,e,f,g))) => Show (ArgType '(a,b,c,d,e,f,g)) where - show _ = (show (AT :: ArgType a)) ++ " " ++ (show (AT :: ArgType '(b,c,d,e,f,g))) + show _ = show (AT :: ArgType a) ++ " " ++ show (AT :: ArgType '(b,c,d,e,f,g)) -instance (Show (ArgType a), Show (ArgType '(b,c,d,e,f,g,h))) +instance (Show (ArgType a), Show (ArgType '(b,c,d,e,f,g,h))) => Show (ArgType '(a,b,c,d,e,f,g,h)) where - show _ = (show (AT :: ArgType a)) ++ " " ++ (show (AT :: ArgType '(b,c,d,e,f,g,h))) + show _ = show (AT :: ArgType a) ++ " " ++ show (AT :: ArgType '(b,c,d,e,f,g,h))