diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,6 +1,15 @@ Changelog for lol project ================================ +0.2.0.0 +----- + * Added benchmarks + * Better performance for C backend with RNS base ring + * UCyc exposes bases as type for safety + * Other safety improvements throughout + * Easier index representation with TemplateHaskell + * Split SymmSHE into new package lol-apps. + 0.1.0.0 ----- * Fixed bug in Box-Muller sampling routine. diff --git a/Crypto/Lol.hs b/Crypto/Lol.hs new file mode 100644 --- /dev/null +++ b/Crypto/Lol.hs @@ -0,0 +1,21 @@ + +-- | 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 + +import Crypto.Lol.Cyclotomic.Cyc +import Crypto.Lol.Gadget +import Crypto.Lol.LatticePrelude + +import Crypto.Lol.Types.ZqBasic +import Crypto.Lol.Cyclotomic.Tensor.CTensor +import Crypto.Lol.Cyclotomic.Tensor.RepaTensor +import Crypto.Lol.Types.IrreducibleChar2 diff --git a/Crypto/Lol/CRTrans.hs b/Crypto/Lol/CRTrans.hs new file mode 100644 --- /dev/null +++ b/Crypto/Lol/CRTrans.hs @@ -0,0 +1,138 @@ +{-# LANGUAGE FlexibleContexts, FlexibleInstances, RebindableSyntax, + ScopedTypeVariables, TypeFamilies #-} + +-- | Classes and helper methods for the Chinese remainder transform +-- and ring extensions. + +module Crypto.Lol.CRTrans +( CRTrans(..), CRTEmbed(..) +, CRTInfo +, crtInfoFact, crtInfoPPow, crtInfoPrime +, gEmbPPow, gEmbPrime +) where + +import Crypto.Lol.LatticePrelude + +import Control.Arrow +import Data.Singletons +import Data.Singletons.Prelude + +-- | Information that characterizes the (invertible) Chinese remainder +-- transformation over a ring @r@, namely: +-- +-- (1) a function that returns the @i@th power of some /principal/ +-- @m@th root of unity (for any integer @i@) +-- +-- (2) the multiplicative inverse of @\\hat{m}@ in @r@. + +type CRTInfo r = (Int -> r, r) + +-- | A ring that (possibly) supports invertible Chinese remainder +-- transformations of various indices. + +-- | 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'@. + +class Ring r => CRTrans 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 + +-- | A ring with a ring embedding into some ring @CRTExt r@ that has +-- an invertible CRT transformation for /every/ positive index @m@. +class (Ring r, Ring (CRTExt r)) => CRTEmbed r where + type CRTExt r + + -- | Embeds from @r@ to @CRTExt r@ + toExt :: r -> CRTExt r + -- | 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)) + +-- CRTEmbed instance for product rings +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 + +-- | 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) + +-- 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) + +-- trivial CRTEmbed instance for complex numbers +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 +-- 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. +instance CRTEmbed Double where + type CRTExt Double = Complex Double + toExt = fromReal . realToField + fromExt = realToField . real + +instance CRTEmbed Int where + type CRTExt Int = Complex Double + toExt = fromIntegral + fromExt = fst . roundComplex + +instance CRTEmbed Int64 where + type CRTExt Int64 = Complex Double + toExt = fromIntegral + fromExt = fst . roundComplex + +instance CRTEmbed Integer where + -- CJP: sufficient precision? Not in general. + type CRTExt Integer = Complex Double + toExt = fromIntegral + fromExt = fst . roundComplex diff --git a/Crypto/Lol/Cyclotomic/Cyc.hs b/Crypto/Lol/Cyclotomic/Cyc.hs new file mode 100644 --- /dev/null +++ b/Crypto/Lol/Cyclotomic/Cyc.hs @@ -0,0 +1,583 @@ +{-# LANGUAGE ConstraintKinds, DataKinds, FlexibleContexts, + FlexibleInstances, GADTs, MultiParamTypeClasses, + NoImplicitPrelude, PolyKinds, RankNTypes, ScopedTypeVariables, + TypeFamilies, TypeOperators, UndecidableInstances #-} + +-- | An implementation of cyclotomic rings that hides the +-- internal representations of ring elements (e.g., the choice of +-- basis), and also offers more efficient storage and operations on +-- subring elements (including elements from the base ring itself). +-- +-- For an implementation that allows (and requires) the programmer to +-- control the underlying representation, see +-- 'Crypto.Lol.Cyclotomic.UCyc.UCyc'. +-- +-- __WARNING:__ as with all fixed-point arithmetic, the functions +-- associated with 'Cyc' may result in overflow (and thereby +-- incorrect answers and potential security flaws) if the input +-- arguments are too close to the bounds imposed by the base type. +-- The acceptable range of inputs for each function is determined by +-- the internal linear transforms and other operations it performs. + +module Crypto.Lol.Cyclotomic.Cyc +( +-- * Data type and constraints + Cyc, CElt, U.NFElt +-- * Constructors/deconstructors +, cycPow, cycDec, cycCRT, scalarCyc +, uncycPow, uncycDec, uncycCRT, unzipCyc, unzipCElt +-- * Core cyclotomic operations +, mulG, divG, gSqNorm, liftCyc, liftPow, liftDec +-- * Representation advice +, advisePow, adviseDec, adviseCRT +-- * Error sampling +, tGaussian, errorRounded, errorCoset +-- * Sub/extension rings +, embed, twace, coeffsCyc, powBasis, crtSet +-- * Rescaling cyclotomic elements +, R.RescaleCyc(..), R.Basis(..) +) where + +import qualified Algebra.Additive as Additive (C) +import qualified Algebra.Module as Module (C) +import qualified Algebra.Ring as Ring (C) +import qualified Algebra.ZeroTestable as ZeroTestable (C) + +import Crypto.Lol.Cyclotomic.UCyc hiding (coeffsDec, coeffsPow, crtSet, + divG, errorCoset, errorRounded, gSqNorm, + mulG, powBasis, tGaussian, unzipCyc) + +import Crypto.Lol.CRTrans +import qualified Crypto.Lol.Cyclotomic.RescaleCyc as R +import Crypto.Lol.Cyclotomic.Tensor (CRTElt, TElt, Tensor) +import qualified Crypto.Lol.Cyclotomic.UCyc as U +import Crypto.Lol.Gadget +import Crypto.Lol.LatticePrelude as LP +import Crypto.Lol.Types.FiniteField +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.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 +-- cyclotomic index; @r@ is the base ring of the coefficients (e.g., +-- @Z@, @Zq@). +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 + -- 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 + +---------- Constructors / deconstructors ---------- + +-- | Wrap a 'UCyc' as a 'Cyc'. +cycPow :: UCyc t m P r -> Cyc t m r +cycPow = Pow +{-# INLINABLE cycPow #-} + +-- | Wrap a 'UCyc' as a 'Cyc'. +cycDec :: UCyc t m D r -> Cyc t m r +cycDec = Dec +{-# INLINABLE cycDec #-} + +-- | Wrap a 'UCyc' as a 'Cyc'. +cycCRT :: UCyc t m C r -> Cyc t m r +cycCRT = CRT +{-# INLINABLE cycCRT #-} + +-- | Embed a scalar from the base ring as a cyclotomic element. +scalarCyc :: r -> Cyc t m r +scalarCyc = Scalar +{-# INLINABLE scalarCyc #-} + +-- | Unwrap a 'Cyc' as a 'UCyc' in powerful-basis representation. +uncycPow :: (Fact m, CElt t r) => Cyc t m r -> UCyc t m P r +{-# INLINABLE uncycPow #-} +uncycPow c = let (Pow u) = toPow' c in u + +-- | Unwrap a 'Cyc' as a 'UCyc' in decoding-basis representation. +uncycDec :: (Fact m, CElt t r) => Cyc t m r -> UCyc t m D r +{-# 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 +{-# INLINABLE uncycCRT #-} +uncycCRT c = let (CRT u) = toCRT' c in u + +---------- Algebraic instances ---------- + +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 (Scalar c) = isZero c + isZero (Sub c) = isZero c + {-# INLINABLE isZero #-} + +instance (Eq r, Fact m, CElt t r) => Eq (Cyc t m r) where + -- same representations + (Scalar c1) == (Scalar c2) = c1 == c2 + (Pow u1) == (Pow u2) = u1 == u2 + (Dec u1) == (Dec u2) = u1 == u2 + (CRT u1) == (CRT u2) = u1 == u2 + -- compare Subs in compositum + (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 + c1 == c2 = toPow' c1 == toPow' c2 + + {-# INLINABLE (==) #-} + +instance (Fact m, CElt t r) => Additive.C (Cyc t m r) where + {-# INLINABLE zero #-} + zero = Scalar zero + + {-# INLINABLE (+) #-} + -- optimized addition of zero + (Scalar c1) + c2 | isZero c1 = c2 + c1 + (Scalar c2) | isZero c2 = c1 + + -- SAME CONSTRUCTORS + (Scalar c1) + (Scalar c2) = Scalar (c1+c2) + (Pow u1) + (Pow u2) = Pow $ u1 + u2 + (Dec u1) + (Dec u2) = Dec $ u1 + u2 + (CRT u1) + (CRT u2) = CRT $ u1 + u2 + -- Sub plus Sub: work in compositum + (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) + + -- SCALAR PLUS SOMETHING ELSE + + (Scalar c) + (Pow u) = Pow $ scalarPow c + u + (Scalar c) + (Dec u) = Pow $ scalarPow c + toPow u -- workaround scalarDec + (Scalar c) + (CRT u) = CRT $ scalarCRT c + u + (Scalar c1) + (Sub c2) = Sub $ Scalar c1 + c2 -- must re-wrap Scalar! + + (Pow u) + (Scalar c) = Pow $ u + scalarPow c + (Dec u) + (Scalar c) = Pow $ toPow u + scalarPow c -- workaround scalarDec + (CRT u) + (Scalar c) = CRT $ u + scalarCRT c + (Sub c1) + (Scalar c2) = Sub $ c1 + Scalar c2 + + -- SUB PLUS NON-SUB, NON-SCALAR: work in full ring + (Sub c1) + c2 = embed' c1 + c2 + c1 + (Sub c2) = c1 + embed' c2 + + -- mixed Dec and Pow: use linear-time conversions + (Dec u1) + (Pow u2) = Pow $ toPow u1 + u2 + (Pow u1) + (Dec u2) = Pow $ u1 + toPow u2 + + -- one CRT: convert other to CRT + (CRT u1) + (Pow u2) = CRT $ u1 + toCRT u2 + (CRT u1) + (Dec u2) = CRT $ u1 + toCRT u2 + (Pow u1) + (CRT u2) = CRT $ toCRT u1 + u2 + (Dec u1) + (CRT u2) = CRT $ toCRT u1 + u2 + + {-# INLINABLE negate #-} + negate (Pow u) = Pow $ negate u + negate (Dec u) = Dec $ negate u + negate (CRT u) = CRT $ negate u + negate (Scalar c) = Scalar (negate c) + negate (Sub c) = Sub $ negate c + +instance (Fact m, CElt t r) => Ring.C (Cyc t m r) where + {-# INLINABLE one #-} + one = Scalar one + + {-# INLINABLE fromInteger #-} + fromInteger = Scalar . fromInteger + + {-# INLINABLE (*) #-} + + -- optimized mul-by-zero + v1@(Scalar c1) * _ | isZero c1 = v1 + _ * v2@(Scalar c2) | isZero c2 = v2 + + -- both CRT + (CRT u1) * (CRT u2) = CRT $ u1*u2 + + -- at least one Scalar + (Scalar c1) * (Scalar c2) = Scalar $ c1*c2 + (Scalar c) * (Pow u) = Pow $ c *> u + (Scalar c) * (Dec u) = Dec $ c *> u + (Scalar c) * (CRT u) = CRT $ c *> u + (Scalar c1) * (Sub c2) = Sub $ Scalar c1 * c2 + + (Pow u) * (Scalar c) = Pow $ c *> u + (Dec u) * (Scalar c) = Dec $ c *> u + (CRT u) * (Scalar c) = CRT $ c *> u + (Sub c1) * (Scalar c2) = Sub $ c1 * Scalar c2 + + -- TWO SUBS: work in a CRT rep for compositum + (Sub (c1 :: Cyc t m1 r)) * (Sub (c2 :: Cyc t m2 r)) = + -- re-wrap c1, c2 as Subs of the composition, and force them to CRT + (Sub $ (toCRT' $ Sub c1 :: Cyc t (FLCM m1 m2) r) * toCRT' (Sub c2)) + \\ lcm2Divides (Proxy::Proxy m1) (Proxy::Proxy m2) (Proxy::Proxy m) + + -- ELSE: work in appropriate CRT rep + c1 * c2 = toCRT' c1 * toCRT' c2 + +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 + -- that the powerful basis has 1 as its first element, and that + -- we're using pow to define the module mult.) + + -- can use any r-basis to define module mult, but must be + -- consistent. + r *> (Pow v) = Pow $ r LP.*> v + r *> x = r *> toPow' x + +---------- Core cyclotomic operations ---------- + +advisePow, adviseDec, adviseCRT :: (Fact m, CElt t r) => Cyc t m r -> Cyc t m r +{-# INLINABLE advisePow #-} +{-# INLINABLE adviseDec #-} +{-# INLINABLE adviseCRT #-} + +-- | Same as 'adviseCRT', but for the powerful-basis representation. +advisePow = toPow' + +-- | Same as 'adviseCRT', but for the powerful-basis representation. +adviseDec = toDec' + +-- | Yield an equivalent element that /may/ be in a CRT +-- representation. This can serve as an optimization hint. E.g., +-- call 'adviseCRT' prior to multiplying the same value by many +-- other values. +adviseCRT = toCRT' + +-- | Multiply by the special element @g@ of the @m@th cyclotomic. +mulG :: (Fact m, CElt t r) => Cyc t m r -> Cyc t m r +{-# 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 (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) +{-# 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 (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.) +tGaussian :: (Fact m, OrdFloat q, Random q, Tensor t, TElt t q, + ToRational v, MonadRandom rnd) + => v -> rnd (Cyc t m q) +tGaussian = (Dec <$>) . U.tGaussian +{-# INLINABLE tGaussian #-} + +-- | Yield the scaled squared norm of @g_m \cdot e@ under +-- the canonical embedding, namely, +-- @\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) + +-- | Generate an LWE error term with given scaled variance, +-- deterministically rounded with respect to the decoding basis. +errorRounded :: (ToInteger z, Tensor t, Fact m, TElt t z, + ToRational v, MonadRandom rnd) => v -> rnd (Cyc t m z) +{-# INLINABLE errorRounded #-} +errorRounded = (Dec <$>) . U.errorRounded + +-- | Generate an LWE error term with given scaled variance @* p^2@ over +-- the given coset, deterministically rounded with respect to the +-- decoding basis. +errorCoset :: + (Mod zp, z ~ ModRep zp, Lift zp z, Fact m, + CElt t zp, TElt t z, ToRational v, MonadRandom rnd) + => v -> Cyc t m zp -> rnd (Cyc t m z) +errorCoset v = (Dec <$>) . U.errorCoset v . uncycDec +{-# INLINABLE errorCoset #-} + +---------- Inter-ring operations ---------- + +-- | Embed (lazily) into an extension ring. +embed :: forall t m m' r . (m `Divides` m') => Cyc t m r -> Cyc t m' r +{-# INLINABLE embed #-} +embed (Scalar c) = Scalar c -- keep as scalar +embed (Sub (c :: Cyc t l r)) = Sub c -- keep as subring element + \\ transDivides (Proxy::Proxy l) (Proxy::Proxy m) (Proxy::Proxy m') +embed c = Sub c + +-- | Force to a non-'Sub' constructor (for internal use only). +embed' :: forall t r l m . (l `Divides` m, CElt t r) => Cyc t l r -> Cyc t m r +{-# INLINE embed' #-} +embed' (Pow u) = Pow $ embedPow u +embed' (Dec u) = Dec $ embedDec u +embed' (CRT u) = either Pow CRT $ embedCRT 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) + +-- | The "tweaked trace" (twace) function +-- @Tw(x) = (mhat \/ m'hat) * Tr(g' \/ g * x)@, +-- which fixes @R@ pointwise (i.e., @twace . embed == id@). +twace :: forall t m m' r . (m `Divides` m', CElt t r) + => Cyc t m' r -> Cyc t m r +{-# 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 (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@. +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') + +-- | 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 +{-# INLINABLE powBasis #-} + +-- | The relative mod-@r@ CRT set of the extension. +crtSet :: (m `Divides` m', ZPP r, CElt t r, TElt t (ZpOf r)) + => Tagged m [Cyc t m' r] +crtSet = (Pow <$>) <$> U.crtSet +{-# INLINABLE crtSet #-} + + +---------- Lattice operations and instances ---------- + +instance (Reduce a b, Fact m, CElt t a, CElt t b) + -- CJP: need these specific constraints to get Reduce instance for Sub case + => Reduce (Cyc t m a) (Cyc t m b) where + {-# INLINABLE reduce #-} + reduce (Pow u) = Pow $ reduce u + reduce (Dec u) = Dec $ reduce u + reduce (CRT u) = Pow $ reduce $ toPow u + reduce (Scalar c) = Scalar $ reduce c + reduce (Sub (c :: Cyc t l a)) = Sub (reduce c :: Cyc t l b) + +type instance LiftOf (Cyc t m r) = Cyc t m (LiftOf r) + +-- | Lift using the specified basis. +liftCyc :: (Lift b a, Fact m, TElt t a, CElt t b) + => R.Basis -> Cyc t m b -> Cyc t m a +{-# INLINABLE liftCyc #-} + +liftCyc R.Pow = liftPow +liftCyc R.Dec = liftDec + +liftPow, liftDec :: (Lift b a, Fact m, TElt t a, CElt t b) + => Cyc t m b -> Cyc t m a +{-# INLINABLE liftPow #-} +{-# INLINABLE liftDec #-} + +-- | 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 +-- 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 + +-- | Unzip for unrestricted types. +unzipCyc :: (Tensor t, Fact m) => 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 (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 + +instance {-# OVERLAPS #-} (Rescale a b, CElt t a, TElt t b) + => R.RescaleCyc (Cyc t) a b where + + -- Optimized for subring constructors, for powerful basis. + -- Analogs for decoding basis are not quite correct, because (* -1) + -- doesn't commute with 'rescale' due to tiebreakers! + rescaleCyc R.Pow (Scalar c) = Scalar $ rescale c + rescaleCyc R.Pow (Sub c) = Sub $ R.rescalePow c + + rescaleCyc R.Pow c = Pow $ fmapPow rescale $ uncycPow c + rescaleCyc R.Dec c = Dec $ fmapDec rescale $ uncycDec c + {-# INLINABLE rescaleCyc #-} + +-- specialized instance for product rings: ~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 + + -- optimized for subrings and powerful basis (see comments in other + -- instance for why this doesn't work for decoding basis) + rescaleCyc R.Pow (Scalar c) = Scalar $ rescale c + rescaleCyc R.Pow (Sub c) = Sub $ R.rescalePow c + + rescaleCyc bas c = let aval = proxy modulus (Proxy::Proxy a) + (a,b) = unzipCElt c + z = liftCyc bas a + in Scalar (recip (reduce aval)) * (b - reduce z) + {-# INLINABLE rescaleCyc #-} + + +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 +instance (Decompose gad zq, Fact m, CElt t zq, CElt t (DecompOf zq)) + => Decompose gad (Cyc t m zq) where + + type DecompOf (Cyc t m zq) = Cyc t m (DecompOf zq) + + -- faster implementations: decompose directly in subring, which is + -- correct because we decompose in powerful basis + decompose (Scalar c) = pasteT $ Scalar <$> peelT (decompose c) + decompose (Sub c) = pasteT $ Sub <$> peelT (decompose c) + + -- traverse: Traversable (UCyc t m P) and Applicative (Tagged gad ZL) + decompose (Pow u) = fromZL $ Pow <$> traverse (toZL . decompose) u + decompose c = decompose $ toPow' c + + {-# INLINABLE decompose #-} + +toZL :: Tagged s [a] -> TaggedT s ZipList a +toZL = coerce + +fromZL :: TaggedT s ZipList a -> Tagged s [a] +fromZL = coerce + +-- promote Correct, using the decoding basis +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) <$> + sequenceA (uncycDec <$> peelT bs) + {-# INLINABLE correct #-} + +---------- Change of representation (internal use only) ---------- + +toPow', toDec', toCRT' :: (Fact m, CElt t r) => Cyc t m r -> Cyc t m r +{-# INLINE toPow' #-} +{-# INLINE toDec' #-} +{-# INLINE toCRT' #-} + +-- | 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' (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' (Sub c) = toDec' $ embed' c + +-- | Force to 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! +toCRT' (Sub c) = toCRT' $ embed' $ toCRT' c + +---------- Utility instances ---------- + +instance (Tensor t, Fact m, NFData r, TElt t r, + NFData (CRTExt r), TElt t (CRTExt r)) => NFData (Cyc t m r) where + rnf (Pow u) = rnf u + rnf (Dec u) = rnf u + rnf (CRT u) = rnf u + 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 + random g = let (u,g') = random g + in (either Pow CRT u, g') + {-# INLINABLE random #-} + + randomR _ = error "randomR non-sensical for Cyc" + +instance (Arbitrary (UCyc t m P r)) => Arbitrary (Cyc t m r) where + 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 diff --git a/Crypto/Lol/Cyclotomic/Linear.hs b/Crypto/Lol/Cyclotomic/Linear.hs new file mode 100644 --- /dev/null +++ b/Crypto/Lol/Cyclotomic/Linear.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE ConstraintKinds, DataKinds, FlexibleContexts, + GeneralizedNewtypeDeriving, KindSignatures, + MultiParamTypeClasses, NoImplicitPrelude, RoleAnnotations, + ScopedTypeVariables, StandaloneDeriving, TypeFamilies, + TypeOperators, UndecidableInstances #-} + +-- | Functions from one cyclotomic ring to another that are linear +-- over a common subring. + +module Crypto.Lol.Cyclotomic.Linear +( Linear, ExtendLinIdx +, linearDec, evalLin, extendLin +) where + +import Crypto.Lol.Cyclotomic.Cyc +import Crypto.Lol.LatticePrelude + +import Algebra.Additive as Additive (C) + +import Control.Applicative +import Control.DeepSeq + +-- | An @E@-linear function from @R@ to @S@. + +-- CJP: also have constructor for relative Pow basis of R/E? So far +-- not needed. +newtype Linear t z (e::Factored) (r::Factored) (s::Factored) = RD [Cyc t s z] + +deriving instance (NFData (Cyc t s z)) => NFData (Linear t z e r s) + +-- some params are phantom but matter for safety +type role Linear representational nominal representational representational nominal + +-- | Construct an @E@-linear function given a list of its output values +-- (in @S@) on the relative decoding basis of @R/E@. The number of +-- elements in the list must not exceed the size of the basis. +linearDec :: forall t z e r s . + (e `Divides` r, e `Divides` s, CElt t z) + => [Cyc t s z] -> Linear t z e r s +linearDec ys = let ps = proxy powBasis (Proxy::Proxy e) `asTypeOf` ys + in if length ys <= length ps then RD (adviseCRT <$> ys) + else error $ "linearDec: too many entries: " + ++ show (length ys) ++ " versus " + ++ show (length ps) + +-- | Evaluates the given linear function on the input. +evalLin :: forall t z e r s . + (e `Divides` r, e `Divides` s, CElt t z) + => Linear t z e r s -> Cyc t r z -> Cyc t s z +evalLin (RD ys) r = sum (zipWith (*) ys $ + embed <$> (coeffsCyc Dec r :: [Cyc t e z])) + +instance Additive (Cyc t s z) => Additive.C (Linear t z e r s) where + zero = RD [] + + (RD as) + (RD bs) = RD $ sumall as bs + where sumall [] ys = ys + sumall xs [] = xs + sumall (x:xs) (y:ys) = x+y : sumall xs ys + + negate (RD as) = RD $ negate <$> as + +instance (Reduce z zq, Fact s, CElt t z, CElt t zq) + => Reduce (Linear t z e r s) (Linear t zq e r s) where + reduce (RD ys) = RD $ reduce <$> ys + +type instance LiftOf (Linear t zp e r s) = Linear t (LiftOf zp) e r s + +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 + +-- | A convenient constraint synonym for extending a linear function +-- to larger rings. +type ExtendLinIdx e r s e' r' s' = + (Fact r, e ~ FGCD r e', r' ~ FLCM r e', -- these imply R'=R\otimes_E E' + e' `Divides` s', s `Divides` s') -- lcm(s,e')|s' <=> (S+E') \subseteq S' + +-- | Extend an @E@-linear function @R->S@ to an @E'@-linear function +-- @R\'->S\'@. (Mathematically, such extension only requires +-- @lcm(r,e\') | r\'@ (not equality), but this generality would +-- significantly complicate the implementation, and for our purposes +-- there's no reason to use any larger @r'@.) +extendLin :: (ExtendLinIdx e r s e' r' s', CElt t z) + => Linear t z e r s -> Linear t z e' r' s' +-- CJP: this simple implementation works because R/E and R'/E' have +-- identical decoding bases, because R' \cong R \otimes_E E'. If we +-- relax the constraint on E then we'd have to change the +-- implementation to something more difficult. +extendLin (RD ys) = RD (embed <$> ys) diff --git a/Crypto/Lol/Cyclotomic/RescaleCyc.hs b/Crypto/Lol/Cyclotomic/RescaleCyc.hs new file mode 100644 --- /dev/null +++ b/Crypto/Lol/Cyclotomic/RescaleCyc.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE MultiParamTypeClasses #-} + +module Crypto.Lol.Cyclotomic.RescaleCyc where + +import Crypto.Lol.Factored + +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 + +-- | Specialized convenience functions. +rescalePow, rescaleDec :: (RescaleCyc c a b, Fact m) => c m a -> c m b +{-# INLINE rescalePow #-} +{-# INLINE rescaleDec #-} +rescalePow = rescaleCyc Pow +rescaleDec = rescaleCyc Dec + diff --git a/Crypto/Lol/Cyclotomic/Tensor.hs b/Crypto/Lol/Cyclotomic/Tensor.hs new file mode 100644 --- /dev/null +++ b/Crypto/Lol/Cyclotomic/Tensor.hs @@ -0,0 +1,447 @@ +{-# LANGUAGE ConstraintKinds, DataKinds, FlexibleContexts, + NoImplicitPrelude, PolyKinds, RankNTypes, ScopedTypeVariables, + TupleSections, TypeFamilies, TypeOperators, + UndecidableInstances #-} + +-- | Interface for cyclotomic tensors, and helper functions for tensor +-- indexing. + +module Crypto.Lol.Cyclotomic.Tensor +( Tensor(..), CRTElt +-- * Top-level CRT functions +, hasCRTFuncs +, scalarCRT, mulGCRT, divGCRT, crt, crtInv, twaceCRT, embedCRT +-- * Tensor indexing +, Matrix, indexM, twCRTs +, zmsToIndexFact +, indexInfo +, extIndicesPowDec, extIndicesCRT, extIndicesCoeffs +, baseIndicesPow, baseIndicesDec, baseIndicesCRT +, digitRev +) +where + +import Crypto.Lol.CRTrans +import Crypto.Lol.LatticePrelude as LP hiding (lift, (*>)) +import Crypto.Lol.Types.FiniteField + +import Control.Applicative +import Control.DeepSeq +import Control.Monad.Random +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) + +-- | 'Tensor' encapsulates all the core linear transformations needed +-- for cyclotomic ring arithmetic. + +-- | The type @t m r@ represents a cyclotomic coefficient tensor of +-- index @m@ over base ring @r@. Most of the methods represent linear +-- transforms corresponding to operations in particular bases. +-- CRT-related methods are wrapped in 'Maybe' because they are +-- well-defined only when a CRT basis exists over the ring @r@ for +-- index @m@. + +-- | The superclass constraints are for convenience, to ensure that we +-- can sample error tensors of 'Double's. + +-- | __WARNING:__ as with all fixed-point arithmetic, the methods +-- in 'Tensor' may result in overflow (and thereby incorrect answers +-- and potential security flaws) if the input arguments are too close +-- to the bounds imposed by the base type. The acceptable range of +-- inputs for each method is determined by the linear transform it +-- implements. + +class (TElt t Double, TElt t (Complex Double)) + => Tensor (t :: Factored -> * -> *) where + + -- | Constraints needed by @t@ to hold type @r@. + type TElt t r :: Constraint + + -- | 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) + ((Eq r, Fact m, TElt t r) :- Eq (t m r)) + entailZTT :: Tagged (t m r) + ((ZeroTestable r, Fact m, TElt t r) :- ZeroTestable (t m r)) + entailNFDataT :: Tagged (t m r) + ((NFData r, Fact m, TElt t r) :- NFData (t m r)) + 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))) + 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 + + -- | Multiply by @g@ in the powerful/decoding basis + mulGPow, mulGDec :: (Ring r, Fact m, TElt t r) => t m r -> t m r + + -- | Divide by @g@ in the powerful/decoding basis. The 'Maybe' + -- output indicates that the operation may fail, which happens + -- exactly when the input is not divisible by @g@. + divGPow, divGDec :: (ZeroTestable r, IntegralDomain r, Fact m, TElt t r) + => t m r -> Maybe (t m r) + + -- | A tuple of all the operations relating to the CRT basis, in a + -- single 'Maybe' value for safety. Clients should typically not + -- 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 + + -- | Sample from the "tweaked" Gaussian error distribution @t*D@ + -- in the decoding basis, where @D@ has scaled variance @v@. + tGaussianDec :: (OrdFloat q, Random q, TElt t q, + ToRational v, Fact m, MonadRandom rnd) + => v -> rnd (t m q) + + -- | Given the coefficient tensor of @e@ with respect to the + -- decoding basis of @R@, yield the (scaled) squared norm of @g_m + -- \cdot e@ under the canonical embedding, namely, + -- @\hat{m}^{ -1 } \cdot || \sigma(g_m \cdot e) ||^2@ . + gSqNormDec :: (Ring r, Fact m, TElt t r) => t m r -> r + + -- | The @twace@ linear transformation, which is the same in both the + -- powerful and decoding bases. + twacePowDec :: (Ring r, m `Divides` m', TElt t r) => t m' r -> t m r + + -- | The @embed@ linear transformations, for the powerful and + -- decoding bases. + embedPow, embedDec :: (Additive r, m `Divides` m', TElt t r) + => t m r -> t m' r + + -- | A tuple of all the extension-related operations involving the + -- CRT bases, for safety. Clients should typically not use this + -- 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 + + -- | Map a tensor in the powerful\/decoding\/CRT basis, representing + -- an @O_m'@ element, to a vector of tensors representing @O_m@ + -- elements in the same kind of basis. + coeffs :: (Ring r, m `Divides` m', TElt t r) => t m' r -> [t m r] + + -- | The powerful extension basis w.r.t. the powerful basis. + powBasisPow :: (Ring r, TElt t r, m `Divides` m') => Tagged m [t m' r] + + -- | A list of tensors representing the mod-@p@ CRT set of the + -- extension. + crtSetDec :: (m `Divides` m', PrimeField fp, Coprime (PToF (CharOf fp)) m', + TElt t fp) + => Tagged m [t m' fp] + + -- | Potentially optimized version of 'fmap' when the input and + -- output element types 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'. + 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) + -- | Unzip for arbitrary types. + unzipT :: (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 () +{-# INLINABLE hasCRTFuncs #-} +hasCRTFuncs = tagT $ do + (_ :: r -> t m r,_,_,_,_) <- crtFuncs + return () + +-- | 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) +{-# INLINABLE scalarCRT #-} +scalarCRT = (\(f,_,_,_,_) -> f) <$> crtFuncs + + +mulGCRT, divGCRT, crt, crtInv :: + (Tensor t, Fact m, CRTElt t r) => Maybe (t m r -> t m r) +{-# INLINABLE mulGCRT #-} +{-# INLINABLE divGCRT #-} +{-# INLINABLE crt #-} +{-# INLINABLE crtInv #-} + +-- | Multiply by @g@ in the CRT basis. (This function is simply an +-- appropriate entry from 'crtFuncs'.) +mulGCRT = (\(_,f,_,_,_) -> f) <$> crtFuncs +-- | Divide by @g@ in the CRT basis. (This function is simply an +-- appropriate entry from 'crtFuncs'.) +divGCRT = (\(_,_,f,_,_) -> f) <$> crtFuncs +-- | The CRT transform. (This function is simply an appropriate entry +-- from 'crtFuncs'.) +crt = (\(_,_,_,f,_) -> f) <$> crtFuncs +-- | The inverse CRT transform. (This function is simply an +-- appropriate entry from 'crtFuncs'.) +crtInv = (\(_,_,_,_,f) -> f) <$> crtFuncs + +-- | The "tweaked trace" function for tensors in the CRT basis: +-- 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 = proxyT hasCRTFuncs (Proxy::Proxy (t m' r)) *> + proxyT hasCRTFuncs (Proxy::Proxy (t m r)) *> + (fst <$> crtExtFuncs) + +-- | 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 = proxyT hasCRTFuncs (Proxy::Proxy (t m' r)) *> + proxyT hasCRTFuncs (Proxy::Proxy (t m r)) *> + (snd <$> crtExtFuncs) + +fMatrix :: forall m r mon . (Fact m, Monad mon, Ring r) + => (forall pp . (PPow pp) => TaggedT pp mon (MatrixC r)) + -> TaggedT m mon (Matrix r) +fMatrix mat = tagT $ go $ sUnF (sing :: SFactored m) + where go :: Sing (pplist :: [PrimePower]) -> mon (Matrix r) + go spps = case spps of + SNil -> return MNil + (SCons spp rest) -> do + rest' <- go rest + mat' <- withWitnessT mat spp + return $ MKron rest' mat' + +-- deeply embedded DSL for Kronecker products of matrices + +data MatrixC r = + MC (Int -> Int -> r) -- yields element i,j + Int Int -- dims + +-- | A Kronecker product of zero of more matrices over @r@. +data Matrix r = MNil | MKron (Matrix r) (MatrixC r) + +-- | 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 = + let (iq,ir) = i `divMod` r + (jq,jr) = j `divMod` c + in indexM m iq jq * mc ir jr + +-- | The "tweaked" CRT^* matrix: @CRT^* . diag(sigma(g_m))@. +twCRTs :: (Fact m, CRTrans r) => TaggedT m Maybe (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 = do + phi <- pureT totientPPow + iToZms <- pureT indexToZmsPPow + jToPow <- pureT indexToPowPPow + (wPow, _) <- crtInfoPPow + gEmb <- gEmbPPow + + return $ MC (\j i -> let i' = iToZms i + in wPow (jToPow j * negate i') * gEmb i') phi phi + +-- 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 + | e >= 1 = let (q,r) = j `divMod` p + in r * (p^(e-1)) + digitRev (p,e-1) q + +indexToPowPPow, indexToZmsPPow :: PPow pp => Tagged pp (Int -> Int) +indexToPowPPow = indexToPow <$> ppPPow +indexToZmsPPow = indexToZms <$> ppPPow + +-- | Convert a @Z_m^*@ index to a linear tensor index in @[m]@. +zmsToIndexFact :: Fact m => Tagged m (Int -> Int) +zmsToIndexFact = zmsToIndex <$> ppsFact + +-- | For a prime power @p^e@, map a tensor index to the corresponding +-- power j in @[phi(p^e)]@, as in the powerful basis. +indexToPow :: PP -> Int -> Int +-- CJP: use accumulator to avoid multiple exponentiations? +indexToPow (p,e) j = let (jq,jr) = j `divMod` (p-1) + in p^(e-1)*jr + digitRev (p,e-1) jq + +-- | For a prime power @p^e@, map a tensor index to the corresponding +-- 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 + +-- | 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 + +-- | Inverse of 'indexToZms'. +zmsToIndexPP :: PP -> Int -> Int +zmsToIndexPP (p,_) i = let (i1,i0) = i `divMod` p + in (p-1)*i1 + i0 - 1 + +-- Index correspondences for ring extensions + +-- | Correspondences between the linear indexes into a basis of O_m', +-- and pair indices into (extension basis) \otimes (basis of O_m). +-- The work the same for Pow,Dec,CRT bases because all these bases +-- have that factorization. The first argument is the list of +-- @(phi(m),phi(m'))@ pairs for the (merged) prime powers of @m@,@m'@. +toIndexPair :: [(Int,Int)] -> Int -> (Int,Int) +fromIndexPair :: [(Int,Int)] -> (Int,Int) -> Int + +toIndexPair [] 0 = (0,0) +toIndexPair ((phi,phi'):rest) i' = + let (i'q,i'r) = i' `divMod` phi' + (i'rq,i'rr) = i'r `divMod` phi + (i'q1,i'q0) = toIndexPair rest i'q + in (i'rq + i'q1*(phi' `div` phi), i'rr + i'q0*phi) + +fromIndexPair [] (0,0) = 0 +fromIndexPair ((phi,phi'):rest) (i1,i0) = + let (i0q,i0r) = i0 `divMod` phi + (i1q,i1r) = i1 `divMod` (phi' `div` phi) + i = fromIndexPair rest (i1q,i0q) + in (i0r + i1r*phi) + i*phi' + +-- | A collection of useful information for working with tensor +-- extensions. The first component is a list of triples @(p,e,e')@ +-- where @e@, @e'@ are respectively the exponents of prime @p@ in @m@, +-- @m'@. The next two components are @phi(m)@ and @phi(m')@. The +-- final component is a pair @(phi(p^e), phi(p^e'))@ for each triple +-- in the first component. +indexInfo :: forall m m' . (m `Divides` m') + => Tagged '(m, m') ([(Int,Int,Int)], Int, Int, [(Int,Int)]) +indexInfo = let pps = proxy ppsFact (Proxy::Proxy m) + pps' = proxy ppsFact (Proxy::Proxy m') + mpps = mergePPs pps pps' + phi = totientPPs pps + phi' = totientPPs pps' + tots = totients mpps + in tag (mpps, phi, phi', tots) + +-- | A vector of @phi(m)@ entries, where the @i@th entry is the index +-- into the powerful\/decoding basis of @O_m'@ of the +-- @i@th entry of the powerful\/decoding basis of @O_m@. +extIndicesPowDec :: (m `Divides` m') => Tagged '(m, m') (U.Vector Int) +extIndicesPowDec = do + (_, phi, _, tots) <- indexInfo + return $ U.generate phi (fromIndexPair tots . (0,)) + +-- | A vector of @phi(m)@ blocks of @phi(m')\/phi(m)@ consecutive +-- entries. Each block contains all those indices into the CRT basis +-- of @O_m'@ that "lie above" the corresponding index into the CRT +-- basis of @O_m@. +extIndicesCRT :: forall m m' . (m `Divides` m') + => Tagged '(m, m') (U.Vector Int) +extIndicesCRT = do + (_, phi, phi', tots) <- indexInfo + return $ U.generate phi' + (fromIndexPair tots . swap . (`divMod` (phi' `div` phi))) + +baseWrapper :: forall m m' a . (m `Divides` m', U.Unbox a) + => ([(Int,Int,Int)] -> Int -> a) + -> Tagged '(m, m') (U.Vector a) +baseWrapper f = do + (mpps, _, phi', _) <- indexInfo + return $ U.generate phi' (f mpps) + +-- | A lookup table for 'toIndexPair' applied to indices @[phi(m')]@. +baseIndicesPow :: forall m m' . (m `Divides` m') + => Tagged '(m, m') (U.Vector (Int,Int)) +-- | A lookup table for 'baseIndexDec' applied to indices @[phi(m')]@. +baseIndicesDec :: forall m m' . (m `Divides` m') + => Tagged '(m, m') (U.Vector (Maybe (Int,Bool))) + +-- | Same as 'baseIndicesPow', but only includes the second component +-- of each pair. +baseIndicesCRT :: forall m m' . (m `Divides` m') + => Tagged '(m, m') (U.Vector Int) + +baseIndicesPow = baseWrapper (toIndexPair . totients) + +-- this one is more complicated; requires the prime powers +baseIndicesDec = baseWrapper baseIndexDec + +baseIndicesCRT = + baseWrapper (\pps -> snd . toIndexPair (totients pps)) + + +-- | The @i0@th entry of the @i1@th vector is 'fromIndexPair' @(i1,i0)@. +extIndicesCoeffs :: forall m m' . (m `Divides` m') + => Tagged '(m, m') (V.Vector (U.Vector Int)) +extIndicesCoeffs = do + (_, phi, phi', tots) <- indexInfo + return $ V.generate (phi' `div` phi) + (\i1 -> U.generate phi (\i0 -> fromIndexPair tots (i1,i0))) + +-- | Convenient reindexing functions + +-- | Maps an index of the extension ring array to its corresponding +-- index in the base ring array (if it exists), with sign, under the +-- decoding basis. +baseIndexDec :: [(Int,Int,Int)] -> Int -> Maybe (Int, Bool) +baseIndexDec [] 0 = Just (0,False) +baseIndexDec ((p,e,e'):rest) i' + = let (i'q, i'r) = i' `divMod` totientPP (p,e') + phi = totientPP (p,e) + curr + | p>2 && e==0 && e' > 0 = case i'r of + 0 -> Just (0,False) + 1 -> Just (0,True) + _ -> Nothing + | otherwise = if i'r < phi then Just (i'r,False) else Nothing + in do + (i,b) <- curr + (j,b') <- baseIndexDec rest i'q + return (i + phi*j, b /= b') + +-- the first list of pps must "divide" the other. result is a list of +-- all (prime, min e, max e). +mergePPs :: [PP] -> [PP] -> [(Int,Int,Int)] +mergePPs [] pps = LP.map (\(p,e) -> (p,0,e)) pps +mergePPs allpps@((p,e):pps) ((p',e'):pps') + | p == p' && e <= e' = (p, e, e') : mergePPs pps pps' + | p > p' = (p', 0, e') : mergePPs allpps pps' + +totients :: [(Int, Int, Int)] -> [(Int,Int)] +totients = LP.map (\(p,e,e') -> (totientPP (p,e), totientPP (p,e'))) diff --git a/Crypto/Lol/Cyclotomic/Tensor/CTensor.hs b/Crypto/Lol/Cyclotomic/Tensor/CTensor.hs new file mode 100644 --- /dev/null +++ b/Crypto/Lol/Cyclotomic/Tensor/CTensor.hs @@ -0,0 +1,474 @@ +{-# LANGUAGE ConstraintKinds, DataKinds, GADTs, + FlexibleContexts, FlexibleInstances, TypeOperators, PolyKinds, + GeneralizedNewtypeDeriving, InstanceSigs, RoleAnnotations, + MultiParamTypeClasses, NoImplicitPrelude, StandaloneDeriving, + ScopedTypeVariables, TupleSections, TypeFamilies, RankNTypes, + TypeSynonymInstances, UndecidableInstances, + RebindableSyntax #-} + +-- | Wrapper for a C implementation of the 'Tensor' interface. + +module Crypto.Lol.Cyclotomic.Tensor.CTensor +( CT ) where + +import Algebra.Additive as Additive (C) +import Algebra.Module as Module (C) +import Algebra.ZeroTestable as ZeroTestable (C) + +import Control.Applicative hiding ((*>)) +import Control.Arrow ((***)) +import Control.DeepSeq +import Control.Monad (liftM) +import Control.Monad.Identity (Identity(..), runIdentity) +import Control.Monad.Random +import Control.Monad.Trans (lift) + +import Data.Coerce +import Data.Constraint hiding ((***)) +import Data.Foldable as F +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 Foreign.Marshal.Utils (with) +import Foreign.Ptr +import Foreign.Storable (Storable (..)) +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.Reflects +import Crypto.Lol.Types.FiniteField +import Crypto.Lol.Types.IZipVector +import Crypto.Lol.Types.ZqBasic + +import System.IO.Unsafe (unsafePerformIO) + +-- | Newtype wrapper around a Vector. +newtype CT' (m :: Factored) r = CT' { unCT :: Vector r } + deriving (Show, Eq, NFData) + +-- the first argument, though phantom, affects representation +type role CT' representational nominal + +-- GADT wrapper that distinguishes between Unbox and unrestricted +-- element types + +-- | 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 + +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) + +toCT :: (Storable r) => CT m r -> CT m r +toCT v@(CT _) = v +toCT (ZV v) = CT $ zvToCT' v + +toZV :: (Fact m) => CT m r -> CT m r +toZV (CT (CT' v)) = ZV $ fromMaybe (error "toZV: internal error") $ + iZipVector $ convert v +toZV v@(ZV _) = v + +zvToCT' :: forall m r . (Storable r) => IZipVector m r -> CT' m r +zvToCT' v = coerce (convert $ unIZipVector v :: Vector r) + +wrap :: (Storable r) => (CT' l r -> CT' m r) -> (CT l r -> CT m r) +wrap f (CT v) = CT $ f v +wrap f (ZV v) = CT $ f $ zvToCT' v + +wrapM :: (Storable r, Monad mon) => (CT' l r -> mon (CT' m r)) + -> (CT l r -> mon (CT m r)) +wrapM f (CT v) = CT <$> f v +wrapM f (ZV v) = CT <$> f (zvToCT' v) + +-- convert an CT' *twace* signature to Tagged one +type family Tw (r :: *) :: * where + Tw (CT' m' r -> CT' m r) = Tagged '(m,m') (Vector r -> Vector r) + Tw (Maybe (CT' m' r -> CT' m r)) = TaggedT '(m,m') Maybe (Vector r -> Vector r) + +type family Em r where + Em (CT' m r -> CT' m' r) = Tagged '(m,m') (Vector r -> Vector r) + Em (Maybe (CT' m r -> CT' m' r)) = TaggedT '(m,m') Maybe (Vector r -> Vector r) + + +---------- NUMERIC PRELUDE INSTANCES ---------- + +-- 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 (*) + +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) + negate (CT (CT' a)) = CT $ CT' $ SV.map negate a -- EAC: This probably should be converted to C code + negate a = negate $ toCT a + + zero = CT $ repl zero + +{- +instance (Fact m, Ring r, Storable r, Dispatch r) + => Ring.C (CT m r) where + (CT a@(CT' _)) * (CT b@(CT' _)) = CT $ (untag $ cZipDispatch dmul) a b + + fromInteger = CT . repl . fromInteger +-} + +instance (ZeroTestable r, Storable r, Fact m) + => ZeroTestable.C (CT m r) where + --{-# INLINABLE isZero #-} + isZero (CT (CT' a)) = SV.foldl' (\ b x -> b && isZero x) True a + isZero (ZV v) = isZero v + +instance (GFCtx fp d, Fact m, Additive (CT m fp)) + => Module.C (GF fp d) (CT m fp) where + + r *> v = case v of + CT (CT' arr) -> CT $ CT' $ SV.fromList $ unCoeffs $ r *> Coeffs $ SV.toList arr + ZV zv -> ZV $ fromJust $ iZipVector $ V.fromList $ unCoeffs $ r *> Coeffs $ V.toList $ unIZipVector zv + +---------- Category-theoretic instances ---------- + +instance Fact m => Functor (CT m) where + -- Functor instance is implied by Applicative laws + fmap f x = pure f <*> x + +instance Fact m => Applicative (CT m) where + pure = ZV . pure + + (ZV f) <*> (ZV a) = ZV (f <*> a) + f@(ZV _) <*> v@(CT _) = f <*> toZV v + +instance Fact m => Foldable (CT m) where + -- Foldable instance is implied by Traversable + foldMap = foldMapDefault + +instance Fact m => Traversable (CT m) where + traverse f r@(CT _) = T.traverse f $ toZV r + traverse f (ZV v) = ZV <$> T.traverse f v + +instance Tensor CT where + + type TElt CT r = (Storable r, Dispatch r) + + 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 + entailModuleT = tag $ Sub Dict + + scalarPow = CT . scalarPow' -- Vector code + + l = wrap $ untag $ basicDispatch dl + lInv = wrap $ untag $ basicDispatch dlinv + + mulGPow = wrap mulGPow' + mulGDec = wrap $ untag $ basicDispatch dmulgdec + + divGPow = wrapM divGPow' + -- we divide by p in the C code (for divGDec only(?)), do NOT call checkDiv! + divGDec = wrapM $ Just . untag (basicDispatch dginvdec) + + crtFuncs = (,,,,) <$> + Just (CT . repl) <*> + (wrap <$> untag (cZipDispatch dmul) <$> untagT gCoeffsCRT) <*> + (wrap <$> untag (cZipDispatch dmul) <$> untagT gInvCoeffsCRT) <*> + (wrap <$> untagT ctCRT) <*> + (wrap <$> untagT ctCRTInv) + + twacePowDec = wrap $ runIdentity $ coerceTw twacePowDec' + embedPow = wrap $ runIdentity $ coerceEm embedPow' + embedDec = wrap $ runIdentity $ coerceEm embedDec' + + tGaussianDec v = CT <$> cDispatchGaussian v + --tGaussianDec v = CT <$> coerceT' (gaussianDec v) + + -- we do not wrap this function because (currently) it can only be called on lifted types + gSqNormDec (CT v) = untag gSqNormDec' v + gSqNormDec (ZV v) = gSqNormDec (CT $ zvToCT' v) + + crtExtFuncs = (,) <$> (wrap <$> coerceTw twaceCRT') + <*> (wrap <$> coerceEm embedCRT') + + coeffs = wrapM $ coerceCoeffs coeffs' + + powBasisPow = (CT <$>) <$> coerceBasis powBasisPow' + + crtSetDec = (CT <$>) <$> coerceBasis crtSetDec' + + fmapT f (CT v) = CT $ coerce (SV.map f) v + fmapT f v@(ZV _) = fmapT f $ toCT v + + fmapTM f (CT (CT' v)) = (CT . CT') <$> SV.mapM f v + fmapTM f v@(ZV _) = fmapTM f $ toCT v + + 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 + + {-# INLINABLE entailIndexT #-} + {-# INLINABLE entailEqT #-} + {-# INLINABLE entailZTT #-} + {-# INLINABLE entailNFDataT #-} + {-# INLINABLE entailRandomT #-} + {-# INLINABLE entailShowT #-} + {-# INLINABLE scalarPow #-} + {-# INLINABLE l #-} + {-# INLINABLE lInv #-} + {-# INLINABLE mulGPow #-} + {-# INLINABLE mulGDec #-} + {-# INLINABLE divGPow #-} + {-# INLINABLE divGDec #-} + {-# INLINABLE crtFuncs #-} + {-# INLINABLE twacePowDec #-} + {-# INLINABLE embedPow #-} + {-# INLINABLE embedDec #-} + {-# INLINABLE tGaussianDec #-} + {-# INLINABLE gSqNormDec #-} + {-# INLINABLE crtExtFuncs #-} + {-# INLINABLE coeffs #-} + {-# INLINABLE powBasisPow #-} + {-# INLINABLE crtSetDec #-} + {-# INLINABLE fmapT #-} + {-# INLINABLE fmapTM #-} + {-# INLINABLE zipWithT #-} + {-# INLINABLE unzipTElt #-} + {-# INLINABLE unzipT #-} + + +coerceTw :: (Functor mon) => TaggedT '(m, m') mon (Vector r -> Vector r) -> mon (CT' m' r -> CT' m r) +coerceTw = (coerce <$>) . untagT + +coerceEm :: (Functor mon) => TaggedT '(m, m') mon (Vector r -> Vector r) -> mon (CT' m r -> CT' m' r) +coerceEm = (coerce <$>) . untagT + +-- | Useful coersion for defining @coeffs@ in the @Tensor@ +-- interface. Using 'coerce' alone is insufficient for type inference. +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 :: + (Fact m, Fact m') + => Tagged '(m,m') [Vector r] -> Tagged m [CT' m' r] +coerceBasis = coerce + +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' = untag $ checkDiv $ basicDispatch dginvpow + +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) + totm = proxy (fromIntegral <$> totientFact) (Proxy::Proxy m) + numFacts = fromIntegral $ SV.length factors + in \(CT' x) -> do + yout <- SV.thaw x + SM.unsafeWith yout (\pout -> + SV.unsafeWith factors (\pfac -> + 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 f = return $ unsafePerformIO . withBasicArgs f + +gSqNormDec' :: forall m r . + (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 + ru' <- ru + 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 + ruinv' <- ruInv + 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) + => 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 -> + let (CT' y) = f' x + in CT' <$> SV.mapM (`divIfDivis` oddRad') y + +divIfDivis :: (IntegralDomain r, ZeroTestable r) => r -> r -> Maybe r +divIfDivis num den = let (q,r) = num `divMod` den + in if isZero r then Just q else Nothing + +cZipDispatch :: (Storable r, Fact m, Additive r) + => (Ptr r -> Ptr r -> Int64 -> IO ()) + -> Tagged m (CT' m r -> CT' m r -> CT' m r) +cZipDispatch f = do -- in Tagged m + totm <- fromIntegral <$> totientFact + return $ coerce $ \a b -> unsafePerformIO $ do + yout <- SV.thaw a + SM.unsafeWith yout (\pout -> + SV.unsafeWith b (\pin -> + f pout pin totm)) + unsafeFreeze yout + +cDispatchGaussian :: forall m r var rnd . + (Storable r, Transcendental r, Dispatch r, Ord r, + Fact m, ToRational var, Random r, MonadRandom rnd) + => var -> rnd (CT' m r) +cDispatchGaussian var = flip proxyT (Proxy::Proxy m) $ do -- in TaggedT m rnd + -- get rus for (Complex r) + ruinv' <- mapTaggedT (return . fromMaybe (error "complexGaussianRoots")) ruInv + totm <- pureT totientFact + m <- pureT valueFact + rad <- pureT radicalFact + yin <- 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 + arbitrary = replM arbitrary + shrink = shrinkNothing + +instance (Storable r, Arbitrary (CT' m r)) => Arbitrary (CT m r) where + arbitrary = CT <$> arbitrary + +instance (Storable r, Random r, Fact m) => Random (CT' m r) where + --{-# INLINABLE random #-} + random = runRand $ replM (liftRand random) + + randomR = error "randomR nonsensical for CT'" + +instance (Storable r, Random (CT' m r)) => Random (CT m r) where + --{-# INLINABLE random #-} + random = runRand $ CT <$> liftRand random + + randomR = error "randomR nonsensical for CT" + +instance (NFData r) => NFData (CT m r) where + rnf (CT v) = rnf v + rnf (ZV v) = rnf v + +repl :: forall m r . (Fact m, Storable r) => r -> CT' m r +repl = let n = proxy totientFact (Proxy::Proxy m) + in coerce . SV.replicate n + +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' = + 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 = do + mval <- pureT valueFact + wPow <- fst <$> crtInfoFact + LP.map + (\(p,e) -> do + let pp = p^e + pow = mval `div` pp + generate pp (wPow . (*pow))) <$> + pureT ppsFact + +--{-# INLINE ruInv #-} +ruInv = do + mval <- pureT valueFact + wPow <- fst <$> crtInfoFact + LP.map + (\(p,e) -> do + let pp = p^e + pow = mval `div` pp + 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 + +-- 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) + embed <- proxyT embedCRT' (Proxy::Proxy '(m,m')) + indices <- pure $ proxy extIndicesCRT (Proxy::Proxy '(m,m')) + (_, m'hatinv) <- proxyT crtInfoFact (Proxy::Proxy m') + let phi = proxy totientFact (Proxy::Proxy m) + phi' = proxy totientFact (Proxy::Proxy m') + mhat = fromIntegral $ proxy valueHatFact (Proxy::Proxy m) + hatRatioInv = m'hatinv * mhat + reltot = phi' `div` phi + -- tweak = mhat * g' / (m'hat * g) + tweak = SV.map (* hatRatioInv) $ SV.zipWith (*) (embed gInv) g' + return $ \ arr -> -- take true trace after mul-by-tweak + let v = backpermute' indices (SV.zipWith (*) tweak arr) + in generate phi $ \i -> foldl1' (+) $ SV.unsafeSlice (i*reltot) reltot v diff --git a/Crypto/Lol/Cyclotomic/Tensor/CTensor/Backend.hs b/Crypto/Lol/Cyclotomic/Tensor/CTensor/Backend.hs new file mode 100644 --- /dev/null +++ b/Crypto/Lol/Cyclotomic/Tensor/CTensor/Backend.hs @@ -0,0 +1,304 @@ +{-# LANGUAGE ConstraintKinds, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, + PolyKinds, ScopedTypeVariables, TypeFamilies, UndecidableInstances #-} + +module Crypto.Lol.Cyclotomic.Tensor.CTensor.Backend +(Dispatch +,dcrt +,dcrtinv +,dgaussdec +,dl +,dlinv +,dnorm +,dmulgpow +,dmulgdec +,dginvpow +,dginvdec +,dadd +,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.Reflects +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.Internal (getPtr) + +import Foreign.ForeignPtr (touchForeignPtr) +import Foreign.Marshal.Array (withArray) +import Foreign.Marshal.Utils (with) +import Foreign.Ptr (plusPtr, castPtr, Ptr) +import Foreign.Storable (Storable (..)) +import qualified Foreign.Storable.Record as Store + +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 +withPtrArray :: (Storable a) => [Vector a] -> (Ptr (Ptr a) -> IO b) -> IO b +withPtrArray v f = do + let vs = LP.map SV.unsafeToForeignPtr0 v + ptrV = LP.map (\(fp,_) -> getPtr fp) vs + res <- withArray ptrV f + LP.mapM_ (\(fp,_) -> touchForeignPtr fp) vs + return res + +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 +instance Storable CPP where + sizeOf = Store.sizeOf store + alignment = Store.alignment store + peek = Store.peek store + poke = Store.poke store + +store :: Store.Dictionary CPP +store = Store.run $ + liftA2 CPP + (Store.element p') + (Store.element e') + +instance Show CPP where + 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 + -- 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)) + alignment _ = max (alignment (undefined :: a)) (alignment (undefined :: b)) + peek p = do + a <- peek (castPtr p :: Ptr a) + b <- peek (castPtr (plusPtr p (sizeOf a)) :: Ptr b) + return (a,b) + poke p (a,b) = do + poke (castPtr p :: Ptr a) a + poke (castPtr (plusPtr p (sizeOf a)) :: Ptr b) b + + + + + +data ZqB64D -- for type safety purposes +data ComplexD +data DoubleD +data Int64D + +type family CTypeOf x where + CTypeOf (a,b) = CTypeOf a + CTypeOf (ZqBasic (q :: k) Int64) = ZqB64D + CTypeOf Double = DoubleD + CTypeOf Int64 = Int64D + CTypeOf (Complex Double) = ComplexD + +-- returns the modulus as a nested list of moduli +class (Tuple a) => ZqTuple a where + type ModPairs a + getModuli :: Tagged a (ModPairs a) + +instance (Reflects q Int64) => ZqTuple (ZqBasic q Int64) where + type ModPairs (ZqBasic q Int64) = Int64 + getModuli = tag $ proxy value (Proxy::Proxy q) + +instance (ZqTuple a, ZqTuple b) => ZqTuple (a, b) where + type ModPairs (a,b) = (ModPairs a, ModPairs b) + getModuli = + let as = proxy getModuli (Proxy::Proxy a) + bs = proxy getModuli (Proxy :: Proxy b) + in tag (as,bs) + +-- counts components in a nested tuple +class Tuple a where + numComponents :: Tagged a Int16 + +instance {-# Overlappable #-} Tuple a where + numComponents = tag 1 + +instance (Tuple a, Tuple b) => Tuple (a,b) where + numComponents = tag $ (proxy numComponents (Proxy::Proxy a)) + (proxy numComponents (Proxy::Proxy b)) + +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 + dcrt :: Ptr (Ptr r) -> Ptr r -> Int64 -> Ptr CPP -> Int16 -> IO () + dcrtinv :: Ptr (Ptr r) -> Ptr r -> Ptr r -> Int64 -> Ptr CPP -> Int16 -> IO () + dgaussdec :: Ptr (Ptr (Complex r)) -> Ptr r -> Int64 -> Ptr CPP -> Int16 -> IO () + + dl :: Ptr r -> Int64 -> Ptr CPP -> Int16 -> IO () + dlinv :: Ptr r -> Int64 -> Ptr CPP -> Int16 -> IO () + dnorm :: Ptr r -> Int64 -> Ptr CPP -> Int16 -> IO () + dmulgpow :: Ptr r -> Int64 -> Ptr CPP -> Int16 -> IO () + dmulgdec :: Ptr r -> Int64 -> Ptr CPP -> Int16 -> IO () + dginvpow :: Ptr r -> Int64 -> Ptr CPP -> Int16 -> IO () + dginvdec :: Ptr r -> Int64 -> Ptr CPP -> Int16 -> IO () + + dadd :: Ptr r -> Ptr r -> Int64 -> IO () + dmul :: Ptr r -> Ptr r -> Int64 -> IO () + +instance (ZqTuple r, Storable (ModPairs r), + CTypeOf r ~ ZqB64D) + => Dispatch' ZqB64D r where + dcrt ruptr pout totm pfac numFacts = + let qs = proxy getModuli (Proxy::Proxy r) + numPairs = proxy numComponents (Proxy::Proxy r) + in with qs $ \qsptr -> + tensorCRTRq numPairs (castPtr pout) totm pfac numFacts (castPtr ruptr) (castPtr qsptr) + dcrtinv ruptr minv pout totm pfac numFacts = + let qs = proxy getModuli (Proxy::Proxy r) + 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 = + 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 = + let qs = proxy getModuli (Proxy::Proxy r) + numPairs = proxy numComponents (Proxy::Proxy r) + in with qs $ \qsptr -> + tensorLInvRq numPairs (castPtr pout) totm pfac numFacts (castPtr qsptr) + dnorm = error "cannot call CT normSq on type ZqBasic" + dmulgpow pout totm pfac numFacts = + let qs = proxy getModuli (Proxy::Proxy r) + numPairs = proxy numComponents (Proxy::Proxy r) + in with qs $ \qsptr -> + tensorGPowRq numPairs (castPtr pout) totm pfac numFacts (castPtr qsptr) + dmulgdec pout totm pfac numFacts = + let qs = proxy getModuli (Proxy::Proxy r) + numPairs = proxy numComponents (Proxy::Proxy r) + in with qs $ \qsptr -> + tensorGDecRq numPairs (castPtr pout) totm pfac numFacts (castPtr qsptr) + dginvpow pout totm pfac numFacts = + let qs = proxy getModuli (Proxy::Proxy r) + numPairs = proxy numComponents (Proxy::Proxy r) + in with qs $ \qsptr -> + tensorGInvPowRq numPairs (castPtr pout) totm pfac numFacts (castPtr qsptr) + dginvdec pout totm pfac numFacts = + let qs = proxy getModuli (Proxy::Proxy r) + 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 = + let qs = proxy getModuli (Proxy::Proxy r) + numPairs = proxy numComponents (Proxy::Proxy r) + in with qs $ \qsptr -> + mulRq numPairs (castPtr aout) (castPtr bout) totm (castPtr qsptr) + 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 = + tensorCRTC (proxy numComponents (Proxy::Proxy r)) (castPtr pout) totm pfac numFacts (castPtr ruptr) + dcrtinv ruptr minv pout totm pfac numFacts = + tensorCRTInvC (proxy numComponents (Proxy::Proxy r)) (castPtr pout) totm pfac numFacts (castPtr ruptr) (castPtr minv) + dl pout = + tensorLC (proxy numComponents (Proxy::Proxy r)) (castPtr pout) + dlinv pout = + tensorLInvC (proxy numComponents (Proxy::Proxy r)) (castPtr pout) + dnorm = error "cannot call CT normSq on type Complex Double" + dmulgpow pout = + tensorGPowC (proxy numComponents (Proxy::Proxy r)) (castPtr pout) + dmulgdec = error "cannot call CT mulGDec on type Complex Double" + 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 = + 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 = + tensorLDouble (proxy numComponents (Proxy::Proxy r)) (castPtr pout) + dlinv pout = + tensorLInvDouble (proxy numComponents (Proxy::Proxy r)) (castPtr pout) + dnorm = error "cannot call CT normSq on type Double" + 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 = + 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 = + tensorLR (proxy numComponents (Proxy::Proxy r)) (castPtr pout) + dlinv pout = + tensorLInvR (proxy numComponents (Proxy::Proxy r)) (castPtr pout) + dnorm pout = + tensorNormSqR (proxy numComponents (Proxy::Proxy r)) (castPtr pout) + dmulgpow pout = + tensorGPowR (proxy numComponents (Proxy::Proxy r)) (castPtr pout) + dmulgdec pout = + tensorGDecR (proxy numComponents (Proxy::Proxy r)) (castPtr pout) + dginvpow pout = + tensorGInvPowR (proxy numComponents (Proxy::Proxy r)) (castPtr 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" + +foreign import ccall unsafe "tensorLR" tensorLR :: Int16 -> Ptr Int64 -> Int64 -> Ptr CPP -> Int16 -> IO () +foreign import ccall unsafe "tensorLInvR" tensorLInvR :: Int16 -> Ptr Int64 -> Int64 -> Ptr CPP -> Int16 -> IO () +foreign import ccall unsafe "tensorLRq" tensorLRq :: Int16 -> Ptr (ZqBasic q Int64) -> Int64 -> Ptr CPP -> Int16 -> Ptr Int64 -> IO () +foreign import ccall unsafe "tensorLInvRq" tensorLInvRq :: Int16 -> Ptr (ZqBasic q Int64) -> Int64 -> Ptr CPP -> Int16 -> Ptr Int64 -> IO () +foreign import ccall unsafe "tensorLDouble" tensorLDouble :: Int16 -> Ptr Double -> Int64 -> Ptr CPP -> Int16 -> IO () +foreign import ccall unsafe "tensorLInvDouble" tensorLInvDouble :: Int16 -> Ptr Double -> Int64 -> Ptr CPP -> Int16 -> IO () +foreign import ccall unsafe "tensorLC" tensorLC :: Int16 -> Ptr (Complex Double) -> Int64 -> Ptr CPP -> Int16 -> IO () +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 "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 () +foreign import ccall unsafe "tensorGPowC" tensorGPowC :: Int16 -> Ptr (Complex Double) -> Int64 -> Ptr CPP -> Int16 -> IO () +foreign import ccall unsafe "tensorGDecR" tensorGDecR :: Int16 -> Ptr Int64 -> Int64 -> Ptr CPP -> Int16 -> IO () +foreign import ccall unsafe "tensorGDecRq" tensorGDecRq :: Int16 -> Ptr (ZqBasic q Int64) -> Int64 -> Ptr CPP -> Int16 -> Ptr Int64 -> IO () +foreign import ccall unsafe "tensorGInvPowR" tensorGInvPowR :: Int16 -> Ptr Int64 -> Int64 -> Ptr CPP -> Int16 -> IO () +foreign import ccall unsafe "tensorGInvPowRq" tensorGInvPowRq :: Int16 -> Ptr (ZqBasic q Int64) -> Int64 -> Ptr CPP -> Int16 -> Ptr Int64 -> IO () +foreign import ccall unsafe "tensorGInvPowC" tensorGInvPowC :: Int16 -> Ptr (Complex Double) -> Int64 -> Ptr CPP -> Int16 -> IO () +foreign import ccall unsafe "tensorGInvDecR" tensorGInvDecR :: Int16 -> Ptr Int64 -> Int64 -> Ptr CPP -> Int16 -> IO () +foreign import ccall unsafe "tensorGInvDecRq" tensorGInvDecRq :: Int16 -> Ptr (ZqBasic q Int64) -> Int64 -> Ptr CPP -> Int16 -> Ptr Int64 -> IO () + +foreign import ccall unsafe "tensorCRTRq" tensorCRTRq :: Int16 -> Ptr (ZqBasic q Int64) -> Int64 -> Ptr CPP -> Int16 -> Ptr (Ptr (ZqBasic q Int64)) -> Ptr Int64 -> IO () +foreign import ccall unsafe "tensorCRTC" tensorCRTC :: Int16 -> Ptr (Complex Double) -> Int64 -> Ptr CPP -> Int16 -> Ptr (Ptr (Complex Double)) -> IO () +foreign import ccall unsafe "tensorCRTInvRq" tensorCRTInvRq :: Int16 -> Ptr (ZqBasic q Int64) -> Int64 -> Ptr CPP -> Int16 -> Ptr (Ptr (ZqBasic q Int64)) -> Ptr (ZqBasic q Int64) -> Ptr Int64 -> IO () +foreign import ccall unsafe "tensorCRTInvC" tensorCRTInvC :: Int16 -> Ptr (Complex Double) -> Int64 -> Ptr CPP -> Int16 -> Ptr (Ptr (Complex Double)) -> Ptr (Complex Double) -> IO () + +foreign import ccall unsafe "tensorGaussianDec" tensorGaussianDec :: Int16 -> Ptr Double -> Int64 -> Ptr CPP -> Int16 -> Ptr (Ptr (Complex Double)) -> IO () + +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 new file mode 100644 --- /dev/null +++ b/Crypto/Lol/Cyclotomic/Tensor/CTensor/Extension.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE ConstraintKinds, DataKinds, FlexibleContexts, NoImplicitPrelude, + PolyKinds, RebindableSyntax, ScopedTypeVariables, + TypeFamilies, TypeOperators #-} + +-- | CT-specific functions for embedding/twacing in various bases + +module Crypto.Lol.Cyclotomic.Tensor.CTensor.Extension +( embedPow', embedDec', embedCRT' +, twacePowDec' -- , twaceCRT' +, coeffs', powBasisPow' +, crtSetDec' +, backpermute' +) where + +import Crypto.Lol.CRTrans +import Crypto.Lol.LatticePrelude as LP hiding (null, lift) +import Crypto.Lol.Cyclotomic.Tensor as T +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 qualified Data.Vector.Storable as SV + + +-- | /O(n)/ Yield the vector obtained by replacing each element @i@ of the +-- index vector by @xs'!'i@. This is equivalent to @'map' (xs'!') is@ but is +-- often much more efficient. +-- +-- > backpermute <0,3,2,3,1,0> = +backpermute' :: (Vector v a) + => U.Vector Int -- ^ @is@ index vector (of length @n@) + -> v a -- ^ @xs@ value vector + -> v a +--{-# INLINE backpermute' #-} +backpermute' is v = generate (G.length is) (\i -> v ! (is ! i)) + +embedPow', embedDec' :: (Additive r, Vector v r, m `Divides` m') + => 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 -> + let (j0,j1) = indices ! idx + in if j0 == 0 + then arr ! j1 + else zero) <$> baseIndicesPow +-- | Embeds an vector in the decoding basis of the the mth cyclotomic ring +-- to an vector in the decoding basis of the m'th cyclotomic ring when @m | m'@ +embedDec' = (\indices arr -> generate (U.length indices) + (\idx -> maybe LP.zero + (\(sh,b) -> if b then negate (arr ! sh) else arr ! sh) + (indices U.! idx))) <$> baseIndicesDec + +-- | 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))) >> + (pureT $ backpermute' <$> baseIndicesCRT) + +-- | maps a vector in the powerful/decoding basis, representing an +-- O_m' element, to a vector of arrays representing O_m elements in +-- the same type of basis +coeffs' :: (Vector v r, m `Divides` m') + => Tagged '(m, m') (v r -> [v r]) +coeffs' = flip (\x -> V.toList . V.map (`backpermute'` x)) + <$> extIndicesCoeffs + +-- | The "tweaked trace" function in either the powerful or decoding +-- 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) +twacePowDec' = backpermute' <$> extIndicesPowDec + + +-- EAC: twaceCRT is defined in CTensor because it needs access to C-backend functions + + +-- | The powerful extension basis, wrt the powerful basis. +-- Outputs a list of vectors in O_m' that are an O_m basis for O_m' +powBasisPow' :: forall m m' r . (m `Divides` m', Ring r, SV.Storable r) + => Tagged '(m, m') [SV.Vector r] +powBasisPow' = do + (_, phi, phi', _) <- indexInfo + idxs <- baseIndicesPow + 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] + +-- | A list of vectors representing the mod-p CRT set of the +-- extension O_m'/O_m +crtSetDec' :: forall m m' fp . + (m `Divides` m', PrimeField fp, Coprime (PToF (CharOf fp)) m', SV.Storable fp) + => Tagged '(m, m') [SV.Vector fp] +crtSetDec' = + let m'p = Proxy :: Proxy m' + p = proxy valuePrime (Proxy::Proxy (CharOf fp)) + phi = proxy totientFact m'p + d = proxy (order p) m'p + h :: Int = proxy valueHatFact m'p + hinv = recip $ fromIntegral h + in reify d $ \(_::Proxy d) -> do + let twCRTs' :: Matrix (GF fp d) + = fromMaybe (error "internal error: crtSetDec': twCRTs") $ proxyT twCRTs m'p + zmsToIdx = proxy T.zmsToIndexFact m'p + elt j i = indexM twCRTs' j (zmsToIdx i) + trace' = trace :: GF fp d -> fp -- to avoid recomputing powTraces + cosets <- partitionCosets p + return $ LP.map (\is -> generate phi + (\j -> hinv * trace' + (sum $ LP.map (elt j) is))) cosets diff --git a/Crypto/Lol/Cyclotomic/Tensor/CTensor/basic.c b/Crypto/Lol/Cyclotomic/Tensor/CTensor/basic.c new file mode 100644 --- /dev/null +++ b/Crypto/Lol/Cyclotomic/Tensor/CTensor/basic.c @@ -0,0 +1,175 @@ +#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/crt.c b/Crypto/Lol/Cyclotomic/Tensor/CTensor/crt.c new file mode 100644 --- /dev/null +++ b/Crypto/Lol/Cyclotomic/Tensor/CTensor/crt.c @@ -0,0 +1,1386 @@ +#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/g.c b/Crypto/Lol/Cyclotomic/Tensor/CTensor/g.c new file mode 100644 --- /dev/null +++ b/Crypto/Lol/Cyclotomic/Tensor/CTensor/g.c @@ -0,0 +1,828 @@ +#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= 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 new file mode 100644 --- /dev/null +++ b/Crypto/Lol/Cyclotomic/Tensor/CTensor/l.c @@ -0,0 +1,434 @@ +#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/norm.c b/Crypto/Lol/Cyclotomic/Tensor/CTensor/norm.c new file mode 100644 --- /dev/null +++ b/Crypto/Lol/Cyclotomic/Tensor/CTensor/norm.c @@ -0,0 +1,86 @@ +#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/random.c b/Crypto/Lol/Cyclotomic/Tensor/CTensor/random.c new file mode 100644 --- /dev/null +++ b/Crypto/Lol/Cyclotomic/Tensor/CTensor/random.c @@ -0,0 +1,74 @@ + +#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/tensorTypes.h b/Crypto/Lol/Cyclotomic/Tensor/CTensor/tensorTypes.h new file mode 100644 --- /dev/null +++ b/Crypto/Lol/Cyclotomic/Tensor/CTensor/tensorTypes.h @@ -0,0 +1,231 @@ + +#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/RepaTensor.hs b/Crypto/Lol/Cyclotomic/Tensor/RepaTensor.hs new file mode 100644 --- /dev/null +++ b/Crypto/Lol/Cyclotomic/Tensor/RepaTensor.hs @@ -0,0 +1,258 @@ +{-# LANGUAGE ConstraintKinds, DataKinds, FlexibleContexts, + FlexibleInstances, GADTs, MultiParamTypeClasses, + NoImplicitPrelude, PolyKinds, RebindableSyntax, + RoleAnnotations, ScopedTypeVariables, StandaloneDeriving, + TypeFamilies, TypeOperators, UndecidableInstances #-} + +-- | A pure, repa-based implementation of the Tensor interface. + +module Crypto.Lol.Cyclotomic.Tensor.RepaTensor +( RT ) where + +import Crypto.Lol.Cyclotomic.Tensor as T +import Crypto.Lol.Cyclotomic.Tensor.RepaTensor.CRT +import Crypto.Lol.Cyclotomic.Tensor.RepaTensor.Dec +import Crypto.Lol.Cyclotomic.Tensor.RepaTensor.Extension +import Crypto.Lol.Cyclotomic.Tensor.RepaTensor.GL +import Crypto.Lol.Cyclotomic.Tensor.RepaTensor.RTCommon as RT +import Crypto.Lol.LatticePrelude as LP hiding + ((!!)) +import Crypto.Lol.Reflects +import Crypto.Lol.Types.FiniteField as FF +import Crypto.Lol.Types.IZipVector + +import Algebra.Additive as Additive (C) +import Algebra.Module as Module (C) +import Algebra.ZeroTestable as ZeroTestable (C) + +import Control.Applicative hiding ((*>)) +import Control.Arrow hiding (arr) +import Control.DeepSeq (NFData (rnf)) +import Control.Monad.Random +import Data.Coerce +import Data.Constraint hiding ((***)) +import Data.Foldable as F +import Data.Maybe +import Data.Traversable as T +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. +data RT (m :: Factored) r where + RT :: Unbox r => !(Arr m r) -> RT m r + ZV :: IZipVector m r -> RT m r + +deriving instance Show r => Show (RT m r) + +instance Eq r => Eq (RT m r) where + (ZV a) == (ZV b) = a == b + (RT a) == (RT b) = a == b + a@(RT _) == b = a == toRT b + a == b@(RT _) = toRT a == b + {-# INLINABLE (==) #-} + +zvToArr :: Unbox r => IZipVector m r -> Arr m r +zvToArr v = let vec = convert $ unIZipVector v + in Arr $ fromUnboxed (Z :. U.length vec) vec + +-- converts to RT constructor +toRT :: Unbox r => RT m r -> RT m r +toRT v@(RT _) = v +toRT (ZV v) = RT $ zvToArr v + +toZV :: Fact m => RT m r -> RT m r +toZV (RT (Arr v)) = ZV $ fromMaybe (error "toZV: internal error") $ + iZipVector $ convert $ toUnboxed v +toZV v@(ZV _) = v + +{-# INLINABLE wrap #-} +wrap :: Unbox r => (Arr l r -> Arr m r) -> RT l r -> RT m r +wrap f (RT v) = RT $ f v +wrap f (ZV v) = RT $ f $ zvToArr v + +{-# INLINABLE wrapM #-} +wrapM :: (Unbox r, Monad mon) => (Arr l r -> mon (Arr m r)) + -> RT l r -> mon (RT m r) +wrapM f (RT v) = RT <$> f v +wrapM f (ZV v) = RT <$> f (zvToArr v) + +instance Tensor RT where + + type TElt RT r = (Unbox r, Elt r) + + 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 + entailModuleT = tag $ Sub Dict + + scalarPow = RT . scalarPow' + + l = wrap fL + lInv = wrap fLInv + + mulGPow = wrap fGPow + mulGDec = wrap fGDec + + divGPow = wrapM fGInvPow + divGDec = wrapM fGInvDec + + crtFuncs = (,,,,) <$> + ((RT .) <$> scalarCRT') <*> + (wrap <$> mulGCRT') <*> + (wrap <$> divGCRT') <*> + (wrap <$> fCRT) <*> + (wrap <$> fCRTInv) + + tGaussianDec = fmap RT . tGaussianDec' + + gSqNormDec (RT e) = gSqNormDec' e + gSqNormDec e = gSqNormDec $ toRT e + + twacePowDec = wrap twacePowDec' + + embedPow = wrap embedPow' + embedDec = wrap embedDec' + + crtExtFuncs = (,) <$> (wrap <$> twaceCRT') <*> (wrap <$> embedCRT') + + coeffs = wrapM coeffs' + + powBasisPow = (RT <$>) <$> powBasisPow' + + crtSetDec = (RT <$>) <$> crtSetDec' + + fmapT f (RT v) = RT $ (coerce $ force . RT.map f) v + fmapT f v@(ZV _) = fmapT f $ toRT v + + -- Repa arrays don't have mapM, so apply to underlying Unboxed + -- vector instead + fmapTM f (RT (Arr arr)) = (RT . Arr . fromUnboxed (extent arr)) <$> + U.mapM f (toUnboxed arr) + fmapTM f v = fmapTM f $ toRT v + + 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 + + {-# INLINABLE entailIndexT #-} + {-# INLINABLE entailEqT #-} + {-# INLINABLE entailZTT #-} + {-# INLINABLE entailNFDataT #-} + {-# INLINABLE entailRandomT #-} + {-# INLINABLE entailShowT #-} + {-# INLINABLE scalarPow #-} + {-# INLINABLE l #-} + {-# INLINABLE lInv #-} + {-# INLINABLE mulGPow #-} + {-# INLINABLE mulGDec #-} + {-# INLINABLE divGPow #-} + {-# INLINABLE divGDec #-} + {-# INLINABLE crtFuncs #-} + {-# INLINABLE twacePowDec #-} + {-# INLINABLE embedPow #-} + {-# INLINABLE embedDec #-} + {-# INLINABLE tGaussianDec #-} + {-# INLINABLE gSqNormDec #-} + {-# INLINABLE crtExtFuncs #-} + {-# INLINABLE coeffs #-} + {-# INLINABLE powBasisPow #-} + {-# INLINABLE crtSetDec #-} + {-# INLINABLE fmapT #-} + {-# INLINABLE fmapTM #-} + {-# INLINABLE zipWithT #-} + {-# INLINABLE unzipTElt #-} + {-# INLINABLE unzipT #-} + + +---------- Category-theoretic instances ---------- + +instance Fact m => Functor (RT m) where + -- Functor instance is implied by Applicative + fmap f x = pure f <*> x + +instance Fact m => Applicative (RT m) where + pure = ZV . pure + + -- RT can never hold an a -> b + (ZV f) <*> (ZV a) = ZV (f <*> a) + f@(ZV _) <*> v@(RT _) = f <*> toZV v + +instance Fact m => Foldable (RT m) where + -- Foldable instance is implied by Traversable + foldMap = foldMapDefault + +instance Fact m => Traversable (RT m) where + traverse f r@(RT _) = T.traverse f $ toZV r + traverse f (ZV v) = ZV <$> T.traverse f v + + +---------- Numeric Prelude instances ---------- + +--CJP: Additive, Ring are not necessary when we use zipWithT +--EAC: But we need an Additive instance for the Module instance + +instance (Unbox r, Additive (Arr m r)) => Additive.C (RT m r) where + zero = RT zero + + (RT a) + (RT b) = RT $ a + b + a + b = toRT a + toRT b + + (RT a) - (RT b) = RT $ a - b + a - b = toRT a - toRT b + + negate (RT a) = RT $ negate a + negate a = negate $ toRT a + + {-# INLINABLE (+) #-} + {-# INLINABLE (-) #-} + {-# INLINABLE zero #-} + {-# INLINABLE negate #-} + +{- +instance (Unbox r, Ring (Arr m r)) => Ring.C (RT m r) where + (RT a) * (RT b) = RT $ a * b + a * b = toRT a * toRT b + + fromInteger = RT . fromInteger + {-# INLINABLE (*) #-} + {-# INLINABLE fromInteger #-} +-} + +instance (ZeroTestable (Arr m r), ZeroTestable (IZipVector m r)) + => ZeroTestable.C (RT m r) where + isZero (RT a) = isZero a + isZero (ZV v) = isZero v + {-# INLINABLE isZero #-} + +instance (GFCtx fp d, Fact m, Additive (RT m fp)) + => 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 + +---------- Miscellaneous instances ---------- + +instance (Unbox r, Random (Arr m r)) => Random (RT m r) where + random = runRand $ RT <$> (liftRand random) + + randomR = error "randomR nonsensical for RT" + +instance (Unbox r, Arbitrary (Arr m r)) => Arbitrary (RT m r) where + arbitrary = RT <$> arbitrary + +instance (NFData r) => NFData (RT m r) where + rnf (RT v) = rnf v + rnf (ZV v) = rnf v diff --git a/Crypto/Lol/Cyclotomic/Tensor/RepaTensor/CRT.hs b/Crypto/Lol/Cyclotomic/Tensor/RepaTensor/CRT.hs new file mode 100644 --- /dev/null +++ b/Crypto/Lol/Cyclotomic/Tensor/RepaTensor/CRT.hs @@ -0,0 +1,215 @@ +{-# LANGUAGE ConstraintKinds, FlexibleContexts, GADTs, NoImplicitPrelude, + ScopedTypeVariables #-} + +-- | Functions to support the chinese remainder transform on Repa arrays + +module Crypto.Lol.Cyclotomic.Tensor.RepaTensor.CRT +( scalarCRT' +, fCRT, fCRTInv +, mulGCRT', divGCRT' +, gCRT, gInvCRT +) where + +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 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) +{-# INLINABLE scalarCRT' #-} +scalarCRT' + = let pps = proxy ppsFact (Proxy::Proxy m) + sz = Z :. totientPPs pps + 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) +{-# 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) +{-# INLINABLE divGCRT' #-} +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) + +-- | 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) +{-# INLINABLE gInvCRT #-} +gInvCRT = fCRT <*> fGInvPow (scalarPow' LP.one) + +fCRT, fCRTInv :: + forall m r . (Fact m, CRTrans r, Unbox r, Elt r) + => Maybe (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. +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) + 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) + +{-# INLINABLE ppDFT #-} +{-# INLINABLE ppDFTInv' #-} +{-# INLINABLE ppCRT #-} +{-# INLINABLE ppCRTInv' #-} + +ppDFT = case (sing :: SPrimePower pp) of + (SPP (STuple2 sp SO)) -> tagT $ withWitnessT pDFT sp + spp@(SPP (STuple2 sp (SS se'))) -> + tagT $ do + let spp' = SPP (STuple2 sp se') + pp'dft <- withWitnessT ppDFT spp' + pptwid <- withWitnessT (ppTwid False) spp + pdft <- withWitnessT pDFT sp + return $ (pp'dft @* Id (dim pdft)) .* pptwid .* (Id (dim pp'dft) @* pdft) + +ppDFTInv' = case (sing :: SPrimePower pp) of + (SPP (STuple2 sp SO)) -> tagT $ withWitnessT pDFTInv' sp + spp@(SPP (STuple2 sp (SS se'))) -> + tagT $ do + let spp' = SPP (STuple2 sp se') + pp'dftInv' <- withWitnessT ppDFTInv' spp' + pptwidInv <- withWitnessT (ppTwid True) spp + pdftInv' <- withWitnessT pDFTInv' sp + return $ (Id (dim pp'dftInv') @* pdftInv') .* pptwidInv .* + (pp'dftInv' @* Id (dim pdftInv')) + +ppCRT = case (sing :: SPrimePower pp) of + (SPP (STuple2 sp SO)) -> tagT $ withWitnessT pCRT sp + spp@(SPP (STuple2 sp (SS se'))) -> + tagT $ do + let spp' = SPP (STuple2 sp se') + pp'dft <- withWitnessT ppDFT spp' + pptwid <- withWitnessT (ppTwidHat False) spp + pcrt <- withWitnessT pCRT sp + return $ + (pp'dft @* Id (dim pcrt)) .* pptwid .* + -- save some work when p=2 + (if dim pcrt > 1 then Id (dim pp'dft) @* pcrt else Id (dim pp'dft)) + +ppCRTInv' = case (sing :: SPrimePower pp) of + (SPP (STuple2 sp SO)) -> tagT $ withWitnessT pCRTInv' sp + spp@(SPP (STuple2 sp (SS se'))) -> + tagT $ do + let spp' = SPP (STuple2 sp se') + pp'dftInv' <- withWitnessT ppDFTInv' spp' + pptwidInv <- withWitnessT (ppTwidHat True) spp + pcrtInv' <- withWitnessT pCRTInv' sp + return $ + (Id (dim pp'dftInv') @* pcrtInv') .* pptwidInv .* + (pp'dftInv' @* Id (dim pcrtInv')) + +butterfly :: (Additive r, Unbox r, Elt r) => Trans r +butterfly = trans 2 $ \arr -> + fromFunction (extent arr) $ + \(sh:.j) -> case j of + 0 -> arr ! (sh:.0) + + arr ! (sh:.1) + 1 -> arr ! (sh:.0) - + arr ! (sh:.1) + +-- 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) + +{-# INLINABLE pDFT #-} +{-# INLINABLE pDFTInv' #-} +{-# INLINABLE pCRT #-} +{-# INLINABLE pCRTInv' #-} + +pDFT = let pval = proxy valuePrime (Proxy::Proxy p) + in if pval == 2 + then return butterfly + else do (omegaPPow, _) <- crtInfoPrime + return $ trans pval $ mulMat $ force $ + fromFunction (Z :. pval :. pval) + (\(Z:.i:.j) -> omegaPPow (i*j)) + +pDFTInv' = let pval = proxy valuePrime (Proxy::Proxy p) + in if pval == 2 + then return butterfly + else do (omegaPPow, _) <- crtInfoPrime + return $ trans pval $ mulMat $ force $ + fromFunction (Z :. pval :. pval) + (\(Z:.i:.j) -> omegaPPow (-i*j)) + +pCRT = let pval = proxy valuePrime (Proxy::Proxy p) + in if pval == 2 + then return $ Id 1 + else do (omegaPPow, _) <- crtInfoPrime + return $ trans (pval-1) $ mulMat $ force $ + fromFunction (Z :. pval-1 :. pval-1) + (\(Z:.i:.j) -> omegaPPow ((i+1)*j)) + +-- crt_p * this = \hat{p}*I, for all prime p. +pCRTInv' = + let pval = proxy valuePrime (Proxy::Proxy p) + in if pval == 2 then return $ Id 1 + else do + (omegaPPow, _) <- crtInfoPrime + return $ trans (pval-1) $ mulMat $ force $ + fromFunction (Z :. pval-1 :. pval-1) + (\(Z:.i:.j) -> omegaPPow (negate i*(j+1)) - + omegaPPow (j+1)) + +-- 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) + +{-# INLINABLE ppTwid #-} +{-# INLINABLE ppTwidHat #-} + +ppTwid inv = + let pp@(p,e) = proxy ppPPow (Proxy :: Proxy pp) + ppval = valuePP pp + in do + (omegaPPPow, _) <- crtInfoPPow + return $ trans ppval $ mulDiag $ force $ + fromFunction (Z :. ppval) + (\(Z:.i) -> let (iq,ir) = i `divMod` p + pow = (if inv then negate else id) + ir * digitRev (p,e-1) iq + in omegaPPPow pow) + +ppTwidHat inv = + let pp@(p,e) = proxy ppPPow (Proxy :: Proxy pp) + pptot = totientPP pp + in do + (omegaPPPow, _) <- crtInfoPPow + return $ trans pptot $ mulDiag $ force $ + fromFunction (Z :. pptot) + (\(Z:.i) -> let (iq,ir) = i `divMod` (p-1) + pow = (if inv then negate else id) + (ir+1) * digitRev (p,e-1) iq + in omegaPPPow pow) diff --git a/Crypto/Lol/Cyclotomic/Tensor/RepaTensor/Dec.hs b/Crypto/Lol/Cyclotomic/Tensor/RepaTensor/Dec.hs new file mode 100644 --- /dev/null +++ b/Crypto/Lol/Cyclotomic/Tensor/RepaTensor/Dec.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE ConstraintKinds, FlexibleContexts, NoImplicitPrelude, + RebindableSyntax, ScopedTypeVariables #-} + +-- | Linear transforms and operations related to the decoding basis. + +module Crypto.Lol.Cyclotomic.Tensor.RepaTensor.Dec +( tGaussianDec', gSqNormDec' ) where + +import Crypto.Lol.Cyclotomic.Tensor.RepaTensor.RTCommon as R +import Crypto.Lol.GaussRandom +import Crypto.Lol.LatticePrelude + +import Control.Monad.Random + +-- | Given @v=r^2@, yields the decoding-basis coefficients of a sample +-- from the tweaked Gaussian @t_m \cdot D_r@. +tGaussianDec' :: forall m v r rnd . + (Fact m, OrdFloat r, Random r, Unbox r, Elt r, + ToRational v, MonadRandom rnd) + => v -> rnd (Arr m r) +tGaussianDec' = + let pm = Proxy::Proxy m + m = proxy valueFact pm + n = proxy totientFact pm + rad = proxy radicalFact pm + in \v -> do -- rnd monad + x <- realGaussians (v * fromIntegral (m `div` rad)) n + let arr = Arr $ fromUnboxed (Z:.n) x + return $ fE arr + +-- | The @E_m@ transformation for an arbitrary @m@. +fE :: (Fact m, Transcendental r, Unbox r, Elt r) => Arr m r -> Arr m r +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) + => Tagged p (Trans r) +pE = let pval = proxy valuePrime (Proxy::Proxy p) + in tag $ if pval==2 then Id 1 + else trans (pval-1) $ mulMat $ force $ + fromFunction (Z :. pval-1 :. pval-1) + (\(Z:.i:.j) -> + -- sqrt(2)*[ cos(2pi*i*(j+1)/p) | sin(same) ] + -- (signs of columns doesn't matter for our purposes.) + let theta = 2 * pi * fromIntegral (i*(j+1)) / + fromIntegral pval + in sqrt 2 * if j < pval `div` 2 + then cos theta else sin theta) + +-- | Given coefficient tensor @e@ with respect to the decoding basis +-- of @R@, yield the (scaled) squared norm of @g_m \cdot e@ under +-- the canonical embedding, namely, +-- @\hat{m}^{ -1 } \cdot || \sigma(g_m -- \cdot e) ||^2@ . +gSqNormDec' :: (Fact m, Ring r, Unbox r, Elt r) => Arr m r -> r +gSqNormDec' e@(Arr ae) = let (Arr ae') = fGramDec' e + -- use sumAllP (define it in RTCommon)? + in sumAllS $ force $ R.zipWith (*) ae ae' + +-- | Multiply by @\hat{m}@ times the Gram matrix of decoding basis of +-- @R^vee@. +fGramDec' :: (Fact m, Ring r, Unbox r, Elt r) => Arr m r -> Arr m r +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 = + let pval = proxy valuePrime (Proxy::Proxy p) + in tag $ if pval==2 then Id 1 + else trans (pval-1) $ + \arr -> let sums = sumS arr + in fromFunction (extent arr) + (\sh@(sh' :. _) -> arr ! sh + sums ! sh') + + diff --git a/Crypto/Lol/Cyclotomic/Tensor/RepaTensor/Extension.hs b/Crypto/Lol/Cyclotomic/Tensor/RepaTensor/Extension.hs new file mode 100644 --- /dev/null +++ b/Crypto/Lol/Cyclotomic/Tensor/RepaTensor/Extension.hs @@ -0,0 +1,193 @@ +{-# LANGUAGE BangPatterns, ConstraintKinds, DataKinds, FlexibleContexts, + FlexibleInstances, MultiParamTypeClasses, NoImplicitPrelude, + PolyKinds, ScopedTypeVariables, TemplateHaskell, TypeFamilies, + TypeOperators #-} + +-- | RT-specific functions for embedding/twacing in various bases + +module Crypto.Lol.Cyclotomic.Tensor.RepaTensor.Extension +( twacePowDec', twaceCRT', embedPow', embedDec', embedCRT' +, 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 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 Control.Applicative +import Control.Arrow (first, (***)) + +import Data.Coerce +import Data.Default +import Data.Maybe +import Data.Reflection (reify) +import qualified Data.Vector as V +import qualified Data.Vector.Unboxed as U +import Data.Vector.Unboxed.Deriving + +-- Default instances +instance Default Z where def = Z +instance (Default a, Default b) => Default (a:.b) where def = def:.def + +-- derived Unbox instances +derivingUnbox "DIM1" + [t| (Z:.Int) -> Int |] + [| \(Z:.i) -> i |] + [| (Z :.) |] + +-- | The "tweaked trace" function in either the powerful or decoding +-- 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 +twacePowDec' + = let indices = proxy extIndicesPowDec (Proxy::Proxy '(m, m')) + 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 +-- @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 + g' :: Arr m' r <- gCRT + gInv <- gInvCRT + embed :: Arr m r -> Arr m' r <- embedCRT' + (_, m'hatinv) <- proxyT crtInfoFact (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 $ + -- take true trace after mul-by-tweak + coerce (\ !arr -> sumS . backpermute (extent indices) (indices !) . RT.zipWith (*) arr) tweak + +embedPow', embedDec' :: forall m m' r . + (m `Divides` m', Unbox r, Additive r) + => Arr m r -> Arr m' r +-- | Embeds an array in the powerful basis of the the mth cyclotomic ring +-- to an array in the powerful basis of the m'th cyclotomic ring when @m | m'@ +embedPow' + = let indices = proxy baseIndicesPow (Proxy::Proxy '(m, m')) + in coerce $ \ !arr -> force $ fromFunction (extent indices) + (\idx -> let (j0,j1) = (indices ! idx) + in if j0 == 0 then arr ! j1 else zero) +-- | Embeds an array in the decoding basis of the the mth cyclotomic ring +-- to an array in the decoding basis of the m'th cyclotomic ring when @m | m'@ +embedDec' + = let indices = proxy baseIndicesDec (Proxy::Proxy '(m, m')) + in coerce $ \ !arr -> force $ + fromFunction (extent indices) + (\idx -> maybe zero + (\(sh,b) -> if b then negate (arr ! sh) + else arr ! sh) + (indices ! idx)) + +-- | 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 + -- first check existence of CRT transform of index m' + proxyT crtInfoFact (Proxy::Proxy m') :: Maybe (CRTInfo r) + let idxs = proxy baseIndicesCRT (Proxy::Proxy '(m,m')) + return $ coerce $ \ !arr -> (force $ backpermute (extent idxs) (idxs !) arr) + +-- | maps an array in the powerful/decoding basis, representing an +-- O_m' element, to an array of arrays representing O_m elements in +-- the same type of basis +coeffs' :: forall m m' r . (m `Divides` m', Unbox r) + => Arr m' r -> [Arr m r] +coeffs' = + let indices = proxy extIndicesCoeffs (Proxy::Proxy '(m, m')) + in coerce $ \ !arr -> V.toList $ + V.map (\idxs -> force $ backpermute (extent idxs) (idxs !) arr) indices + +-- | The powerful extension basis, wrt the powerful basis. +-- 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 $ + 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') + (\(Z:.j) -> let (j0,j1) = idxs U.! j + in if j0==k && j1==0 then one else zero)) + [0..phi' `div` phi - 1] + +-- | A list of arrays representing the mod-p CRT set of the +-- extension O_m'/O_m +crtSetDec' :: forall m m' fp . + (m `Divides` m', PrimeField fp, Coprime (PToF (CharOf fp)) m', + Unbox fp) + => Tagged m [Arr m' fp] +crtSetDec' = return $ + let m'p = Proxy :: Proxy m' + p = proxy valuePrime (Proxy::Proxy (CharOf fp)) + phi = proxy totientFact m'p + + d = proxy (order p) m'p + h :: Int = proxy valueHatFact m'p + hinv = recip $ fromIntegral h + in reify d $ \(_::Proxy d) -> + let twCRTs' :: T.Matrix (GF fp d) + = fromMaybe (error "internal error: crtSetDec': twCRTs") $ proxyT T.twCRTs m'p + zmsToIdx = proxy T.zmsToIndexFact m'p + 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) + (\(Z:.j) -> hinv * trace' + (sum $ LP.map (elt j) is))) cosets + + +-- convert memoized reindexing Vectors to Arrays, for convenience and speed + +extIndicesPowDec :: forall m m' . (m `Divides` m') + => Tagged '(m, m') (Array U DIM1 DIM1) +extIndicesPowDec = do + idxs <- T.extIndicesPowDec + return $ fromUnboxed (Z :. U.length idxs) $ U.map (Z:.) idxs + +extIndicesCRT :: forall m m' . (m `Divides` m') + => Tagged '(m, m') (Array U DIM2 DIM1) +extIndicesCRT = + let phi = proxy totientFact (Proxy::Proxy m) + phi' = proxy totientFact (Proxy::Proxy m') + in do + idxs <- T.extIndicesCRT + return $ fromUnboxed (Z :. phi :. phi' `div` phi) $ U.map (Z:.) idxs + +baseIndicesPow :: forall m m' . (m `Divides` m') + => Tagged '(m, m') (Array U DIM1 (Int,DIM1)) + +baseIndicesDec :: forall m m' . (m `Divides` m') + => Tagged '(m, m') (Array U DIM1 (Maybe (DIM1, Bool))) + +baseIndicesCRT :: forall m m' . (m `Divides` m') + => Tagged '(m, m') (Array U DIM1 DIM1) + +baseIndicesPow = do + idxs <- T.baseIndicesPow + return $ fromUnboxed (Z :. U.length idxs) $ U.map (id *** (Z:.)) idxs + +baseIndicesDec = do + idxs <- T.baseIndicesDec + return $ fromUnboxed (Z :. U.length idxs) $ U.map (liftA (first (Z:.))) idxs + +baseIndicesCRT = do + idxs <- T.baseIndicesCRT + return $ fromUnboxed (Z :. U.length idxs) $ U.map (Z:.) idxs + +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) $ + U.map (Z:.) arr) <$> T.extIndicesCoeffs diff --git a/Crypto/Lol/Cyclotomic/Tensor/RepaTensor/GL.hs b/Crypto/Lol/Cyclotomic/Tensor/RepaTensor/GL.hs new file mode 100644 --- /dev/null +++ b/Crypto/Lol/Cyclotomic/Tensor/RepaTensor/GL.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE BangPatterns, ConstraintKinds, FlexibleContexts, GADTs, + MultiParamTypeClasses, NoImplicitPrelude, RankNTypes, + RebindableSyntax, ScopedTypeVariables #-} + +-- | The @G@ and @L@ transforms for Repa arrays. + +module Crypto.Lol.Cyclotomic.Tensor.RepaTensor.GL +( fL, fLInv, fGPow, fGDec, fGInvPow, fGInvDec +) where + +import Crypto.Lol.Cyclotomic.Tensor.RepaTensor.RTCommon as RT +import Crypto.Lol.LatticePrelude as LP +import Data.Coerce + +fL, fLInv, fGPow, fGDec :: (Fact m, Additive r, Unbox r, Elt r) + => Arr m r -> Arr m r +{-# INLINABLE fL #-} +{-# INLINABLE fLInv #-} +{-# INLINABLE fGPow #-} +{-# INLINABLE fGDec #-} + +fGInvPow, fGInvDec :: + (Fact m, IntegralDomain r, ZeroTestable r, Unbox r, Elt r) + => Arr m r -> Maybe (Arr m r) +{-# INLINABLE fGInvPow #-} +{-# INLINABLE fGInvDec #-} + +-- | Arbitrary-index @L@ transform, which converts from decoding-basis +-- to powerful-basis representation. +fL = eval $ fTensor $ ppTensor pL +-- | Arbitrary-index @L^{ -1 }@ transform, which converts from +-- powerful-basis to decoding-basis representation. +fLInv = eval $ fTensor $ ppTensor pLInv +-- | Arbitrary-index multiplication by @g_m@ in the powerful basis. +fGPow = eval $ fTensor $ ppTensor pGPow +-- | Arbitrary-index multiplication by @g_m@ in the decoding basis. +fGDec = eval $ fTensor $ ppTensor pGDec +-- | Arbitrary-index division by @g_m@ in the powerful +-- basis. Outputs 'Nothing' if the input is not evenly divisible by +-- @g_m@. Warning: not constant time! +fGInvPow = wrapGInv' pGInvPow' +-- | Arbitrary-index division by @g_m@ in the decoding +-- basis. Outputs 'Nothing' if the input is no evenly divisible by +-- @g_m@. Warning: not constant time! +fGInvDec = wrapGInv' pGInvDec' + +wrapGInv' :: forall m r . + (Fact m, IntegralDomain r, ZeroTestable r, Unbox r, Elt r) + => (forall p . Prim p => Tagged p (Trans r)) + -> Arr m r -> Maybe (Arr m r) +wrapGInv' ginv = + let fGInv = eval $ fTensor $ ppTensor ginv + oddrad = fromIntegral $ proxy oddRadicalFact (Proxy::Proxy m) + in (`divCheck` oddrad) . fGInv +{-# INLINABLE wrapGInv' #-} + +-- | This is not a constant-time algorithm! Depending on its usage, +-- it might provide a timing side-channel. +divCheck :: (IntegralDomain r, ZeroTestable r, Unbox r) + => Arr m r -> r -> Maybe (Arr m r) +divCheck = coerce $ \ !arr den -> + let qrs = force $ RT.map (`divMod` den) arr + pass = foldAllS (&&) True $ RT.map (isZero . snd) qrs + out = force $ RT.map fst qrs + in if pass then Just out else Nothing +{-# INLINABLE divCheck #-} + +pWrap :: forall p r . Prim 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) + -- special case: return identity function for p=2 + in return $ if pval > 2 + then trans (pval-1) $ f pval + else Id 1 +{-# INLINABLE pWrap #-} + + +pL, pLInv, pGPow, pGDec :: (Prim p, Additive r, Unbox r, Elt r) + => Tagged p (Trans r) + +pGInvPow', pGInvDec' :: (Prim p, Ring r, Unbox r, Elt r) + => Tagged p (Trans r) +{-# INLINABLE pL #-} +{-# INLINABLE pLInv #-} +{-# INLINABLE pGPow #-} +{-# INLINABLE pGDec #-} +{-# INLINABLE pGInvPow' #-} +{-# INLINABLE pGInvDec' #-} + +pL = pWrap (\_ !arr -> + fromFunction (extent arr) $ + \ (i':.i) -> sumAllS $ extract (Z:.0) (Z:.(i+1)) $ slice arr (i':.All)) + +pLInv = pWrap (\_ !arr -> + let f (i' :. 0) = arr! (i' :. 0) + f (i' :. i) = arr! (i' :. i) - arr! (i' :. i-1) + in fromFunction (extent arr) f) + + +-- multiplicaton by g_p=1-zeta_p in power basis. +-- this is "wrong" for p=2 but we never use that case thanks to pWrap. +pGPow = pWrap (\p !arr -> + let f (i':.0) = arr! (i':.p-2) + arr! (i':.0) + f (i':.i) = arr! (i':.p-2) + arr! (i':.i) - arr! (i':.i-1) + in fromFunction (extent arr) f) + +-- multiplication by g_p=1-zeta_p in decoding basis +pGDec = pWrap (\_ !arr -> + let f (i':.0) = arr! (i':.0) + sumAllS (slice arr (i':.All)) + f (i':.i) = arr! (i':.i) - arr! (i':.i-1) + in fromFunction (extent arr) f) + +-- CJP: profiling suggests that this does two read passes through the +-- array; see if we can rewrite to make it one + +-- doesn't do division by (odd) p +pGInvPow' = + pWrap (\p !arr -> + let f (i':.i) = + let col = slice arr (i':.All) + in fromIntegral (p-i-1) * sumAllS (extract (Z:.0) (Z:.i+1) col) + + fromIntegral (-i-1) * sumAllS (extract (Z:.i+1) (Z:.p-i-2) col) + in fromFunction (extent arr) f) + +-- doesn't do division by (odd) p +pGInvDec' = + pWrap (\p !arr -> + let f (i':.i) = + let col = slice arr (i':.All) + nats = fromFunction (Z:.p-1) (\(Z:.j) -> fromIntegral j+1) + in (sumAllS $ RT.zipWith (*) col nats) - + fromIntegral p * sumAllS (extract (Z:.i+1) (Z:.p-i-2) col) + in fromFunction (extent arr) f) diff --git a/Crypto/Lol/Cyclotomic/Tensor/RepaTensor/RTCommon.hs b/Crypto/Lol/Cyclotomic/Tensor/RepaTensor/RTCommon.hs new file mode 100644 --- /dev/null +++ b/Crypto/Lol/Cyclotomic/Tensor/RepaTensor/RTCommon.hs @@ -0,0 +1,277 @@ +{-# LANGUAGE BangPatterns, ConstraintKinds, DataKinds, FlexibleContexts, + FlexibleInstances, GADTs, GeneralizedNewtypeDeriving, + KindSignatures, MultiParamTypeClasses, NoImplicitPrelude, + RankNTypes, RebindableSyntax, RoleAnnotations, + ScopedTypeVariables, TypeOperators #-} + +-- | A simple DSL for tensoring Repa arrays and other common functionality +-- on Repa arrays + +module Crypto.Lol.Cyclotomic.Tensor.RepaTensor.RTCommon +( module R +, module Data.Array.Repa.Eval +, module Data.Array.Repa.Repr.Unboxed +, Arr(..), repl, replM, eval, evalM, fTensor, ppTensor +, Trans(Id), trans, dim, (.*), (@*), force +, mulMat, mulDiag +, scalarPow' +, sumS, sumAllS +) where + +import Crypto.Lol.LatticePrelude as LP hiding ((!!)) + +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.Random +import Data.Array.Repa as R hiding (sumAllP, sumAllS, sumP, + sumS, (*^), (+^), (-^), (/^)) +import Data.Array.Repa.Eval hiding (one, zero) +import Data.Array.Repa.Repr.Unboxed +import Data.Coerce +import Data.Singletons +import Data.Singletons.Prelude hiding ((:.)) +import qualified Data.Vector.Unboxed as U +import Test.QuickCheck + +-- just for specialization +import Crypto.Lol.Types.ZqBasic + +-- always unboxed (manifest); intermediate calculations can use +-- delayed arrays + +-- | Indexed newtype for 1-dimensional Unbox repa arrays +newtype Arr (m :: Factored) r = Arr (Array U DIM1 r) + deriving (Eq, Show, NFData) + +-- the first argument, though phantom, affects representation +-- CJP: why must the second arg be nominal? +-- EAC: From https://ghc.haskell.org/trac/ghc/wiki/Roles#Thesolution: +-- "The exception to the above algorithm is for classes: all parameters for a class default to a nominal role." +-- Arr is a synonym for Array, which is an associated data type to the class Source. The parameter `r` above +-- corresponds to the parameter `e` in the definition of class Source, so it's role must be nominal. +type role Arr nominal nominal + +-- | An 'Arr' filled with the argument. +repl :: forall m r . (Fact m, Unbox r) => r -> Arr m r +repl = let n = proxy totientFact (Proxy::Proxy m) + in Arr . fromUnboxed (Z:.n) . U.replicate n +{-# INLINABLE repl #-} + +-- | Monadic version of 'repl'. +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 +{-# INLINABLE replM #-} + +instance (Fact m, Additive r, Unbox r, Elt r) => Additive.C (Arr m r) where + zero = repl zero + (Arr a) + (Arr b) = Arr $ force $ R.zipWith (+) a b + negate (Arr a) = Arr $ force $ R.map negate a + {-# INLINABLE zero #-} + {-# INLINABLE (+) #-} + {-# INLINABLE negate #-} + +instance (Fact m, Ring r, Unbox r, Elt r) => Ring.C (Arr m r) where + one = repl one + (Arr a) * (Arr b) = Arr $ force $ R.zipWith (*) a b + fromInteger = repl . fromInteger + {-# INLINABLE one #-} + {-# INLINABLE (*) #-} + {-# INLINABLE fromInteger #-} + +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 $ foldAllS (\ x y -> if isZero x then y else x) (a R.! (Z:.0)) a + {-# INLINABLE isZero #-} + + +instance (Unbox r) => NFData (Array U DIM1 r) where + -- EAC: Repa doesn't define any NFData instances, + -- I'm hoping deepSeqArray is a reasonable approx + rnf x = deepSeqArray x () + +instance (Unbox r, Random r, Fact m) => Random (Arr m r) where + random = runRand $ replM (liftRand random) + + randomR = error "randomR nonsensical for Arr" + +instance (Arbitrary r, Unbox r, Fact m) => Arbitrary (Arr m r) where + arbitrary = replM arbitrary + shrink = shrinkNothing + +-- | For a factored index, tensors up any function defined for (and +-- tagged by) any prime power +fTensor :: forall m r mon . (Fact m, Monad mon, Unbox r) + => (forall pp . (PPow pp) => TaggedT pp mon (Trans r)) + -> TaggedT m mon (Trans r) + +fTensor func = tagT $ go $ sUnF (sing :: SFactored m) + where + go :: Sing (pplist :: [PrimePower]) -> mon (Trans r) + go spps = case spps of + SNil -> return $ Id 1 + (SCons spp rest) -> do + rest' <- go rest + func' <- withWitnessT func spp + return $ rest' @* func' +{-# INLINABLE fTensor #-} + +-- | 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)) + -> TaggedT pp mon (Trans r) + +ppTensor func = tagT $ case (sing :: SPrimePower pp) of + pp@(SPP (STuple2 sp _)) -> do + func' <- withWitnessT func sp + let lts = withWitness valuePPow pp `div` withWitness valuePrime sp + return $ Id lts @* func' +{-# INLINABLE ppTensor #-} + + +-- deeply embedded DSL for transformations and their various +-- compositions + +-- (dim(f), f) where f operates on innermost dimension of array +data Tensorable r = Tensorable + !Int !(forall rep . Source rep r => Array rep DIM2 r -> Array D DIM2 r) + +-- transform component: a Tensorable with particular I_l, I_r +type TransC r = (Tensorable r, Int, Int) + +-- full transform: sequence of zero or more components +-- | a DSL for tensor transforms on Repa arrays +data Trans r = Id !Int -- ^| identity sentinel + | TSnoc !(Trans r) !(TransC r) -- ^| (function) composition of transforms + +dimC :: TransC r -> Int +dimC (Tensorable d _, l, r) = l*d*r +{-# INLINABLE dimC #-} + +-- | Returns the (linear) dimension of a transform +dim :: Trans r -> Int +dim (Id n) = n +dim (TSnoc _ f) = dimC f -- just use dimension of head +{-# INLINABLE dim #-} + +-- | smart constructor from a Tensorable +trans :: Int -> (forall rep . Source rep r => Array rep DIM2 r -> Array D DIM2 r) -> Trans r +trans d f = TSnoc (Id d) (Tensorable d f, 1, 1) +{-# INLINABLE trans #-} + +-- | compose transforms +(.*) :: Trans r -> Trans r -> Trans r +f .* g | dim f == dim g = f ..* g + | otherwise = error $ "(.*): transform dimensions don't match " + LP.++ show (dim f) LP.++ ", " LP.++ show (dim g) + where + f' ..* (Id _) = f' -- drop sentinel + f' ..* (TSnoc rest g') = TSnoc (f' ..* rest) g' +{-# INLINABLE (.*) #-} + +-- | tensor/Kronecker product (otimes) +(@*) :: Trans r -> Trans r -> Trans r +-- merge identity transforms +(Id n) @* (Id m) = Id (n*m) +-- Id on left or right +i@(Id n) @* (TSnoc g' (g, l, r)) = TSnoc (i @* g') (g, n*l, r) +(TSnoc f' (f, l, r)) @* i@(Id n) = TSnoc (f' @* i) (f, l, r*n) +-- no Ids: compose +f @* g = (f @* Id (dim g)) .* (Id (dim f) @* g) +{-# INLINABLE (@*) #-} + +evalC :: (Unbox r) => TransC r -> Array U DIM1 r -> Array U DIM1 r +evalC (Tensorable d f, _, r) = force . unexpose r . f . expose d r +{-# INLINABLE evalC #-} + +-- | Creates an evaluatable Haskell function from a tensored transform +eval :: (Unbox r) => Tagged m (Trans r) -> Arr m r -> Arr m r +eval x = coerce $ eval' $ untag x + where eval' (Id _) = id + eval' (TSnoc rest f) = eval' rest . evalC f +{-# INLINABLE eval #-} + +-- | 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 +{-# INLINE evalM #-} + +-- | maps the innermost dimension to a 2-dim array with innermost dim d, +-- for performing a I_l \otimes f_d \otimes I_r transformation +expose :: (Source r1 r, Unbox r) + => Int -> Int -> Array r1 DIM1 r -> Array D DIM2 r +expose !d !r !arr = + let (Z :. sz) = extent arr + f (Z :. i :. j) = let imodr = i `mod` r + in (Z :. (i-imodr)*d + j*r + imodr) + in backpermute (Z :. sz `div` d :. d) f arr +{-# INLINABLE expose #-} + +-- | inverse of expose +unexpose :: (Source r1 r, Unbox r) => Int -> Array r1 DIM2 r -> Array D DIM1 r +unexpose !r !arr = + let (Z :. sz :. d) = extent arr + f (Z :. i) = let (idivr,imodr) = i `divMod` r + (idivrd,j) = idivr `divMod` d + in (Z :. r*idivrd + imodr :. j) + in backpermute (Z :. sz*d) f arr +{-# INLINABLE unexpose #-} + +-- | general matrix multiplication along innermost dim of v +mulMat :: (Source r1 r, Source r2 r, Ring r, Unbox r, Elt r) + => Array r1 DIM2 r -> Array r2 DIM2 r -> Array D DIM2 r +mulMat !m !v + = let (Z :. mrows :. mcols) = extent m + (sh :. vrows) = extent v + f (sh' :. i) = sumAllS $ R.zipWith (*) (slice m (Z:.i:.All)) $ slice v (sh':.All) + 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 +mulDiag !diag !arr = fromFunction (extent arr) f + where f idx@(_ :. i) = (arr ! idx) * (diag ! (Z:.i)) +{-# INLINABLE mulDiag #-} + +-- misc Tensor functions + +-- | 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)) + where go n !r = let fct (Z:.0) = r + fct _ = LP.zero + in force $ fromFunction (Z:.n) fct +{-# INLINABLE scalarPow' #-} + +-- | Forces a delayed array to a manifest array. +force :: (Shape sh, Unbox r) => Array D sh r -> Array U sh r +force = computeS +--force = runIdentity . computeP +{-# INLINABLE force #-} + +-- copied implementations of functions we need that normally require +-- Num + +-- | Sum the inner-most dimension of an array sequentially +sumS :: (Source r a, Elt a, Unbox a, Additive a, Shape sh) + => Array r (sh :. Int) a + -> Array U sh a +sumS = foldS (+) LP.zero +{-# INLINABLE sumS #-} + +-- | Sum all array indices to a scalar sequentially +sumAllS :: (Shape sh, Source r a, Elt a, Unbox a, Additive a) + => Array r sh a + -> a +sumAllS = foldAllS (+) LP.zero +{-# INLINABLE sumAllS #-} diff --git a/Crypto/Lol/Cyclotomic/UCyc.hs b/Crypto/Lol/Cyclotomic/UCyc.hs new file mode 100644 --- /dev/null +++ b/Crypto/Lol/Cyclotomic/UCyc.hs @@ -0,0 +1,591 @@ +{-# LANGUAGE ConstraintKinds, DataKinds, FlexibleContexts, + FlexibleInstances, GADTs, InstanceSigs, MultiParamTypeClasses, + NoImplicitPrelude, PolyKinds, RankNTypes, RebindableSyntax, + ScopedTypeVariables, TypeFamilies, TypeOperators, + UndecidableInstances #-} + +-- | A low-level implementation of cyclotomic rings that allows (and +-- requires) the programmer to control the underlying representation +-- of ring elements, i.e., powerful, decoding, or CRT basis. +-- +-- __WARNING:__ as with all fixed-point arithmetic, the functions +-- associated with 'UCyc' may result in overflow (and thereby +-- incorrect answers and potential security flaws) if the input +-- arguments are too close to the bounds imposed by the base type. +-- The acceptable range of inputs for each function is determined by +-- the internal linear transforms and other operations it performs. + +module Crypto.Lol.Cyclotomic.UCyc +( +-- * Data types and constraints + UCyc, P, D, C, UCElt, NFElt +-- * Changing representation +, toPow, toDec, toCRT, fmapPow, fmapDec, unzipCyc, unzipUCElt +-- * Scalars +, scalarPow, scalarCRT -- scalarDec suppressed +-- * Basic operations +, mulG, divG, gSqNorm +-- * Error sampling +, tGaussian, errorRounded, errorCoset +-- * Inter-ring operations and values +, embedPow, embedDec, embedCRT +, twacePow, twaceDec, twaceCRT +, coeffsPow, coeffsDec, powBasis, crtSet +) where + +import Crypto.Lol.Cyclotomic.Tensor hiding (embedCRT, embedDec, embedPow, + scalarCRT, scalarPow, -- scalarDec + twaceCRT) + +import Crypto.Lol.CRTrans +import qualified Crypto.Lol.Cyclotomic.Tensor as T +import Crypto.Lol.LatticePrelude as LP +import Crypto.Lol.Types.FiniteField +import Crypto.Lol.Types.ZPP + +import qualified Algebra.Additive as Additive (C) +import qualified Algebra.Module as Module (C) +import qualified Algebra.Ring as Ring (C) +import qualified Algebra.ZeroTestable as ZeroTestable (C) + +import Control.Applicative as A +import Control.Arrow +import Control.DeepSeq +import Control.Monad +import Control.Monad.Random +import Data.Foldable as F +import Data.Maybe +import Data.Traversable +import Test.QuickCheck + +--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. +data C + +-- | 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 +-- cyclotomic index; @rep@ is the representation ('P', 'D', or 'C'); +-- @r@ is the base ring of the coefficients (e.g., @Z@, @Zq@). +-- +-- The 'Functor', 'Applicative', 'Foldable' and 'Traversable' +-- instances all work coefficient-wise (in the specified basis). +data UCyc t m 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 + +-- | 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)) + +-- | Convenient synonym for 'deepseq'-able element type. +type NFElt r = (NFData r, NFData (CRTExt r)) + +-- | Embed a scalar from the base ring. +scalarPow :: (Tensor t, Fact m, Ring r, TElt t r) => r -> UCyc t m P r +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) +{-# INLINABLE scalarCRT #-} + +-- Eq instances + +instance (Eq r, Tensor t, Fact m, TElt t r) => Eq (UCyc t m P r) where + (Pow v1) == (Pow v2) = v1 == v2 \\ witness entailEqT v1 + {-# INLINABLE (==) #-} + +instance (Eq r, Tensor t, Fact m, TElt t r) => Eq (UCyc t m D r) where + (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 + {-# INLINABLE (==) #-} + + +---------- Numeric Prelude instances ---------- + +-- ZeroTestable instances + +instance (ZeroTestable r, Tensor t, Fact m, TElt t r) + => ZeroTestable.C (UCyc t m P r) where + isZero (Pow v) = isZero v \\ witness entailZTT v + {-# INLINABLE isZero #-} + +instance (ZeroTestable r, Tensor t, Fact m, TElt t r) + => ZeroTestable.C (UCyc t m D r) where + isZero (Dec v) = isZero v \\ witness entailZTT v + {-# INLINABLE isZero #-} + +instance (ZeroTestable r, Fact m, UCElt 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 + {-# INLINABLE isZero #-} + +-- Additive instances + +instance (Additive r, Tensor t, Fact m, TElt t r) => Additive.C (UCyc t m P r) where + zero = Pow $ T.scalarPow zero + (Pow v1) + (Pow v2) = Pow $ zipWithT (+) v1 v2 + (Pow v1) - (Pow v2) = Pow $ zipWithT (-) v1 v2 + negate (Pow v) = Pow $ fmapT negate v + {-# INLINABLE zero #-} + {-# INLINABLE (+) #-} + {-# INLINABLE (-) #-} + {-# INLINABLE negate #-} + +instance (Additive r, Tensor t, Fact m, TElt t r) => Additive.C (UCyc t m D r) where + zero = Dec $ T.scalarPow zero -- scalarPow works because it's zero + (Dec v1) + (Dec v2) = Dec $ zipWithT (+) v1 v2 + (Dec v1) - (Dec v2) = Dec $ zipWithT (-) v1 v2 + negate (Dec v) = Dec $ fmapT negate v + {-# INLINABLE zero #-} + {-# INLINABLE (+) #-} + {-# INLINABLE (-) #-} + {-# INLINABLE negate #-} + +instance (Fact m, UCElt t r) => Additive.C (UCyc t m C 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" + + (CRTr v1) - (CRTr v2) = CRTr $ zipWithT (-) v1 v2 + (CRTe v1) - (CRTe v2) = CRTe $ zipWithT (-) v1 v2 + _ - _ = error "UCyc (-) internal error: mixed CRTr/CRTe" + + negate (CRTr v) = CRTr $ fmapT negate v + negate (CRTe v) = CRTe $ fmapT negate v + + {-# INLINABLE zero #-} + {-# INLINABLE (+) #-} + {-# INLINABLE (-) #-} + {-# INLINABLE negate #-} + +-- Ring instance: only for CRT + +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" + + {-# INLINABLE one #-} + {-# INLINABLE fromInteger #-} + {-# INLINABLE (*) #-} + + +instance (Ring r, Tensor t, Fact m, TElt t r) => Module.C r (UCyc t m P r) where + r *> (Pow v) = Pow $ fmapT (r *) v + {-# INLINABLE (*>) #-} + +instance (Ring r, Tensor t, Fact m, TElt t r) => Module.C r (UCyc t m D r) where + 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 + {-# INLINABLE (*>) #-} + +instance (GFCtx fp d, Fact m, UCElt 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) + + +instance (Reduce a b, Tensor t, Fact m, TElt t a, TElt t b) + => Reduce (UCyc t m P a) (UCyc t m P b) where + reduce (Pow v) = Pow $ fmapT reduce v + {-# INLINABLE reduce #-} + +instance (Reduce a b, Tensor t, Fact m, TElt t a, TElt t b) + => Reduce (UCyc t m D a) (UCyc t m D b) where + reduce (Dec v) = Dec $ fmapT reduce v + {-# INLINABLE reduce #-} + +-- CJP: no Reduce for C rep because we can't efficiently handle CRTe case + +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) + +instance (Lift' r, Tensor t, Fact m, TElt t r, TElt t (LiftOf r)) + => Lift' (UCyc t m P r) where + lift (Pow v) = Pow $ fmapT lift v + {-# INLINABLE lift #-} + +instance (Lift' r, Tensor t, Fact m, TElt t r, TElt t (LiftOf r)) + => Lift' (UCyc t m D r) where + lift (Dec v) = Dec $ fmapT lift v + {-# INLINABLE lift #-} + + +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 + rescale (Pow v) = Pow $ fmapT rescale v + {-# INLINABLE rescale #-} + +instance (Rescale a b, Tensor t, Fact m, TElt t a, TElt t b) + => Rescale (UCyc t m D a) (UCyc t m D b) where + rescale (Dec v) = Dec $ fmapT rescale v + {-# INLINABLE rescale #-} + + +-- 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). + + +-- | Type-restricted (and potentially more efficient) map 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 +-- 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 + +-- | 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 + +-- | Multiply by the special element @g@. +mulG :: (Tensor t, Fact m, UCElt 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 + +-- | 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) +{-# 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 + +-- | Yield the scaled squared norm of @g_m \cdot e@ under +-- the canonical embedding, namely, +-- @\hat{m}^{ -1 } \cdot || \sigma(g_m \cdot e) ||^2@ . +gSqNorm :: (Ring r, Tensor t, Fact m, TElt t r) => UCyc t m D r -> r +gSqNorm (Dec v) = gSqNormDec v +{-# 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.) +tGaussian :: (Tensor t, Fact m, OrdFloat q, Random q, TElt t q, + ToRational v, MonadRandom rnd) + => v -> rnd (UCyc t m D q) +tGaussian = fmap Dec . tGaussianDec +{-# INLINABLE tGaussian #-} + +-- | Generate an LWE error term from the "tweaked" Gaussian with given +-- scaled variance, deterministically rounded using the decoding +-- basis. +errorRounded :: forall v rnd t m z . + (ToInteger z, Tensor t, Fact m, TElt t z, + ToRational v, MonadRandom rnd) + => v -> rnd (UCyc t m D z) +{-# INLINABLE errorRounded #-} +errorRounded svar = + Dec . fmapT (roundMult one) <$> (tGaussianDec svar :: rnd (t m Double)) + +-- | 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. +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) + => v -> UCyc t m D zp -> rnd (UCyc t m D z) +{-# 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) + return $! roundCoset <$> c <*> err + + +----- inter-ring operations + +-- | Embed into an extension ring, for the powerful basis. +embedPow :: (Additive r, Tensor t, m `Divides` m', TElt t r) + => UCyc t m P r -> UCyc t m' P r +embedPow (Pow v) = Pow $ T.embedPow v +{-# INLINABLE embedPow #-} + +-- | Embed into an extension ring, for the decoding basis. +embedDec :: (Additive r, Tensor t, m `Divides` m', TElt t r) + => UCyc t m D r -> UCyc t m' D r +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)) + +-- | 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 +twacePow (Pow v) = Pow $ twacePowDec v +{-# INLINABLE twacePow #-} + +-- | Twace into a subring, for the decoding basis. +twaceDec :: (Ring r, Tensor t, m `Divides` m', TElt t r) + => UCyc t m' D r -> UCyc t m D r +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)) + +-- | 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) + => UCyc t m' P r -> [UCyc t m P r] +{-# INLINABLE coeffsPow #-} +coeffsPow (Pow v) = LP.map Pow $ coeffs v + +-- | Yield the @O_m@-coefficients of an @O_m'@ element, with respect to +-- the relative decoding @O_m@-basis. +coeffsDec :: (Ring r, Tensor t, m `Divides` m', TElt t r) + => UCyc t m' D r -> [UCyc t m D r] +{-# INLINABLE coeffsDec #-} +coeffsDec (Dec v) = LP.map Dec $ coeffs v + +-- | The relative powerful basis of @O_m' / O_m@. +powBasis :: (Ring r, Tensor t, m `Divides` m', TElt t r) + => Tagged m [UCyc t m' P r] +{-# INLINABLE powBasis #-} +powBasis = (Pow <$>) <$> powBasisPow + +-- | The relative mod-@r@ CRT set of @O_m' / O_m@, represented with +-- respect to the powerful basis (which seems to be the best choice +-- for typical use cases). +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)) + => Tagged m [UCyc t m' P r] +{-# INLINABLE crtSet #-} +crtSet = + -- CJP: consider using traceEvent or traceMarker + --DT.trace ("UCyc.crtSet: m = " ++ + -- show (proxy valueFact (Proxy::Proxy m)) ++ ", m'= " ++ + -- show (proxy valueFact (Proxy::Proxy m'))) $ + let (p,e) = proxy modulusZPP (Proxy::Proxy r) + pp = Proxy::Proxy p + pm = Proxy::Proxy m + pm' = Proxy::Proxy m' + in retag (fmap (embedPow . + (if e > 1 then toPow . (^(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' + + +--------- Conversion methods ------------------ + + +-- | Convert to powerful-basis representation. +toPow :: (Fact m, UCElt 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 + +-- | Convert to decoding-basis representation. +toDec :: (Fact m, UCElt 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 + +-- | 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 +{-# 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) + in \x -> case x of + (CRTr _) -> x + (CRTe _) -> 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. + +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 + +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 + +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 + + {-# INLINABLE pure #-} + {-# INLINABLE (<*>) #-} + +instance (Tensor t, Fact m) => Applicative (UCyc t m D) where + pure = Dec . pure \\ proxy entailIndexT (Proxy::Proxy (t m r)) + (Dec f) <*> (Dec v) = Dec $ f <*> v \\ witness entailIndexT v + + {-# INLINABLE pure #-} + {-# INLINABLE (<*>) #-} + + +instance (Tensor t, Fact m) => Foldable (UCyc t m P) where + {-# INLINABLE foldr #-} + foldr f b (Pow v) = F.foldr f b v \\ witness entailIndexT v + +instance (Tensor t, Fact m) => Foldable (UCyc t m D) where + {-# INLINABLE foldr #-} + foldr f b (Dec 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 + +instance (Tensor t, Fact m) => Traversable (UCyc t m D) where + {-# INLINABLE traverse #-} + traverse f (Dec v) = Dec <$> traverse f v \\ witness entailIndexT v + + +---------- Utility instances ---------- + +instance (Random r, Tensor t, Fact m, CRTElt t r) + => 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)) + 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 + +instance (Arbitrary (t m r)) => Arbitrary (UCyc t m D r) where + arbitrary = Dec <$> arbitrary + shrink = shrinkNothing + +instance (Arbitrary (t m r)) => Arbitrary (UCyc t m C r) where + arbitrary = CRTr <$> arbitrary + shrink = shrinkNothing + +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 diff --git a/Crypto/Lol/Factored.hs b/Crypto/Lol/Factored.hs new file mode 100644 --- /dev/null +++ b/Crypto/Lol/Factored.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE DataKinds, TemplateHaskell, TupleSections #-} + +-- | This module defines types and operations for type-level +-- representation and manipulation of natural numbers, as represented +-- by their prime-power factorizations. It relies on Template +-- Haskell, so parts of the documentation may be difficult to read. +-- See source-level comments for further details. + +module Crypto.Lol.Factored +( module Crypto.Lol.FactoredDefs +-- * Convenient synonyms for 'Factored', 'PrimePower', and 'Prime' types +, module Crypto.Lol.Factored +) where + +import Crypto.Lol.FactoredDefs + +$(mapM fDec [1..512]) +$(mapM fDec [1024,2048]) + +$(mapM ppDec $ (2,) <$> [1,2,3,4,5,6,7]) +$(mapM ppDec $ (3,) <$> [1,2,3,4]) +$(mapM ppDec $ (,1) <$> [5,7,11]) + +$(mapM pDec $ take 120 primes) + +-- CJP: this fails to compile, as it should, because 4 is not prime +-- (sequence [ppDec (4,2)]) diff --git a/Crypto/Lol/FactoredDefs.hs b/Crypto/Lol/FactoredDefs.hs new file mode 100644 --- /dev/null +++ b/Crypto/Lol/FactoredDefs.hs @@ -0,0 +1,429 @@ +{-# LANGUAGE ConstraintKinds, DataKinds, ExplicitNamespaces, GADTs, + InstanceSigs, KindSignatures, PolyKinds, ScopedTypeVariables, + TemplateHaskell, TypeFamilies, TypeOperators, + UndecidableInstances #-} + +-- | This sub-module exists only because we can't define and use +-- template Haskell splices in the same module. + +module Crypto.Lol.FactoredDefs +( +-- * Factored natural numbers + Factored, SFactored, Fact, fType, fDec +-- * Prime powers +, PrimePower, SPrimePower, Sing(SPP), PPow, ppType, ppDec +-- * Primes +, Prime, SPrime, Prim, pType, pDec +-- * Constructors +, pToPP, sPToPP, PToPP, ppToF, sPpToF, PpToF, pToF, sPToF, PToF +-- * Unwrappers +, unF, sUnF, UnF, unPP, sUnPP, UnPP, primePP, PrimePP, exponentPP, ExponentPP +-- * Arithmetic operations +, fPPMul, FPPMul, fMul, FMul, type (*) +, fDivides, FDivides, Divides, fDiv, FDiv, type (/) +, fGCD, FGCD, fLCM, FLCM, Coprime +, fOddRadical, FOddRadical +, pFree, PFree +-- * Convenient reflections +, ppsFact, valueFact, totientFact, valueHatFact, radicalFact, oddRadicalFact +, ppPPow, primePPow, exponentPPow, valuePPow, totientPPow +, valuePrime +-- * Number-theoretic laws +, transDivides, gcdDivides, lcmDivides, lcm2Divides +, pSplitTheorems, pFreeDivides +, (\\) -- re-export from Data.Constraint for convenience +-- * Utility operations on prime powers +, valueHat +, PP, ppToPP, valuePP, totientPP, radicalPP, oddRadicalPP +, valuePPs, totientPPs, radicalPPs, oddRadicalPPs +-- * Re-export +, module Crypto.Lol.PosBin +) where + +import Crypto.Lol.PosBin + +import Control.Arrow +import Data.Constraint hiding ((***), (&&&)) +import Data.Functor.Trans.Tagged +import Data.List hiding ((\\)) +import Data.Singletons.Prelude hiding ((:-)) +import Data.Singletons.TH +import Language.Haskell.TH + +import Unsafe.Coerce + +singletons [d| + + -- CJP: record syntax doesn't work here with singletons; + -- something about "escaped type variables" + + -- restrict to primes + newtype Prime = P Bin deriving (Eq,Ord,Show) + + -- (prime, exponent) + newtype PrimePower = PP (Prime,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 + unP (P p) = p + + -- Unwrap 'PrimePower'. + unPP :: PrimePower -> (Prime,Pos) + unPP (PP pp) = pp + + -- Unwrap 'Factored' + unF :: Factored -> [PrimePower] + unF (F pps) = pps + + -- Prime component of a 'PrimePower'. + primePP :: PrimePower -> Prime + primePP = fst . unPP + + -- Exponent component of a 'PrimePower'. + exponentPP :: PrimePower -> Pos + exponentPP = snd . unPP + + |] + +type F1 = 'F '[] + +singletons [d| + + fPPMul :: PrimePower -> Factored -> Factored + fMul :: Factored -> Factored -> Factored + + -- Multiply a 'PrimePower' into a 'Factored' number. + fPPMul pp (F pps) = F (ppMul pp pps) + + -- Multiply two 'Factored' numbers. + fMul (F pps1) (F pps2) = F (ppsMul pps1 pps2) + + -- helper functions (not for export) + + -- keeps primes in sorted order; merges duplicates + ppMul :: PrimePower -> [PrimePower] -> [PrimePower] + ppMul x [] = [x] + ppMul pp'@(PP (p',e')) pps@(pp@(PP (p,e)):pps') = + case compare p' p of + EQ -> PP (p, addPos e e') : pps' + LT -> pp' : pps + GT -> pp : ppMul pp' pps' + + ppsMul :: [PrimePower] -> [PrimePower] -> [PrimePower] + ppsMul [] ys = ys + ppsMul (pp:pps) ys = ppsMul pps (ppMul pp ys) + + |] + +-- ARITHMETIC OPERATIONS +singletons [d| + pToPP :: Prime -> PrimePower + pToPP p = PP (p, O) + + ppToF :: PrimePower -> Factored + ppToF pp = F [pp] + + pToF :: Prime -> Factored + pToF = ppToF . pToPP + + fGCD, fLCM :: Factored -> Factored -> Factored + fDivides :: Factored -> Factored -> Bool + fDiv :: Factored -> Factored -> Factored + fOddRadical :: Factored -> Factored + + fGCD (F pps1) (F pps2) = F (ppsGCD pps1 pps2) + fLCM (F pps1) (F pps2) = F (ppsLCM pps1 pps2) + + fDivides (F pps1) (F pps2) = ppsDivides pps1 pps2 + fDiv (F pps1) (F pps2) = F (ppsDiv pps1 pps2) + fOddRadical (F pps) = F (ppsOddRad pps) + + -- Helper functions (not for export) on PrimePowers and + -- lists. Can assume that input lists obey the invariant + -- of Factored lists, and need to ensure that output lists + -- also obey the invariant. + ppsGCD :: [PrimePower] -> [PrimePower] -> [PrimePower] + ppsGCD [] _ = [] + ppsGCD (_:_) [] = [] + ppsGCD xs@(PP (p,e) : xs') ys@(PP (p',e') : ys') = + case compare p p' of + EQ -> PP (p, min e e') : ppsGCD xs' ys' + LT -> ppsGCD xs' ys + GT -> ppsGCD xs ys' + + ppsLCM :: [PrimePower] -> [PrimePower] -> [PrimePower] + ppsLCM [] ys = ys + ppsLCM xs@(_:_) [] = xs + ppsLCM xs@(pp@(PP (p,e)) : xs') ys@(pp'@(PP (p',e')) : ys') = + case compare p p' of + EQ -> PP (p, max e e') : ppsLCM xs' ys' + LT -> pp : ppsLCM xs' ys + GT -> pp' : ppsLCM xs ys' + + ppsDivides :: [PrimePower] -> [PrimePower] -> Bool + ppsDivides [] _ = True + ppsDivides (_:_) [] = False + ppsDivides xs@(PP (p,e) : xs') (PP (p',e') : ys') = + if p == p' then (e <= e') && ppsDivides xs' ys' + else (p > p') && ppsDivides xs ys' + + ppsDiv :: [PrimePower] -> [PrimePower] -> [PrimePower] + ppsDiv xs [] = xs + ppsDiv (pp@(PP (p,e)) : xs') ys@(PP (p',e') : ys') = + if p == p' && e' == e then ppsDiv xs' ys' + else if p == p' && e' <= e then PP (p, subPos e e') : ppsDiv xs' ys' + else if p <= p' then pp : ppsDiv xs' ys + else error "invalid call to ppsDiv" + + ppsOddRad :: [PrimePower] -> [PrimePower] + ppsOddRad [] = [] + ppsOddRad (PP (p, _) : xs') = + if p == P (D0 B1) then ppsOddRad xs' -- D0 B1 == 2 + else PP (p,O) : ppsOddRad xs' + + |] + +singletons [d| + -- Remove all @p@-factors from a 'Factored'. + pFree :: Prime -> Factored -> Factored + pFree p (F pps) = F (go pps) + where go [] = [] + go (pp@(PP (p',_)) : ps) = + if p == p' then ps + else pp : (go ps) + |] + +-- | Type (family) synonym for division of 'Factored' types +type a / b = FDiv a b + +-- | Type (family) synonym for multiplication of 'Factored' types +type a * b = FMul a b + +-- convenience aliases: enforce kind, hide SingI + +-- | Kind-restricted synonym for 'SingI'. +type Prim (p :: Prime) = SingI p + +-- | Kind-restricted synonym for 'SingI'. +type PPow (pp :: PrimePower) = SingI pp + +-- | Kind-restricted synonym for 'SingI'. +type Fact (m :: Factored) = SingI m + +-- | Constraint synonym for divisibility of 'Factored' types. +type Divides m m' = (Fact m, Fact m', FDivides m m' ~ 'True) + +-- | Constraint synonym for coprimality of 'Factored' types. +type Coprime m m' = (FGCD m m' ~ F1) + +-- coercions: using proxy arguments here due to compiler bugs in usage + +-- coerce any divisibility relationship we want +coerceFDivs :: p m -> p' m' -> (() :- (FDivides m m' ~ 'True)) +coerceFDivs _ _ = Sub $ unsafeCoerce (Dict :: Dict ()) + +-- coerce any GCD we want +coerceGCD :: p a -> p' a' -> p'' a'' -> (() :- (FGCD a a' ~ a'')) +coerceGCD _ _ _ = Sub $ unsafeCoerce (Dict :: Dict ()) + +-- | Entails constraint for transitivity of division, i.e. +-- if @k|l@ and @l|m@, then @k|m@. +transDivides :: forall k l m . Proxy k -> Proxy l -> Proxy m -> + ((k `Divides` l, l `Divides` m) :- (k `Divides` m)) +transDivides k _ m = Sub Dict \\ coerceFDivs k m + +-- | Entailment for divisibility by GCD: +-- if @g=GCD(m1,m2)@ then @g|m1@ and @g|m2@. +gcdDivides :: forall m1 m2 g . Proxy m1 -> Proxy m2 -> + ((Fact m1, Fact m2, g ~ FGCD m1 m2) :- + (g `Divides` m1, g `Divides` m2)) +gcdDivides m1 m2 = + Sub $ withSingI (sFGCD (sing :: SFactored m1) (sing :: SFactored m2)) + Dict \\ coerceFDivs (Proxy::Proxy g) m1 + \\ coerceFDivs (Proxy::Proxy g) m2 + +-- | Entailment for LCM divisibility: +-- if @l=LCM(m1,m2)@ then @m1|l@ and @m2|l@. +lcmDivides :: forall m1 m2 l . Proxy m1 -> Proxy m2 -> + ((Fact m1, Fact m2, l ~ FLCM m1 m2) :- + (m1 `Divides` l, m2 `Divides` l)) +lcmDivides m1 m2 = + Sub $ withSingI (sFLCM (sing :: SFactored m1) (sing :: SFactored m2)) + Dict \\ coerceFDivs m1 (Proxy::Proxy l) + \\ coerceFDivs m2 (Proxy::Proxy l) + +-- | Entailment for LCM divisibility: +-- the LCM of two divisors of @m@ also divides @m@. +lcm2Divides :: forall m1 m2 l m . Proxy m1 -> Proxy m2 -> Proxy m -> + ((m1 `Divides` m, m2 `Divides` m, l ~ FLCM m1 m2) :- + (m1 `Divides` l, m2 `Divides` l, (FLCM m1 m2) `Divides` m)) +lcm2Divides m1 m2 m = + Sub $ withSingI (sFLCM (sing :: SFactored m1) (sing :: SFactored m2)) + Dict \\ coerceFDivs (Proxy::Proxy (FLCM m1 m2)) m \\ lcmDivides m1 m2 + +-- | Entailment for @p@-free division: +-- 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) :- + (f `Divides` m, Coprime (PToF p) f)) +pSplitTheorems _ m = + Sub $ withSingI (sPFree (sing :: SPrime 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') :- + ((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')) $ + Dict \\ coerceFDivs (Proxy::Proxy (PFree p m)) (Proxy::Proxy (PFree p m')) + +-- | Type synonym for @(prime, exponent)@ pair. +type PP = (Int, Int) + +-- | Value-level prime-power factorization tagged by a 'Factored' type. +ppsFact :: forall m . Fact m => Tagged m [PP] +ppsFact = tag $ map ppToPP $ unF $ fromSing (sing :: SFactored m) + +valueFact, totientFact, valueHatFact, radicalFact, oddRadicalFact :: + Fact m => Tagged m Int + +-- | The value of a 'Factored' type. +valueFact = valuePPs <$> ppsFact + +-- | The totient of a 'Factored' type's value. +totientFact = totientPPs <$> ppsFact + +-- | The "hat" of a 'Factored' type's value: +-- @\hat{m}@ is @m@ if @m@ is odd, and @m/2@ otherwise. +valueHatFact = valueHat <$> valueFact + +-- | The radical (product of prime divisors) of a 'Factored' type. +radicalFact = radicalPPs <$> ppsFact + +-- | The odd radical (product of odd prime divisors) of a 'Factored' +-- type. +oddRadicalFact = oddRadicalPPs <$> ppsFact + +-- | Reflect a 'PrimePower' type to a 'PP' value. +ppPPow :: forall pp . PPow pp => Tagged pp PP +ppPPow = tag $ ppToPP $ fromSing (sing :: SPrimePower pp) + +primePPow, exponentPPow, valuePPow, totientPPow :: PPow pp => Tagged pp Int +-- | Reflect the prime component of a 'PrimePower' type. +primePPow = fst <$> ppPPow +-- | Reflect the exponent component of a 'PrimePower' type. +exponentPPow = snd <$> ppPPow +-- | The value of a 'PrimePower' type. +valuePPow = valuePP <$> ppPPow +-- | 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) + +-- | Return @m@ if @m@ is odd, and @m/2@ otherwise. +valueHat :: Integral i => i -> i +valueHat m = if m `mod` 2 == 0 then m `div` 2 else m + +-- | Conversion. +ppToPP :: PrimePower -> PP +ppToPP = (binToInt . unP *** posToInt) . unPP + +valuePP, totientPP, radicalPP, oddRadicalPP :: PP -> Int +-- | The value of a prime power. +valuePP (p,e) = p^e + +-- | Totient of a prime power. +totientPP (_,0) = 1 +totientPP (p,e) = (p-1)*(p^(e-1)) + +-- | The radical of a prime power. +radicalPP (_,0) = 1 +radicalPP (p,_) = p + +-- | The odd radical of a prime power. +oddRadicalPP (2,_) = 1 +oddRadicalPP (p,_) = p + +valuePPs, totientPPs, radicalPPs, oddRadicalPPs :: [PP] -> Int +-- | Product of values of individual 'PP's +valuePPs = product . map valuePP +-- | Product of totients of individual 'PP's +totientPPs = product . map totientPP +-- | Product of radicals of individual 'PP's +radicalPPs = product . map radicalPP +-- | Product of odd radicals of individual 'PP's +oddRadicalPPs = product . map oddRadicalPP + + +-- | Template Haskell splice for the 'Prime' 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 +-- synonyms). +pType :: Int -> TypeQ +pType p + | prime p = conT 'P `appT` binType p + | otherwise = fail $ "pType : non-prime p " ++ show p + +-- | Template Haskell splice for the 'PrimePower' type corresponding to +-- a given 'PP'. (Calls 'pType' on the first component of its +-- argument, so should only be used on small-to-moderate-sized +-- numbers.) This is the preferred (and only) way of constructing a +-- concrete 'PrimePower' type. +ppType :: PP -> TypeQ +ppType (p,e) = conT 'PP `appT` + (promotedTupleT 2 `appT` pType p `appT` posType e) + +-- | Template Haskell splice for the 'Factored' type corresponding to a +-- given positive integer. Factors its argument using a naive +-- trial-division algorithm with 'primes', so should only be used on +-- 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)) + promotedNilT $ factorize n) + +-- | Template Haskell splice that defines the 'Prime' type synonym +-- @Primep@ for a positive prime integer @p@. +pDec :: Int -> DecQ +pDec p = tySynD (mkName $ "Prime" ++ show p) [] $ pType p + +-- | Template Haskell splice that defines the 'PrimePower' type synonym +-- @PPn@, where @n=p^e@. +ppDec :: PP -> DecQ +ppDec pp@(p,e) = tySynD (mkName $ "PP" ++ show (p^e)) [] $ ppType pp + +-- | Template Haskell splice that defines the 'Factored' type synonym +-- @Fn@ for a positive integer @n@. +fDec :: Int -> DecQ +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. +factorize' :: [Int] -> Int -> [Int] +factorize' _ 1 = [] +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 a positive integer into a list of (prime,exponent) +-- pairs, in strictly increasing order by prime. +factorize :: Int -> [(Int,Int)] +factorize = map (head &&& length) . group . factorize' primes + diff --git a/Crypto/Lol/Gadget.hs b/Crypto/Lol/Gadget.hs new file mode 100644 --- /dev/null +++ b/Crypto/Lol/Gadget.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE ConstraintKinds, DataKinds, FlexibleContexts, + FlexibleInstances, MultiParamTypeClasses, NoImplicitPrelude, + PolyKinds, ScopedTypeVariables, TupleSections, TypeFamilies, + UndecidableInstances #-} + +-- | Interfaces for "gadgets," decomposition, and error correction. + +module Crypto.Lol.Gadget +( Gadget(..), Decompose(..), Correct(..) +, TrivGad, BaseBGad +) where + +import Crypto.Lol.LatticePrelude + +import Control.Applicative +import Control.Arrow + +-- | Dummy type representing the gadget @[1]@. +data TrivGad +-- | Dummy type representing the gadget @[1,b,b^2,...]@. +data BaseBGad b + +-- | "Gadget" vectors, parameterized by an index type. + +class Ring u => Gadget gad u where + -- | The gadget vector over @u@. + gadget :: Tagged gad [u] + + -- | Yield an error-tolerant encoding of an element with respect to + -- the gadget. (Mathematically, this should just be the product of + -- the input with the gadget, but it is a class method to allow for + -- optimized implementations.) + encode :: u -> Tagged gad [u] + encode s = ((* s) <$>) <$> gadget + +-- | Decomposition relative to a gadget. + +class (Gadget gad u, Reduce (DecompOf u) u) => Decompose gad u where + -- | The ring that @u@ decomposes over. + type DecompOf u + + -- | Yield a short vector @x@ such that @\ = u@. + decompose :: u -> Tagged gad [DecompOf u] + +-- | Error correction relative to a gadget. + +class Gadget gad u => Correct gad u where + + -- | Error-correct a "noisy" encoding of an element (see 'encode'), + -- returning the encoded element and the error vector. + correct :: Tagged gad [u] -> (u, [LiftOf u]) + + +-- instances for products + +instance (Gadget gad a, Gadget gad b) => Gadget gad (a,b) where + + gadget = (++) <$> (map (,zero) <$> gadget) <*> (map (zero,) <$> gadget) + +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 + +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)) + => Correct gad (a,b) where + + correct = + let gada = gadget :: Tagged gad [a] + gadb = gadget :: Tagged gad [b] + ka = length gada + qaval = toInteger $ proxy modulus (Proxy::Proxy a) + qbval = toInteger $ proxy modulus (Proxy::Proxy b) + qamod = fromIntegral qaval + qbmod = fromIntegral qbval + qainv = recip qamod + qbinv = recip qbmod + in \tv -> + let v = untag tv + (wa,wb) = splitAt ka v + (va,xb) = unzip $ + (\(a,b) -> let x = toInteger $ lift b + in (qbinv * (a - fromIntegral x), x)) <$> wa + (vb,xa) = unzip $ + (\(a,b) -> let x = toInteger $ lift a + in (qainv * (b - fromIntegral x), x)) <$> wb + (sa,ea) = (qbmod *) *** + zipWith (\x e -> x + qbval * toInteger e) xb $ + correct (tag va `asTypeOf` gada) + (sb,eb) = (qamod *) *** + zipWith (\x e -> x + qaval * toInteger e) xa $ + correct (tag vb `asTypeOf` gadb) + in ((sa,sb), ea ++ eb) + + +{- CJP: strawman class for the more general view of LWE secrets as +"module characters," i.e., module homomorphisms into a particular +range. This is probably wrong, though. + +class Character u where -- Module superclass(es)? + type CharRange u + data Char u -- need data for injectivity + + evalChar :: Char u -> u -> CharRange u + +class (Gadget gad u, Character u) => Correct gad u where + + -- | Correct a "noisy" encoding of an LWE secret (i.e., a + -- 'ModuleHomom' on 'u'). + correct :: Tagged gad [CharRange u] -> Char u + +encode :: (Correct gad u) => Char u -> Tagged gad [CharRange u] +encode s = pasteT $ evalMH s <$> peelT gadget + +-} + diff --git a/Crypto/Lol/GaussRandom.hs b/Crypto/Lol/GaussRandom.hs new file mode 100644 --- /dev/null +++ b/Crypto/Lol/GaussRandom.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE NoImplicitPrelude, RebindableSyntax, ScopedTypeVariables #-} + +-- | Functions for sampling from a continuous Gaussian distribution + +module Crypto.Lol.GaussRandom +( realGaussian, realGaussians ) where + +import Crypto.Lol.LatticePrelude + +import qualified Data.Vector.Generic as V + +import Control.Monad +import Control.Monad.Random + +-- | Using polar form of Box-Muller transform, returns a pair of +-- centered, Gaussian-distributed real numbers with scaled variance +-- @svar = true variance * (2*pi)@. See +-- for details. + +realGaussian :: forall v q m . + (ToRational v, OrdFloat q, Random q, MonadRandom m) + => v -> m (q,q) +realGaussian svar = + let var = realToField svar / pi :: q -- twice true variance + in do (u,v) <- iterateWhile uvGuard getUV + let t = u*u+v*v + com = sqrt (-var * log t / t) + -- we can either sample u,v from [-1,1] + -- or generate sign bits for the outputs + s1 <- getRandom + s2 <- getRandom + let u' = if s1 then u else -u + v' = if s2 then v else -v + return (u'*com,v'*com) + where getUV = do u <- getRandomR (zero,one) + v <- getRandomR (zero,one) + return (u,v) + uvGuard (u,v) = (u*u+v*v >= one) || (u*u+v*v == zero) + +-- | Generate @n@ real, independent gaussians of scaled variance @svar +-- = true variance * (2*pi)@. +realGaussians :: + (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) $ + replicateM (n `div` 2) (realGaussian var) + + + + + + +-- Taken from monad-loops-0.4.3 + +-- | Execute an action repeatedly until its result fails to satisfy a predicate, +-- and return that result (discarding all others). +iterateWhile :: (Monad m) => (a -> Bool) -> m a -> m a +iterateWhile p x = x >>= iterateUntilM (not . p) (const x) + +-- | 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 + | p v = return v + | otherwise = f v >>= iterateUntilM p f + +{- +-- | Returns a Gaussian-distributed sample over 'pZ' with given +-- (scaled) variance parameter @v=var/(2*pi)@ and center, using +-- rejection sampling + +gaussRound :: (RealTranscendental v, Random v, + RealRing c, ToRational c, + Ring i, ToInteger i, Random i, MonadRandom m) + => v -> c -> m i +gaussRound svar c = + let dev = ceiling $ 6 * sqrt svar -- 6 gives stat dist < 2^-163 + lower = floor c - dev + upper = ceiling c + dev + sampler = do + z <- getRandomR (lower, upper) + u <- getRandomR (zero, one) + let dist = fromIntegral z - realToField c + let prob = exp (-pi * (dist*dist / svar)) + if u <= prob then return z else sampler + in sampler +-} diff --git a/Crypto/Lol/LatticePrelude.hs b/Crypto/Lol/LatticePrelude.hs new file mode 100644 --- /dev/null +++ b/Crypto/Lol/LatticePrelude.hs @@ -0,0 +1,276 @@ +{-# 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/PosBin.hs b/Crypto/Lol/PosBin.hs new file mode 100644 --- /dev/null +++ b/Crypto/Lol/PosBin.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE DataKinds, TemplateHaskell #-} + +-- | Positive naturals in Peano and binary representations, +-- singletonized and promoted to the type level. This module relies +-- on Template Haskell, so parts of the documentation may be difficult +-- to read. See source-level comments for further details. + +module Crypto.Lol.PosBin +( module Crypto.Lol.PosBinDefs +-- * Convenient synonyms for 'Pos' and 'Bin' types +, module Crypto.Lol.PosBin +) where + +import Crypto.Lol.PosBinDefs + +$(mapM posDec [1..16]) + +$(mapM binDec [1..128]) diff --git a/Crypto/Lol/PosBinDefs.hs b/Crypto/Lol/PosBinDefs.hs new file mode 100644 --- /dev/null +++ b/Crypto/Lol/PosBinDefs.hs @@ -0,0 +1,147 @@ +{-# LANGUAGE ConstraintKinds, DataKinds, GADTs, InstanceSigs, + KindSignatures, NoImplicitPrelude, PolyKinds, + RebindableSyntax, ScopedTypeVariables, TemplateHaskell, + TypeFamilies, UndecidableInstances #-} + +-- | This sub-module exists only because we can't define and use +-- template Haskell splices in the same module. + +module Crypto.Lol.PosBinDefs +( -- * Positive naturals in Peano representation + Pos(..), Sing(SO, SS), SPos, PosC +, posToInt, addPos, sAddPos, AddPos, subPos, sSubPos, SubPos +, posType, posDec +, OSym0, SSym0, SSym1, AddPosSym0, AddPosSym1, SubPosSym0, SubPosSym1 + -- * Positive naturals in binary representation +, Bin(..), Sing(SB1, SD0, SD1), SBin, BinC +, binToInt, binType, binDec +, B1Sym0, D0Sym0, D0Sym1, D1Sym0, D1Sym1 + -- * Miscellaneous +, intDec, primes, prime +) +where + +import Data.Singletons.Prelude +import Data.Singletons.TH +import Language.Haskell.TH + +import Algebra.ToInteger as ToInteger +import NumericPrelude + +singletons [d| + -- Positive naturals (1, 2, ...) in Peano representation. + data Pos = O -- one + | S Pos -- successor + deriving (Show, Eq) + + instance Ord Pos where + compare O O = EQ + compare O (S _) = LT + compare (S _) O = GT + compare (S a) (S b) = compare a b + + addPos :: Pos -> Pos -> Pos + addPos O b = S b + addPos (S a) b = S $ addPos a b + + subPos :: Pos -> Pos -> Pos + subPos (S a) O = a + subPos (S a) (S b) = subPos a b + subPos O _ = error "Invalid call to subPos: a <= b" + + |] + +-- not promotable due to numeric output + +-- | Convert a 'Pos' to an integral type. +posToInt :: ToInteger.C z => Pos -> z +posToInt O = one +posToInt (S a) = one + posToInt a + +singletons [d| + -- Positive naturals in binary representation. + data Bin = B1 -- 1 + | D0 Bin -- 2*b (double) + | D1 Bin -- 1 + 2*b (double and increment) + deriving (Show, Eq) + + instance Ord Bin where + compare B1 B1 = EQ + compare B1 (D0 _) = LT + compare B1 (D1 _) = LT + compare (D0 _) B1 = GT + compare (D1 _) B1 = GT + compare (D0 a) (D0 b) = compare a b + compare (D1 a) (D1 b) = compare a b + compare (D0 a) (D1 b) = case compare a b of + EQ -> LT + LT -> LT + GT -> GT + compare (D1 a) (D0 b) = case compare a b of + EQ -> GT + LT -> LT + GT -> GT + + |] + +-- | Convert a 'Bin' to an integral type. +binToInt :: ToInteger.C z => Bin -> z +binToInt B1 = one +binToInt (D0 a) = 2 * binToInt a +binToInt (D1 a) = 1 + 2 * binToInt a + +-- | Kind-restricted synonym for 'SingI'. +type PosC (p :: Pos) = SingI p + +-- | Kind-restricted synonym for 'SingI'. +type BinC (b :: Bin) = SingI b + +-- | Template Haskell splice for the 'Pos' type +-- representing a given 'Int', e.g., @$(posType 8)@. +posType :: Int -> TypeQ +posType n + | n <= 0 = fail $ "posType: non-positive argument n = " ++ show n + | n == 1 = conT 'O + | otherwise = conT 'S `appT` posType (n-1) + +-- | Template Haskell splice for the 'Bin' type +-- representing a given 'Int', e.g., @$(binType 89)@. +binType :: Int -> TypeQ +binType n + | n <= 0 = fail $ "binType: non-positive argument n = " ++ show n + | otherwise = case n `quotRem` 2 of + (0,1) -> conT 'B1 + (q,0) -> conT 'D0 `appT` binType q + (q,1) -> conT 'D1 `appT` binType q + _ -> fail "internal error in PosBinTH.bin" + +posDec, binDec :: Int -> DecQ +-- | Template Haskell splice that defines the 'Pos' type synonym @Pn@. +posDec = intDec "P" posType +-- | Template Haskell splice that defines the 'Bin' type synonym @Bn@. +binDec = intDec "B" binType + +-- | Template Haskell splice that declares a type synonym +-- @n@ as the type @f n@. +intDec :: String -- ^ @pfx@ + -> (Int -> TypeQ) -- ^ @f@ + -> Int -- ^ @n@ + -> DecQ +intDec pfx f n = tySynD (mkName $ pfx ++ show n) [] (f n) + +-- | Infinite list of primes, built using Sieve of Erastothenes. +primes :: [Int] +primes = 2 : 3 : 5 : primes' + where + isPrime (p:ps) n = p*p > n || n `rem` p /= 0 && isPrime ps n + primes' = 7 : filter (isPrime primes') (scanl (+) 11 $ cycle [2,4,2,4,6,2,6,4]) + +-- | Search for the argument in 'primes'. This is not particularly +-- fast, but works well enough for moderate-sized numbers that would +-- appear as (divisors of) cyclotomic indices of interest. +prime :: Int -> Bool +prime = go primes + where go (p:ps) n = case compare p n of + LT -> go ps n + EQ -> True + GT -> False diff --git a/Crypto/Lol/Reflects.hs b/Crypto/Lol/Reflects.hs new file mode 100644 --- /dev/null +++ b/Crypto/Lol/Reflects.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE DataKinds, FlexibleContexts, FlexibleInstances, + KindSignatures, MultiParamTypeClasses, NoImplicitPrelude, + PolyKinds, ScopedTypeVariables, UndecidableInstances #-} + +-- | Generic interface for reflecting types to values. + +module Crypto.Lol.Reflects +( Reflects(..) +) where + +import Algebra.ToInteger as ToInteger +import NumericPrelude + +import Crypto.Lol.Factored + +import Control.Applicative +import Data.Functor.Trans.Tagged +import Data.Proxy +import Data.Reflection +import GHC.TypeLits as TL + +-- | Reflection without fundep, and with tagged value. Intended only +-- for low-level code; build specialized wrappers around it for +-- specific functionality. + +class Reflects a i where + -- | Reflect the value assiated with the type @a@. + value :: Tagged a i + +instance (KnownNat a, ToInteger.C i) => Reflects (a :: TL.Nat) i where + value = tag $ fromIntegral $ natVal (Proxy::Proxy a) + +{- + +instance (PosC a, ToInteger.C i) => Reflects a i where + value = tag $ posToInt $ fromSing (sing :: Sing a) + +instance (BinC a, ToInteger.C i) => Reflects a i where + value = tag $ binToInt $ fromSing (sing :: Sing a) + +-} + +-- CJP: need reflections for Prime and PrimePower types because we use +-- them with ZqBasic + +instance (Prim 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) diff --git a/Crypto/Lol/Types/Complex.hs b/Crypto/Lol/Types/Complex.hs new file mode 100644 --- /dev/null +++ b/Crypto/Lol/Types/Complex.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE DataKinds, FlexibleContexts, FlexibleInstances, + GeneralizedNewtypeDeriving, MultiParamTypeClasses, + NoImplicitPrelude, RebindableSyntax, ScopedTypeVariables, + StandaloneDeriving, TemplateHaskell, TypeFamilies, + UndecidableInstances #-} + +-- | Data type, functions, and instances for complex numbers. + +module Crypto.Lol.Types.Complex ( + Complex +, roundComplex +, cis, real, imag, fromReal +) where + +import Algebra.Additive as Additive (C) +import Algebra.Field as Field (C) +import Algebra.IntegralDomain as IntegralDomain +import Algebra.Ring as Ring (C) +import Algebra.ZeroTestable as ZeroTestable (C) +import qualified Number.Complex as C hiding (exp, signum) + +import Crypto.Lol.Types.Numeric as LP + +import Control.DeepSeq +import Data.Array.Repa.Eval as R +import Data.Vector.Storable (Storable) +import Data.Vector.Unboxed (Unbox) +import Data.Vector.Unboxed.Deriving +import System.Random +import Test.QuickCheck + +-- | 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) + +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. +instance (Field a) => IntegralDomain.C (Complex a) where + (Complex a) `divMod` (Complex b) = (Complex $ a / b, LP.zero) + +-- we can't use Generics for NFData because NP doesn't export the +-- (deep) constructor for Complex.T +instance (NFData a) => NFData (Complex a) where + rnf (Complex x) = let r = C.real x + i = C.imag x + in rnf r `seq` rnf i `seq` () + +instance (Random a) => Random (Complex a) where + random g = let (a,g') = random g + (b,g'') = random g' + in (Complex $ a C.+: b, g'') + + randomR = error "randomR not defined for (Complex t)" + +instance (R.Elt a) => R.Elt (Complex a) where + touch (Complex c) = do + touch $ C.real c + touch $ C.imag c + zero = Complex $ R.zero C.+: R.zero + one = Complex $ R.one C.+: R.zero + +-- | Rounds the real and imaginary components to the nearest integer. +roundComplex :: (RealRing a, ToInteger b) => Complex a -> (b,b) +roundComplex (Complex x) = (round $ C.real x, round $ C.imag x) + +-- | 'cis' @t@ is a complex value with magnitude 1 and phase t (modulo @2*Pi@). +cis :: Transcendental a => a -> Complex a +cis = Complex . C.cis + +-- | Real component of a complex number. +real :: Complex a -> a +real (Complex a) = C.real a + +-- | Imaginary component of a complex number. +imag :: Complex a -> a +imag (Complex a) = C.imag a + +-- | Embeds a scalar as the real component of a complex number. +fromReal :: Additive a => a -> Complex a +fromReal = Complex . C.fromReal diff --git a/Crypto/Lol/Types/FiniteField.hs b/Crypto/Lol/Types/FiniteField.hs new file mode 100644 --- /dev/null +++ b/Crypto/Lol/Types/FiniteField.hs @@ -0,0 +1,174 @@ +{-# LANGUAGE ConstraintKinds, DataKinds, FlexibleContexts, + GeneralizedNewtypeDeriving, MultiParamTypeClasses, + NoImplicitPrelude, PolyKinds, RebindableSyntax, + RoleAnnotations, ScopedTypeVariables, TypeFamilies, + UndecidableInstances #-} + +-- CJP: need PolyKinds to allow d to have non-* kind + +-- | Basic (unoptimized) finite field arithmetic. + +module Crypto.Lol.Types.FiniteField +( GF -- export type but not constructor +, PrimeField, GFCtx +, size, trace, toList, fromList +, IrreduciblePoly(..), X(..), (^^) +, TensorCoeffs(..) +) where + +import Crypto.Lol.CRTrans +import Crypto.Lol.Factored +import Crypto.Lol.LatticePrelude +import Crypto.Lol.Reflects + +import Algebra.Additive as Additive (C) +import Algebra.Field as Field (C) +import Algebra.Module as Module (C) +import Algebra.Ring as Ring (C) +import Algebra.ZeroTestable as ZeroTestable (C) +import MathObj.Polynomial + +import Math.NumberTheory.Primes.Factorisation + +import Control.Applicative hiding ((*>)) +import Control.DeepSeq +import Control.Monad +import qualified Data.Vector as V + +--import qualified Debug.Trace as DT + +-- | A finite field of given degree over @F_p@. +newtype GF fp d = GF (Polynomial fp) + deriving (Eq, Show, Additive.C, ZeroTestable.C, NFData) + +-- the second argument, though phantom, affects representation +type role GF representational representational + +type PrimeField fp = (Enumerable fp, Field fp, Eq fp, ZeroTestable fp, + Prim (CharOf fp), IrreduciblePoly fp) + +type GFCtx fp d = (PrimeField fp, Reflects d Int) + +instance (GFCtx fp d) => Enumerable (GF fp d) where + values = GF <$> fromCoeffs <$> + -- d-fold cartesian product of Fp values + replicateM (proxy value (Proxy::Proxy d)) values + +instance (GFCtx fp d) => Ring.C (GF fp d) where + + one = GF one + + (*) = let poly = proxy irreduciblePoly (Proxy :: Proxy d) + in \(GF f) (GF g) -> GF $ (f*g) `mod` poly + + fromInteger = GF . fromInteger + +instance (GFCtx fp d) => Field.C (GF fp d) where + + recip = let g = proxy irreduciblePoly (Proxy :: Proxy d) + in \(GF f) -> let (_,(a,_)) = extendedGCD f g + in GF a + +instance (GFCtx fp d) => CRTrans (GF fp d) where + + crtInfo m = (,) <$> omegaPow <*> scalarInv + where + omegaPow = + let size' = proxy size (Proxy :: Proxy (GF fp d)) + (q,r) = (size'-1) `quotRem` m + gen = head $ filter isPrimitive values + omega = gen^q + omegaPows = V.iterateN m (*omega) one + in if r == 0 + then Just $ (omegaPows V.!) . (`mod` m) + else Nothing + scalarInv = Just $ recip $ fromIntegral $ valueHat m + +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) = + let dval = proxy value (Proxy::Proxy d) + n = length fps + in if n `mod` dval /= 0 then + error $ "FiniteField: d (= " ++ show dval ++ + ") does not divide n (= " ++ show n ++ ")" + else Coeffs $ concat ((toList . (r *) . fromList) <$> chunksOf dval fps) + +chunksOf :: Int -> [a] -> [[a]] +chunksOf _ [] = [] +chunksOf n xs + | n > 0 = let (h,t) = splitAt n xs in h : chunksOf n t + | 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 +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) + +-- | 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 " ++ + show (length cs) ++ " > degree " ++ show dval + +sizePP :: forall fp d . (GFCtx fp d) => Tagged (GF fp d) PP +sizePP = tag (proxy valuePrime (Proxy::Proxy (CharOf fp)), + proxy value (Proxy::Proxy d)) + +-- | The order of the field: @size (GF fp d) = p^d@ +size :: (GFCtx fp d) => Tagged (GF fp d) Int +size = uncurry (^) <$> sizePP + +isPrimitive :: forall fp d . (GFCtx fp d) => GF fp d -> Bool +isPrimitive = let q = proxy size (Proxy :: Proxy (GF fp d)) + ps = map (fromIntegral . fst) $ factorise $ + fromIntegral $ q-1 + exps = map ((q-1) `div`) ps + in \g -> not (isZero g) && all (\e -> g^e /= 1) exps + +dotp :: (Ring a) => [a] -> [a] -> a +dotp a b = sum $ zipWith (*) a b + +-- | Trace into the prime subfield. +trace :: forall fp d . (GFCtx fp d) => GF fp d -> fp +trace = let ts = proxy powTraces (Proxy::Proxy (GF fp d)) + in \(GF f) -> dotp ts (coeffs f) + +-- | Traces of the power basis elements 1, x, x^2, ..., x^(d-1). +powTraces :: forall fp d . (GFCtx fp d) => Tagged (GF fp d) [fp] +powTraces = + --DT.trace ("FiniteField.powTraces: p = " ++ + -- show (proxy value (Proxy::Proxy (CharOf fp)) :: Int) ++ + -- ", 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) + +-- helper that computes trace via brute force: sum frobenius +-- automorphisms +trace' :: (GFCtx fp d) => GF fp d -> fp +trace' e = let (p,d) = witness sizePP e + (GF t) = sum $ take d $ iterate (^p) e + -- t is a constant polynomial + in head $ coeffs t + +-- | Represents fields over which we can get irreducible +-- polynomials of desired degrees. (An instance of this class is +-- defined in 'Crypto.Lol.Types.IrreducibleChar2' and exported from +-- 'Crypto.Lol'.) +class Field fp => IrreduciblePoly fp where + irreduciblePoly :: (Reflects d Int) => Tagged d (Polynomial fp) + +-- | Convenience data type for writing 'IrreduciblePoly' instances. +data X = X + +-- | Convenience function for writing 'IrreduciblePoly' instances. +(^^) :: Ring a => X -> Int -> Polynomial a +X ^^ i | i >= 0 = fromCoeffs $ replicate i 0 ++ [1] +_ ^^ _ = error "FiniteField.(^^) only defined for non-negative exponents." diff --git a/Crypto/Lol/Types/IZipVector.hs b/Crypto/Lol/Types/IZipVector.hs new file mode 100644 --- /dev/null +++ b/Crypto/Lol/Types/IZipVector.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE ConstraintKinds, DataKinds, DeriveTraversable, + FlexibleContexts, GeneralizedNewtypeDeriving, KindSignatures, + MultiParamTypeClasses, RoleAnnotations, ScopedTypeVariables, + TypeFamilies, UndecidableInstances #-} + +-- | Provides applicative-like functions for indexed vectors + +module Crypto.Lol.Types.IZipVector +( IZipVector, iZipVector, unIZipVector, unzipIZV +) where + +import Crypto.Lol.Factored + +import Algebra.ZeroTestable as ZeroTestable + +import Control.DeepSeq +import Data.Data +import Data.Functor.Trans.Tagged +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 +-- proper lengths (and is necessary to implement 'pure'). + +newtype IZipVector (m :: Factored) a = + IZipVector { -- | Deconstructor + 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) + +-- the first argument, though phantom, affects representation +type role IZipVector representational representational + +-- | Smart constructor that checks whether length of input is right +-- (should be totient of @m@). +iZipVector :: forall m a . (Fact m) => Vector a -> Maybe (IZipVector m a) +iZipVector = let n = proxy totientFact (Proxy::Proxy m) + in \vec -> if n == V.length vec + then Just $ IZipVector vec + else Nothing + +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) + +-- don't export +repl :: forall m a . (Fact m) => a -> IZipVector m a +repl = let n = proxy totientFact (Proxy::Proxy m) + in IZipVector . V.replicate n + +-- Zip-py 'Applicative' instance. +instance (Fact m) => Applicative (IZipVector m) where + pure = repl + (IZipVector f) <*> (IZipVector a) = IZipVector $ V.zipWith ($) f a + +-- no ZeroTestable instance for Vectors, so define here +instance (ZeroTestable.C a) => ZeroTestable.C (Vector a) where + isZero = V.all isZero diff --git a/Crypto/Lol/Types/IrreducibleChar2.hs b/Crypto/Lol/Types/IrreducibleChar2.hs new file mode 100644 --- /dev/null +++ b/Crypto/Lol/Types/IrreducibleChar2.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE FlexibleInstances, NoImplicitPrelude, PolyKinds, + RebindableSyntax, ScopedTypeVariables, TypeFamilies, + UndecidableInstances #-} + +-- | Orphan instance of 'IrreduciblePoly' for characteristic-2 fields. + +module Crypto.Lol.Types.IrreducibleChar2 () where + +import Crypto.Lol.LatticePrelude +import Crypto.Lol.Reflects +import Crypto.Lol.Types.FiniteField + +-- | Convenience function. +taggedProxy :: Tagged s (Proxy s) +taggedProxy = tag Proxy + +-- 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. + +-- 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." diff --git a/Crypto/Lol/Types/Numeric.hs b/Crypto/Lol/Types/Numeric.hs new file mode 100644 --- /dev/null +++ b/Crypto/Lol/Types/Numeric.hs @@ -0,0 +1,210 @@ +{-# LANGUAGE ConstraintKinds, DataKinds, FlexibleInstances, GADTs, + MultiParamTypeClasses, NoImplicitPrelude, RebindableSyntax, + ScopedTypeVariables, TypeOperators #-} + +-- we have some orphan instances here for instances of +-- package classes with Prelude data types +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | This module imports NumericPrelude and defines constraint +-- synonyms for NumericPrelude classes to help with code readability, +-- and defines saner versions of some NumericPrelude functions + +module Crypto.Lol.Types.Numeric +( module Crypto.Lol.Types.Numeric -- everything we define here +, module NumericPrelude -- re-export +, Int64 -- commonly used +) where + +import Control.DeepSeq +import Control.Monad.Random + +-- NumericPrelude has silly types for these functions +import NumericPrelude hiding (abs, max, min, (^)) +import qualified NumericPrelude.Numeric (abs) +import qualified Prelude (max, min) + +import qualified Algebra.Absolute (C) +import qualified Algebra.Additive (C) +import qualified Algebra.Algebraic (C) +import qualified Algebra.Field (C) +import qualified Algebra.IntegralDomain (C) +import qualified Algebra.Module (C) +import qualified Algebra.PrincipalIdealDomain (C) +import qualified Algebra.RealField (C) +import qualified Algebra.RealIntegral (C) +import qualified Algebra.RealRing (C) +import qualified Algebra.RealTranscendental (C) +import qualified Algebra.Ring (C) +import qualified Algebra.ToInteger (C) +import qualified Algebra.ToRational (C, realToField) +import qualified Algebra.Transcendental (C) +import qualified Algebra.ZeroTestable (C) +import MathObj.Polynomial + +import Data.Int (Int64) + +-- | The Prelude definition of 'max'. +max :: Ord a => a -> a -> a +max = Prelude.max + +-- | The Prelude definition of 'min'. +min :: Ord a => a -> a -> a +min = Prelude.min + +-- | The sane definition of 'abs' from +-- 'NumericPrelude.Numeric' +-- rather than the default from 'NumericPrelude'. +abs :: Absolute a => a -> a +abs = NumericPrelude.Numeric.abs + +-- | The hidden NP function from 'Algebra.ToRational'. +realToField :: (Field b, ToRational a) => a -> b +realToField = Algebra.ToRational.realToField + +-- use this if you need: +{- isZero -} +-- | Sane synonym for 'Algebra.ZeroTestable.C'. +type ZeroTestable a = (Algebra.ZeroTestable.C a) + +{- - + negate -} +-- | Sane synonym for 'Algebra.Additive.C'. +type Additive a = (Algebra.Additive.C a) + +{- Additive, plus: * fromIntegral -} +-- | Sane synonym for 'Algebra.Ring.C'. +type Ring a = (Algebra.Ring.C a) + +{- Ring and Additive, plus: *> -} +-- | Sane synonym for 'Algebra.Module.C'. +type Module a v = (Algebra.Module.C a v) + +{- Ring, plus: div, mod, divmod -} +-- | Sane synonym for 'Algebra.IntegralDomain.C'. +type IntegralDomain a = (Algebra.IntegralDomain.C a) + +{- Ring, plus: abs signum toRational' -} +-- | Sane synonym for 'Algebra.ToRational.C'. +type ToRational a = (Algebra.ToRational.C a) + +{- Ring, plus: / recip fromRational -} +-- | Sane synonym for 'Algebra.Field.C'. +type Field a = (Algebra.Field.C a) + +{- Ring, plus: abs and rounding functions -} +-- | Sane synonym for 'Algebra.RealRing.C'. +type RealRing a = (Algebra.RealRing.C a) + +{- Field, plus: abs signum round floor ceiling -} +-- | Sane synonym for 'Algebra.RealField.C'. +type RealField a = (Algebra.RealField.C a) + +{- Field, plus: sqrt root ^/ -} +-- | Sane synonym for 'Algebra.Algebraic.C'. +type Algebraic a = (Algebra.Algebraic.C a) + +{- Algebraic, plus: pi exp log sin atan -} +-- | Sane synonym for 'Algebra.Transcendental.C'. +type Transcendental a = (Algebra.Transcendental.C a) + +{- Transcendental and RealField, plus atan2 -} +-- | Sane synonym for 'Algebra.RealTranscendental.C'. +type RealTranscendental a = (Algebra.RealTranscendental.C a) + +{- Transcendental, plus: == <= >= < > -} +-- | Convenient synonym for @(Ord a, Transcendental a)@ +type OrdFloat a = (Ord a, Transcendental a) + +{- ToRational and Ring, plus: toInteger div mod divmod quot rem quotrem -} +-- | Sane synonym for 'Algebra.ToInteger.C'. +type ToInteger a = (Algebra.ToInteger.C a) + +-- | Sane synonym for 'Algebra.Absolute.C'. +type Absolute a = (Algebra.Absolute.C a) + +-- | Sane synonym for 'Algebra.RealIntegral.C'. +type RealIntegral a = (Algebra.RealIntegral.C a) + +-- | Sane synonym for 'Algebra.PrincipalIdealDomain.C'. +type PID a = (Algebra.PrincipalIdealDomain.C a) + +-- | Sane synonym for 'MathObj.Polynomial.T'. +type Polynomial a = MathObj.Polynomial.T a + +-- | IntegralDomain instance for Double +instance Algebra.IntegralDomain.C Double where + _ `div` 0 = error "cannot divide Double by 0\n" + a `div` b = a / b + _ `mod` _ = 0 + +-- NFData instance for Polynomial, missing from NP +instance (NFData r) => NFData (Polynomial r) where + rnf = rnf . coeffs + +-- | Our custom exponentiation, overriding NP's version that +-- requires 'Integer' exponent. +-- Copied from http://hackage.haskell.org/package/base-4.7.0.0/docs/src/GHC-Real.html#%5E +{-# SPECIALISE [1] (^) :: + Integer -> Integer -> Integer, + Integer -> Int -> Integer, + Int -> Int -> Int, + Int64 -> Int64 -> Int64 + #-} +(^) :: forall a i . (Ring a, ToInteger i) => a -> i -> a +x0 ^ y0 | y0 < 0 = error "Negative exponent" + | y0 == 0 = 1 + | otherwise = f x0 y0 + where -- f : x0 ^ y0 = x ^ y + f :: a -> i -> a -- a polymorphic local binding needs a sig + f x y | even y = f (x * x) (y `quot` 2) + | y == 1 = x + | otherwise = g (x * x) ((y - 1) `quot` 2) x + -- g : x0 ^ y0 = (x ^ y) * z + g :: a -> i -> a -> a + g x y z | even y = g (x * x) (y `quot` 2) z + | y == 1 = x * z + | otherwise = g (x * x) ((y - 1) `quot` 2) (x * z) + +-- | Inverse of @a@ modulo @q@, in range @0..q-1@. (Argument order is +-- infix-friendly.) +modinv :: (PID i, Eq i) => i -> i -> Maybe i +modinv a q = let (d, (_, inv)) = extendedGCD q a + in if d == one + then Just $ inv `mod` q + else Nothing + +-- | Decompose an element into a list of "centered" digits with respect +-- to relative radices. +decomp :: (IntegralDomain z, Ord z) => [z] -> z -> [z] +decomp [] v = [v] +decomp (b:bs) v = let (q,r) = v `divModCent` b + in r : decomp bs q + +-- | Deterministically round to the nearest multiple of @i@. +roundMult :: (RealField r, ToInteger i) => i -> r -> i +roundMult 1 r = round r +roundMult i r = let r' = r / fromIntegral i in i * round r' + +-- | Randomly round to the nearest larger or smaller multiple of @i@, +-- where the round-off term has expectation zero. +roundScalarCentered :: (RealField r, Random r, ToInteger i, + MonadRandom mon) + => i -> r -> mon i +roundScalarCentered p x = + let x' = x / fromIntegral p + mod1 = x' - floor x' + in do prob <- getRandomR (zero, one) + return $ p * if prob < mod1 + then ceiling x' + else floor x' + +-- | Variant of 'Algebra.IntegralDomain.divMod' in which the remainder +-- is in the range @[-b\/2,b\/2)@. +divModCent :: (IntegralDomain i, Ord i) + => i -- ^ dividend @a@ + -> i -- ^ divisor @b@ + -> (i,i) -- ^ (quotient, remainder) +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/Random.hs b/Crypto/Lol/Types/Random.hs new file mode 100644 --- /dev/null +++ b/Crypto/Lol/Types/Random.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving, PackageImports #-} + +-- | 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. + +module Crypto.Lol.Types.Random (CryptoRand) where + +import "crypto-api" Crypto.Random +import Data.Binary.Get +import Data.ByteString hiding (pack) +import Data.ByteString.Lazy (pack) +import System.Random + +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" + +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) + + split (CryptoRand g) = case splitGen g of + Right (g1, g2) -> (CryptoRand g1, CryptoRand g2) + Left err -> error $ "Split error: " ++ show err diff --git a/Crypto/Lol/Types/ZPP.hs b/Crypto/Lol/Types/ZPP.hs new file mode 100644 --- /dev/null +++ b/Crypto/Lol/Types/ZPP.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE FlexibleContexts, TypeFamilies #-} + +-- | A class for integers mod a prime power. + +module Crypto.Lol.Types.ZPP +( ZPP(..) +) where + +import Crypto.Lol.LatticePrelude +import Crypto.Lol.Types.FiniteField + +-- | Represents integers modulo a prime power. +class (PrimeField (ZpOf zq), Ring zq) => ZPP zq where + + -- | An implementation of the integers modulo the prime base. + type ZpOf zq + + -- | The prime and exponent of the modulus. + modulusZPP :: Tagged zq PP + + -- | Lift from @Z_p@ to a representative. + liftZp :: ZpOf zq -> zq + diff --git a/Crypto/Lol/Types/ZmStar.hs b/Crypto/Lol/Types/ZmStar.hs new file mode 100644 --- /dev/null +++ b/Crypto/Lol/Types/ZmStar.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE ConstraintKinds, DataKinds, FlexibleContexts, + NoImplicitPrelude, PolyKinds, RebindableSyntax, + ScopedTypeVariables, TypeFamilies, TypeOperators, + UndecidableInstances #-} + +-- | A collection of helper functions for working with @Z_m^*@ + +module Crypto.Lol.Types.ZmStar +( order, partitionCosets +) where + +import Crypto.Lol.Factored +import Crypto.Lol.LatticePrelude as LP hiding (null) +import Crypto.Lol.Reflects +import Crypto.Lol.Types.ZqBasic + +import Data.List as L (foldl', transpose) +import Data.Map (Map, elems, empty, insertWith') +import Data.Set as S (Set, difference, findMin, fromList, map, null) + + +-- | The multiplicative order of @p@ (the argument) modulo @m@. +-- Requires @gcd(p,m)=1@. +order :: forall m . (Reflects m Int) => Int -> Tagged m Int +order p = tag $ + 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)) + +-- given p, returns the cosets of Z_m^* /

+cosets :: forall zm . (Mod zm, ModRep zm ~ Int, Ord zm, Ring zm) + => Int -> [Set zm] +cosets p = + let mval = proxy modulus (Proxy::Proxy zm) + in if gcd p mval /= 1 + then error "p and m not coprime" + else let zmstar = fromList $ LP.map fromIntegral $ filter ((==) 1 . gcd mval) [1..mval] + zp = fromIntegral p + -- generates the coset containing x + coset x = fromList $ x : takeWhile (/=x) (iterate (*zp) $ zp*x) + -- repeatedly removes a (new) coset from the remaining elements + genCosets s | null s = [] + genCosets s = let c = coset (findMin s) + in c : genCosets (difference s c) + in genCosets zmstar + +-- CJP: could tag this by '(p,m,m') for safety/memoization. + +-- | Given @p@, returns a partition of the cosets of @Z_{m\'}^* \/ \

@ +-- (specified by representatives), where the cosets in each component +-- are in bijective correspondence with the cosets of @Z_m^* \/ \

@ under +-- the natural (@mod m@) homomorphism. +partitionCosets :: forall m m' . (m `Divides` m') + => Int -> Tagged '(m, m') [[Int]] +partitionCosets p = + let m'cosets = cosets p + -- a map from cosets of Z_m^* /

to their preimages under the + -- natural homomorphism + partition = + L.foldl' (\cmap x -> insertWith' (++) (S.map (reduce . lift) x) [x] cmap) + (empty :: Map (Set (ZqBasic m Int)) [Set (ZqBasic m' Int)]) + m'cosets + -- transpose the map to get a list of list of sets, where for each + -- inner list, there is exactly one m'-(co)set lying above each m-coset + part' = transpose $ elems partition + -- concat the inner sets to get a list of "CRT cosets" (indexed in Z_m'^*) + in return $ LP.map (LP.map (lift . findMin)) part' diff --git a/Crypto/Lol/Types/ZqBasic.hs b/Crypto/Lol/Types/ZqBasic.hs new file mode 100644 --- /dev/null +++ b/Crypto/Lol/Types/ZqBasic.hs @@ -0,0 +1,345 @@ +{-# LANGUAGE ConstraintKinds, DataKinds, FlexibleContexts, + FlexibleInstances, GeneralizedNewtypeDeriving, + MultiParamTypeClasses, NoImplicitPrelude, PolyKinds, + RebindableSyntax, RoleAnnotations, ScopedTypeVariables, + StandaloneDeriving, TypeFamilies, UndecidableInstances #-} + +-- | An implementation of modular arithmetic, i.e., the ring Zq. + +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.Reflects +import Crypto.Lol.Types.FiniteField +import Crypto.Lol.Types.ZPP + +import Math.NumberTheory.Primes.Factorisation +import Math.NumberTheory.Primes.Testing + +import Control.Applicative +import Control.Arrow +import Control.DeepSeq (NFData) +import Data.Coerce +import Data.Maybe +import NumericPrelude.Numeric as NP (round) +import System.Random +import Test.QuickCheck + +-- for the Unbox instances +import qualified Data.Vector as V +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 + +-- for the Elt instance +import qualified Data.Array.Repa.Eval as E + +import qualified Algebra.Additive as Additive (C) +import qualified Algebra.Field as Field (C) +import qualified Algebra.IntegralDomain as IntegralDomain (C) +import qualified Algebra.Ring as Ring (C) +import qualified Algebra.ZeroTestable as ZeroTestable (C) + +-- | 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) + +-- the q argument, though phantom, matters for safety +type role ZqBasic nominal representational + +--deriving instance (U.Unbox i) => G.Vector U.Vector (ZqBasic q i) +--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' = 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' = let qval = proxy value (Proxy::Proxy q) + in \(ZqB x) -> if 2 * x < qval + then x + else x - qval + +instance (ReflectsTI q 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 + type ModRep (ZqBasic q z) = z + + modulus = retag (value :: Tagged q z) + +type instance CharOf (ZqBasic p z) = p + +instance (PPow pp, zq ~ ZqBasic pp z, + PrimeField (ZpOf zq), Ring zq, Ring (ZpOf zq)) + => ZPP (ZqBasic (pp :: PrimePower) z) where + + type ZpOf (ZqBasic pp z) = ZqBasic (PrimePP pp) z + + modulusZPP = retag (ppPPow :: Tagged pp PP) + liftZp = coerce + +instance (ReflectsTI q z) => Reduce z (ZqBasic q z) where + reduce = reduce' + +instance (Reflects q z, Ring (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 + lift = decode' + +instance (ReflectsTI q z, ReflectsTI q' z, Ring z) + => Rescale (ZqBasic q z) (ZqBasic q' z) where + + rescale = rescaleMod + +instance (Reflects p z, ReflectsTI q z, + Field (ZqBasic p z), Field (ZqBasic q 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) + +-- | 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 = -- 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 + + +-- instance of CRTrans +instance (ReflectsTI q z, PID z, Enumerable (ZqBasic q z)) + => CRTrans (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) + +-- instance of CRTEmbed +instance (ReflectsTI q 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 + + {-# INLINABLE zero #-} + zero = ZqB zero + + {-# INLINABLE (+) #-} + (+) = let qval = proxy value (Proxy::Proxy q) + in \ (ZqB x) (ZqB y) -> + let z = x + y + in ZqB (if z >= qval then z - qval else z) + + {-# INLINABLE negate #-} + negate (ZqB x) = reduce' $ negate x + +-- instance of Ring +instance (ReflectsTI q 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) + -- this is safe as long as type z can hold the value of q + in \x -> ZqB $ fromInteger $ x `mod` qval + +-- instance of Field +instance (ReflectsTI q z, PID z, Show z) => Field.C (ZqBasic q z) where + + {-# INLINABLE recip #-} + recip = let qval = proxy value (Proxy::Proxy q) + -- safe because modinv returns in range 0..qval-1 + in \(ZqB x) -> ZqB $ + fromMaybe (error $ "ZqB.recip fail: " ++ + 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 + divMod a b = (a/b, zero) + +-- Gadget-related instances +instance (ReflectsTI q z, Additive z) => Gadget TrivGad (ZqBasic q z) where + gadget = tag [one] + +instance (ReflectsTI q 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 + correct a = case untag a of + [b] -> (b, [zero]) + _ -> error "Correct TrivGad: wrong length" + +-- BaseBGad instances + +gadlen :: (RealIntegral z) => z -> z -> Int +gadlen _ q | isZero q = 0 +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) + => 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) + => Decompose (BaseBGad b) (ZqBasic q z) where + type DecompOf (ZqBasic q z) = z + decompose = let qval = proxy value (Proxy :: Proxy q) + bval = proxy value (Proxy :: Proxy b) + k = gadlen bval qval + radices = replicate (k-1) bval + in tag . decomp radices . lift + +-- | Yield the error vector for a noisy multiple of the gadget (all +-- over the integers). +correctZ :: forall z . (RealIntegral z) + => z -- ^ modulus @q@ + -> z -- ^ base @b@ + -> [z] -- ^ input vector @v = s \cdot g^t + e@ + -> [z] -- ^ error @e@ +correctZ q b = + let gadZ = gadgetZ b q + k = length gadZ + gadlast = last gadZ + 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 + (v', v'l) = subLast v $ qbarD w x + s = fst $ v'l `divModCent` gadlast + in zipWith (-) v' $ (s*) <$> gadZ + + where + -- | 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 q' (v1:vs@(v2:_)) = let quo = fst $ divModCent (b*v1-v2) q + in (quo:) *** (quo*q' +) $ + barBtRnd (q' `div` b) vs + + -- | Yield @(q \bar{D}) \cdot w@, given precomputed first entry + qbarD :: [z] -> z -> [z] + qbarD [] x = [x] + qbarD (w0:ws) x = x : qbarD ws (b*x - q*w0) + + -- | Yield the difference between the input vectors, along with + -- their final entry. + subLast :: [z] -> [z] -> ([z], z) + 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) + => Correct (BaseBGad b) (ZqBasic q z) where + + correct = + let qval = proxy value (Proxy :: Proxy q) + bval = proxy value (Proxy :: Proxy b) + correct' = correctZ qval bval + in \tv -> let v = untag tv + es = correct' $ lift <$> v + in (head v - reduce (head es), es) + +-- instance of Random +instance (ReflectsTI q 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') + + randomR _ = error "randomR non-sensical for Zq types" + +-- instance of Arbitrary +instance (ReflectsTI q z, Random z) => Arbitrary (ZqBasic q z) where + arbitrary = + let qval :: z = proxy value (Proxy::Proxy q) + in fromIntegral <$> choose (0, qval-1) + + shrink = shrinkNothing + +-- CJP: restored manual Unbox instances, until we have a better way +-- (NewtypeDeriving or TH) + +newtype instance U.MVector s (ZqBasic q z) = MV_ZqBasic (U.MVector s z) +newtype instance U.Vector (ZqBasic q z) = V_ZqBasic (U.Vector z) + +-- Unbox, when underlying representation is +instance U.Unbox z => U.Unbox (ZqBasic q z) + +{- purloined and tweaked from code in `vector` package that defines +types as unboxed -} +instance U.Unbox z => M.MVector U.MVector (ZqBasic q z) where + basicLength (MV_ZqBasic v) = M.basicLength v + basicUnsafeSlice z n (MV_ZqBasic v) = MV_ZqBasic $ M.basicUnsafeSlice z n v + basicOverlaps (MV_ZqBasic v1) (MV_ZqBasic v2) = M.basicOverlaps v1 v2 + basicInitialize (MV_ZqBasic v) = M.basicInitialize v + basicUnsafeNew n = MV_ZqBasic <$> M.basicUnsafeNew n + basicUnsafeReplicate n (ZqB x) = MV_ZqBasic <$> M.basicUnsafeReplicate n x + basicUnsafeRead (MV_ZqBasic v) z = ZqB <$> M.basicUnsafeRead v z + basicUnsafeWrite (MV_ZqBasic v) z (ZqB x) = M.basicUnsafeWrite v z x + basicClear (MV_ZqBasic v) = M.basicClear v + basicSet (MV_ZqBasic v) (ZqB x) = M.basicSet v x + basicUnsafeCopy (MV_ZqBasic v1) (MV_ZqBasic v2) = M.basicUnsafeCopy v1 v2 + basicUnsafeMove (MV_ZqBasic v1) (MV_ZqBasic v2) = M.basicUnsafeMove v1 v2 + basicUnsafeGrow (MV_ZqBasic v) n = MV_ZqBasic <$> M.basicUnsafeGrow v n + +instance U.Unbox z => G.Vector U.Vector (ZqBasic q z) where + basicUnsafeFreeze (MV_ZqBasic v) = V_ZqBasic <$> G.basicUnsafeFreeze v + basicUnsafeThaw (V_ZqBasic v) = MV_ZqBasic <$> G.basicUnsafeThaw v + basicLength (V_ZqBasic v) = G.basicLength v + basicUnsafeSlice z n (V_ZqBasic v) = V_ZqBasic $ G.basicUnsafeSlice z n v + basicUnsafeIndexM (V_ZqBasic v) z = ZqB <$> G.basicUnsafeIndexM v z + basicUnsafeCopy (MV_ZqBasic mv) (V_ZqBasic v) = G.basicUnsafeCopy mv v + elemseq _ = seq diff --git a/README b/README --- a/README +++ b/README @@ -1,9 +1,5 @@ Overview of key modules, roughly from highest- to lowest-level: -* SymmSHE.hs, an implementation of a symmetric-key, - somewhat-homomorphic encryption scheme that is essentially - equivalent to the one from the toolkit paper [LPR'13]. - * Cyc.hs, which defines an interface for using cyclotomic fields, rings R, and quotient rings Rq=R/qR; as well as many other commonly used operations, e.g., converting diff --git a/benchmarks/CycBenches.hs b/benchmarks/CycBenches.hs new file mode 100644 --- /dev/null +++ b/benchmarks/CycBenches.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE DataKinds, FlexibleContexts, + NoImplicitPrelude, RebindableSyntax, + ScopedTypeVariables, TypeFamilies, + TypeOperators, UndecidableInstances #-} + +module CycBenches (cycBenches) where + +import Benchmarks +import Harness.Cyc +import Utils + +import Control.Monad.Random + +import Crypto.Lol +import Crypto.Lol.Types.Random +import Crypto.Random.DRBG + +import Data.Singletons +import Data.Promotion.Prelude.List +import Data.Promotion.Prelude.Eq +import Data.Singletons.TypeRepStar + +cycBenches :: (MonadRandom m) => m 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 + ] + +-- 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 = + let a' = adviseCRT a + b' = adviseCRT b + in bench (a' *) b' + +-- convert input from Pow basis to CRT basis +bench_crt :: (BasicCtx t m r) => Cyc t m r -> Bench '(t,m,r) +bench_crt x = let y = advisePow x in bench adviseCRT y + +-- convert input from CRT basis to Pow basis +bench_crtInv :: (BasicCtx t m r) => Cyc t m r -> Bench '(t,m,r) +bench_crtInv x = let y = adviseCRT x in bench advisePow y + +-- convert input from Dec basis to Pow basis +bench_l :: (BasicCtx t m r) => Cyc t m r -> Bench '(t,m,r) +bench_l x = let y = adviseDec x in bench advisePow y + +-- lift an element in the Pow basis +bench_liftPow :: forall t m r . (LiftCtx t m r) => Cyc t m r -> Bench '(t,m,r) +bench_liftPow x = let y = advisePow x in bench (liftCyc Pow :: Cyc t m r -> Cyc t m (LiftOf r)) y + +-- multiply by g when input is in Pow basis +bench_mulgPow :: (BasicCtx t m r) => Cyc t m r -> Bench '(t,m,r) +bench_mulgPow x = let y = advisePow x in bench mulG y + +-- multiply by g when input is in CRT basis +bench_mulgCRT :: (BasicCtx t m r) => Cyc t m r -> Bench '(t,m,r) +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) + => 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) + => Cyc t m' r -> Bench '(t,m,m',r) +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) + => Cyc t m r -> Bench '(t,m,m',r) +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) + ] +-- 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)) +type LiftParams = ( '(,) <$> Tensors) <*> (Nub (Filter Liftable (Map RemoveM MM'RCombos))) +type TwoIdxParams = ( '(,) <$> Tensors) <*> MM'RCombos + +type ErrorParams = ( '(,) <$> '[HashDRBG]) <*> LiftParams + +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 new file mode 100644 --- /dev/null +++ b/benchmarks/Main.hs @@ -0,0 +1,12 @@ + +import CycBenches +import ZqBenches + +import Criterion.Main +import Control.Monad + +main :: IO () +main = defaultMain =<< (sequence [ + zqBenches, + cycBenches + ]) diff --git a/benchmarks/ZqBenches.hs b/benchmarks/ZqBenches.hs new file mode 100644 --- /dev/null +++ b/benchmarks/ZqBenches.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE DataKinds, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, + NoImplicitPrelude, RankNTypes, TypeFamilies #-} + +module ZqBenches (zqBenches) where + +import Crypto.Lol + +import Control.Applicative +import Control.Monad +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 Benchmarks + +type Arr = R.Array R.U R.DIM1 + +zqBenches :: MonadRandom rnd => rnd Benchmark +zqBenches = benchGroup "ZqBasic" [ + hideArgs bench_mul_unb (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_unb :: (Ring zq, U.Unbox zq) => U.Vector zq -> U.Vector zq -> Bench zq +bench_mul_unb a b = bench (U.zipWith (*) a) b + +vecLen = 100 :: Int + +instance (U.Unbox zq, Random zq, MonadRandom rnd) => Generatable rnd (Arr zq) where + genArg = R.fromListUnboxed (R.Z R.:. vecLen) <$> replicateM vecLen getRandom + +instance (U.Unbox zq, Random zq, MonadRandom rnd) => Generatable rnd (U.Vector zq) where + genArg = U.fromList <$> replicateM vecLen getRandom diff --git a/lol.cabal b/lol.cabal --- a/lol.cabal +++ b/lol.cabal @@ -5,7 +5,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.1.0.0 +version: 0.2.0.0 synopsis: A library for lattice cryptography. homepage: https://github.com/cpeikert/Lol Bug-Reports: https://github.com/cpeikert/Lol/issues @@ -18,14 +18,25 @@ stability: experimental build-type: Simple extra-source-files: README, CHANGES.md, - src/Crypto/Lol/Cyclotomic/Tensor/CTensor/tensorTypes.h, - test-suite/CycTests.hs, - test-suite/SHETests.hs, - test-suite/TensorTests.hs, - test-suite/TestTypes.hs, - test-suite/ZqTests.hs -cabal-version: >=1.10 -description: Λ ○ λ (Lol) is a general-purpose library for ring-based lattice cryptography. + benchmarks/CycBenches.hs, + benchmarks/ZqBenches.hs, + tests/CycTests.hs, + tests/ZqTests.hs, + tests/TensorTests.hs, + utils/Apply.hs, + utils/Benchmarks.hs, + utils/Gen.hs, + utils/Tests.hs, + utils/TestTypes.hs, + utils/Utils.hs, + utils/Harness/Cyc.hs, + Crypto/Lol/Cyclotomic/Tensor/CTensor/tensorTypes.h +cabal-version: >= 1.10 +description: + Λ ○ λ (Lol) is a general-purpose library for ring-based lattice cryptography. + For a detailed description of interfaces and functionality, see + . + For example cryptographic applications, see . source-repository head type: git location: https://github.com/cpeikert/Lol @@ -40,18 +51,23 @@ Description: Compile via LLVM. This produces much better object code, but you need to have the LLVM compiler installed. - Default: False + Default: True +Flag opt + Description: Turn on library optimizations + Default: True + Manual: False + library - hs-source-dirs: src - Include-dirs: src/Crypto/Lol/Cyclotomic/Tensor/CTensor - C-sources: src/Crypto/Lol/Cyclotomic/Tensor/CTensor/basic.c, - src/Crypto/Lol/Cyclotomic/Tensor/CTensor/crt.c, - src/Crypto/Lol/Cyclotomic/Tensor/CTensor/g.c, - src/Crypto/Lol/Cyclotomic/Tensor/CTensor/generalfuncs.c, - src/Crypto/Lol/Cyclotomic/Tensor/CTensor/l.c, - src/Crypto/Lol/Cyclotomic/Tensor/CTensor/random.c - Includes: src/Crypto/Lol/Cyclotomic/Tensor/CTensor/tensorTypes.h + 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) @@ -65,96 +81,124 @@ ghc-options: -fllvm -optlo-O3 -- ghc optimizations - ghc-options: -O3 -Odph -funbox-strict-fields -fwarn-dodgy-imports -rtsopts - ghc-options: -fno-liberate-case -funfolding-use-threshold1000 -funfolding-keeness-factor1000 + 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 exposed-modules: Crypto.Lol + Crypto.Lol.PosBin + Crypto.Lol.Factored + Crypto.Lol.Reflects Crypto.Lol.CRTrans Crypto.Lol.Gadget Crypto.Lol.LatticePrelude - - Crypto.Lol.Applications.SymmSHE - Crypto.Lol.Cyclotomic.Tensor - Crypto.Lol.Factored Crypto.Lol.Cyclotomic.Cyc Crypto.Lol.Cyclotomic.UCyc - Crypto.Lol.Cyclotomic.Utility - + Crypto.Lol.Cyclotomic.RescaleCyc Crypto.Lol.Cyclotomic.Linear + 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.PrimeField Crypto.Lol.Types.IrreducibleChar2 - Crypto.Lol.Types.ZPP Crypto.Lol.Types.ZqBasic - Crypto.Lol.Reflects - other-modules: - Crypto.Lol.Types.ZmStar + Crypto.Lol.FactoredDefs + Crypto.Lol.PosBinDefs Crypto.Lol.GaussRandom + Crypto.Lol.Types.ZmStar Crypto.Lol.Types.Complex + Crypto.Lol.Types.Numeric Crypto.Lol.Types.IZipVector Crypto.Lol.Cyclotomic.Tensor.RepaTensor.CRT Crypto.Lol.Cyclotomic.Tensor.RepaTensor.Extension - Crypto.Lol.Cyclotomic.Tensor.RepaTensor.Gauss + Crypto.Lol.Cyclotomic.Tensor.RepaTensor.Dec Crypto.Lol.Cyclotomic.Tensor.RepaTensor.GL Crypto.Lol.Cyclotomic.Tensor.RepaTensor.RTCommon - Crypto.Lol.Cyclotomic.Tensor.CTensor.Extension - Crypto.Lol.Types.Numeric + Crypto.Lol.Cyclotomic.Tensor.CTensor.Backend build-depends: - arithmoi>=0.4.1.3 && <0.5, + arithmoi >= 0.4.1.3 && <0.5, base==4.8.*, - constraints==0.4.*, - containers>=0.5.6.2 && < 0.6, - data-default>=0.3.0 && < 0.6, - deepseq>=1.4.1.1 && <1.5, - MonadRandom>=0.2 && < 0.5, - mtl>=2.2.1 && < 2.3, - numeric-prelude>=0.4.2 && < 0.5, - QuickCheck>=2.8 && < 2.9, - random>=1.1 && < 1.2, - reflection>=1.5.1 && < 2.2, + binary, + bytestring, + constraints, + containers >= 0.5.6.2 && < 0.6, + crypto-api, + data-default >= 0.3.0 && < 0.6, + deepseq >= 1.4.1.1 && <1.5, + MonadRandom >= 0.2 && < 0.5, + mtl >= 2.2.1 && < 2.3, + numeric-prelude >= 0.4.2 && < 0.5, + QuickCheck >= 2.8 && < 2.9, + random >= 1.1 && < 1.2, + reflection >= 1.5.1 && < 2.2, repa==3.4.*, - singletons>=1.1.2.1 && < 2.1, - storable-record>=0.0.3 && < 0.1, - storable-tuple>=0.0.1 && < 0.1, - th-desugar>=1.5.4 && < 1.6, - type-natural>=0.2.3.2 && < 0.4, - tagged-transformer>=0.7 && < 0.9, - transformers>=0.4.2.0 && < 0.5, + singletons >= 1.1.2.1 && < 2.1, + storable-record >= 0.0.3 && < 0.1, + th-desugar >= 1.5.4 && < 1.6, + tagged-transformer >= 0.7 && < 0.9, + template-haskell >= 2.2.0.0, + transformers >= 0.4.2.0 && < 0.5, vector==0.11.*, - vector-th-unbox>=0.2.1.0 && < 0.3 + vector-th-unbox >= 0.2.1.0 && < 0.3 other-extensions: TemplateHaskell -test-suite lol-test-suite +test-suite test-lol type: exitcode-stdio-1.0 - hs-source-dirs: test-suite + hs-source-dirs: tests,utils default-language: Haskell2010 main-is: Main.hs - -- ghc optimizations ghc-options: -threaded -rtsopts build-depends: base, constraints, + deepseq, + DRBG, lol, MonadRandom, - QuickCheck>=2.8 && < 2.9, + mtl, + QuickCheck >= 2.8 && < 2.9, + random, repa, + singletons, test-framework >= 0.8 && < 0.9, test-framework-quickcheck2 >= 0.3 && < 0.4, - time>=1.2 && < 1.6, - type-natural, vector + +Benchmark bench-lol + type: exitcode-stdio-1.0 + hs-source-dirs: benchmarks,utils + default-language: Haskell2010 + main-is: Main.hs + + -- if flag(llvm) + -- ghc-options: -fllvm -optlo-O3 + ghc-options: -threaded -rtsopts + -- ghc-options: -O2 -Odph -funbox-strict-fields -fwarn-dodgy-imports -rtsopts + -- ghc-options: -fno-liberate-case -funfolding-use-threshold1000 -funfolding-keeness-factor1000 + + build-depends: + base, + criterion, + deepseq, + DRBG, + lol, + MonadRandom, + mtl, + singletons, + transformers, + vector, + repa diff --git a/src/Crypto/Lol.hs b/src/Crypto/Lol.hs deleted file mode 100644 --- a/src/Crypto/Lol.hs +++ /dev/null @@ -1,21 +0,0 @@ - --- | 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 - -import Crypto.Lol.Cyclotomic.Cyc -import Crypto.Lol.Gadget -import Crypto.Lol.LatticePrelude - -import Crypto.Lol.Types.ZqBasic -import Crypto.Lol.Cyclotomic.Tensor.CTensor -import Crypto.Lol.Cyclotomic.Tensor.RepaTensor -import Crypto.Lol.Types.IrreducibleChar2 diff --git a/src/Crypto/Lol/Applications/SymmSHE.hs b/src/Crypto/Lol/Applications/SymmSHE.hs deleted file mode 100644 --- a/src/Crypto/Lol/Applications/SymmSHE.hs +++ /dev/null @@ -1,498 +0,0 @@ -{-# LANGUAGE ConstraintKinds, DataKinds, DeriveDataTypeable, - FlexibleContexts, FlexibleInstances, GADTs, - MultiParamTypeClasses, NoImplicitPrelude, ScopedTypeVariables, - TypeFamilies, TypeOperators, UndecidableInstances #-} - --- | Symmetric-key somewhat homomorphic encryption. - -module Crypto.Lol.Applications.SymmSHE -( --- * Data types -SK, PT, CT -- don't export constructors! --- * Keygen, encryption, decryption -, genSK -, encrypt -, errorTerm, errorTermUnrestricted, decrypt, decryptUnrestricted --- * Encoding of plaintext -, toMSD, toLSD --- * Arithmetic with public values -, addScalar, addPublic, mulPublic --- * Modulus switching -, rescaleLinearCT, modSwitchPT --- * Key switching -, keySwitchLinear, keySwitchQuadCirc --- * Ring switching -, embedSK, embedCT, twaceCT -, tunnelCT --- * Constraint synonyms -, AddPublicCtx, MulPublicCtx, InnerKeySwitchCtx, KeySwitchCtx, KSHintCtx, ModSwitchPTCtx -, ToSDCtx, EncryptCtx, TunnelCtx, GenSKCtx, DecryptCtx -, ErrorTermCtx -) where - -import qualified Algebra.Additive as Additive (C) -import qualified Algebra.Ring as Ring (C) - -import Crypto.Lol.Cyclotomic.Cyc -import Crypto.Lol.Cyclotomic.UCyc (forceDec) -import Crypto.Lol.Cyclotomic.Linear -import Crypto.Lol.Gadget -import Crypto.Lol.LatticePrelude as LP hiding (sin) - -import Control.Applicative hiding ((*>)) -import Control.DeepSeq -import Control.Monad as CM -import Control.Monad.Random -import Data.Maybe -import Data.Traversable as DT -import Data.Typeable - -import MathObj.Polynomial as P - --- | secret key -data SK r where - SK :: (ToRational v, NFData v) => v -> r -> SK r - --- | plaintext -type PT rp = rp - --- | Ciphertext encoding type -data Encoding = MSD | LSD deriving (Show, Eq) - --- | Ciphertext over @R'_q@, encrypting a plaintext in @R_p (R=O_m)@. -data CT (m :: Factored) zp r'q = - CT - !Encoding -- MSD/LSD encoding - !Int -- accumulated power of g_m' in c(s) - !zp -- factor to mul by upon decryption - !(Polynomial r'q) -- the polynomial c(s) - deriving (Typeable, Show) - --- Note: do *not* give an Eq instance for CT, because it's not --- meaningful to compare ciphertexts for equality - -instance (NFData zp, NFData r'q) => NFData (CT m zp r'q) where - rnf (CT _ k sc cs) = rnf k `seq` rnf sc `seq` rnf cs - -instance (NFData r) => NFData (SK r) where - rnf (SK v s) = rnf v `seq` rnf s - ----------- Basic functions: Gen, Enc, Dec ---------- - --- | Constraint synonym for generating a secret key. -type GenSKCtx t m z v = - (ToInteger z, Fact m, CElt t z, ToRational v, NFData v) - --- | Generates a secret key with (index-independent) scaled variance --- parameter @v@; see 'errorRounded'. -genSK :: (GenSKCtx t m z v, MonadRandom rnd) - => v -> rnd (SK (Cyc t m z)) -genSK v = liftM (SK v) $ errorRounded v - --- | Constraint synonym for encryption. -type EncryptCtx t m m' z zp zq = - (Mod zp, Ring zp, Ring zq, Lift zp (ModRep zp), - Reduce z zq, Reduce (LiftOf zp) zq, - CElt t zq, CElt t zp, CElt t z, CElt t (LiftOf zp), - m `Divides` m') - --- | Encrypt a plaintext under a secret key. -encrypt :: forall t m m' z zp zq rnd . (EncryptCtx t m m' z zp zq, MonadRandom rnd) - => SK (Cyc t m' z) -> PT (Cyc t m zp) -> rnd (CT m zp (Cyc t m' zq)) -encrypt (SK svar s) = - let sq = adviseCRT $ reduce s - in \pt -> do - e <- errorCoset svar (embed pt :: PT (Cyc t m' zp)) - c1 <- getRandom - return $! CT LSD zero one $ fromCoeffs [reduce e - c1 * sq, c1] - --- | Constraint synonym for extracting the error term of a ciphertext. -type ErrorTermCtx t m' z zp zq = - (Reduce z zq, Lift' zq, CElt t z, CElt t (LiftOf zq), - ToSDCtx t m' zp zq) - --- | Extract the error term of a ciphertext. -errorTerm :: (ErrorTermCtx t m' z zp zq) - => SK (Cyc t m' z) -> CT m zp (Cyc t m' zq) -> Cyc t m' (LiftOf zq) -errorTerm (SK _ s) = let sq = reduce s in - \ct -> let (CT LSD _ _ c) = toLSD ct - in liftCyc Dec $ evaluate c sq - --- for when we know the division must succeed -divG' :: (Fact m, CElt t r) => Cyc t m r -> Cyc t m r -divG' = fromJust . divG - --- | Constraint synonym for decryption. -type DecryptCtx t m m' z zp zq = - (ErrorTermCtx t m' z zp zq, Reduce (LiftOf zq) zp, - m `Divides` m', CElt t zp) - --- | Decrypt a ciphertext. -decrypt :: forall t m m' z zp zq . (DecryptCtx t m m' z zp zq) - => SK (Cyc t m' z) -> CT m zp (Cyc t m' zq) -> PT (Cyc t m zp) -decrypt sk ct = - let ct'@(CT LSD k l _) = toLSD ct - in let e :: Cyc t m' zp = reduce $ errorTerm sk ct' - in (scalarCyc l) * twace (iterate divG' e !! k) - ---- unrestricted versions --- - --- | More general form of 'errorTerm' that works for unrestricted --- output coefficient types. -errorTermUnrestricted :: - (Reduce z zq, Lift' zq, CElt t z, ToSDCtx t m' zp zq) - => SK (Cyc t m' z) -> CT m zp (Cyc t m' zq) -> Cyc t m' (LiftOf zq) -errorTermUnrestricted (SK _ s) = let sq = reduce s in - \ct -> let (CT LSD _ _ c) = toLSD ct - eval = evaluate c sq - in cyc $ fmap lift $ forceDec $ unsafeUnCyc eval - --- | More general form of 'decrypt' that works for unrestricted output --- coefficient types. -decryptUnrestricted :: - (Fact m, Fact m', CElt t zp, m `Divides` m', - Reduce z zq, Lift' zq, CElt t z, ToSDCtx t m' zp zq, Reduce (LiftOf zq) zp) - => SK (Cyc t m' z) -> CT m zp (Cyc t m' zq) -> PT (Cyc t m zp) - -decryptUnrestricted (SK _ s) = let sq = reduce s in - \ct -> let (CT LSD k l c) = toLSD ct - in let eval = evaluate c sq - e = cyc $ fmap (reduce . lift) $ forceDec $ unsafeUnCyc eval - l' = scalarCyc l - in l' * twace (iterate divG' e !! k) - ----------- LSD/MSD switching ---------- - --- | Constraint synonym for converting between ciphertext encodings. -type ToSDCtx t m' zp zq = (Encode zp zq, Fact m', CElt t zq) - -toLSD, toMSD :: ToSDCtx t m' zp zq - => CT m zp (Cyc t m' zq) -> CT m zp (Cyc t m' zq) - --- CJP: reduce duplication in these functions? They differ in only two places - --- | Convert a ciphertext to MSD encoding. -toMSD = let (zpScale, zqScale) = lsdToMSD - rqScale = scalarCyc zqScale - in \ct@(CT enc k l c) -> case enc of - MSD -> ct - LSD -> CT MSD k (zpScale * l) ((rqScale *) <$> c) - --- | Convert a ciphertext to LSD encoding. -toLSD = let (zpScale, zqScale) = msdToLSD - rqScale = scalarCyc zqScale - in \ct@(CT enc k l c) -> case enc of - LSD -> ct - MSD -> CT LSD k (zpScale * l) ((rqScale *) <$> c) - ----------- Modulus switching ---------- - --- | Rescale a linear polynomial in MSD encoding, for best noise --- behavior. -rescaleLinearMSD :: (RescaleCyc (Cyc t) zq zq', Fact m') - => Polynomial (Cyc t m' zq) -> Polynomial (Cyc t m' zq') -rescaleLinearMSD c = case coeffs c of - [] -> fromCoeffs [] - [c0] -> fromCoeffs [rescaleCyc Dec c0] - [c0,c1] -> let c0' = rescaleCyc Dec c0 - c1' = rescaleCyc Pow c1 - in fromCoeffs [c0', c1'] - _ -> error $ "rescaleLinearMSD: list too long (not linear): " ++ - show (length $ coeffs c) - --- | Rescale a linear ciphertext to a new modulus. -rescaleLinearCT :: (RescaleCyc (Cyc t) zq zq', ToSDCtx t m' zp zq) - => CT m zp (Cyc t m' zq) -> CT m zp (Cyc t m' zq') -rescaleLinearCT ct = let CT MSD k l c = toMSD ct - in CT MSD k l $ rescaleLinearMSD c - --- | Constraint synonym for modulus switching. -type ModSwitchPTCtx t m' zp zp' zq = - (Lift' zp, Reduce (LiftOf zp) zp', ToSDCtx t m' zp zq) - --- | Homomorphically divide a plaintext that is known to be a multiple --- of @(p\/p\')@ by that factor, thereby scaling the plaintext modulus --- from @p@ to @p\'@. -modSwitchPT :: (ModSwitchPTCtx t m' zp zp' zq) - => CT m zp (Cyc t m' zq) -> CT m zp' (Cyc t m' zq) -modSwitchPT ct = let CT MSD k l c = toMSD ct in - CT MSD k (reduce (lift l)) c - ----------- Key switching ---------- - -type LWECtx t m' z zq = - (ToInteger z, Reduce z zq, Ring zq, Fact m', CElt t z, CElt t zq) - --- | An LWE sample for a given secret (corresponding to a linear --- ciphertext encrypting 0 in MSD form) -lweSample :: (LWECtx t m' z zq, MonadRandom rnd) - => SK (Cyc t m' z) -> rnd (Polynomial (Cyc t m' zq)) -lweSample (SK svar s) = - -- adviseCRT because we call `replicateM (lweSample s)` below, but only want to do CRT once. - let sq = adviseCRT $ negate $ reduce s - in do - e <- errorRounded svar - c1 <- adviseCRT <$> getRandom -- we would like hints to be in CRT form - return $ fromCoeffs [c1 * sq + reduce (e `asTypeOf` s), c1] - --- | Constraint synonym for generating key-switch hints. -type KSHintCtx gad t m' z zq = - (LWECtx t m' z zq, Reduce (DecompOf zq) zq, Gadget gad zq, - CElt t (DecompOf zq)) - --- | Generate a hint that "encrypts" a value under a secret key, in --- the sense required for key-switching. The hint works for any --- plaintext modulus, but must be applied on a ciphertext in MSD form. -ksHint :: (KSHintCtx gad t m' z zq, MonadRandom rnd) - => SK (Cyc t m' z) -> Cyc t m' z - -> rnd (Tagged gad [Polynomial (Cyc t m' zq)]) -ksHint skout val = do -- rnd monad - let valq = reduce val - valgad = encode valq - -- CJP: clunky, but that's what we get without a MonadTagged - samples <- DT.mapM (\as -> replicateM (length as) (lweSample skout)) valgad - return $ zipWith (+) <$> (map P.const <$> valgad) <*> samples - -type KnapsackCtx t (m' :: Factored) z zq' = - (Reduce z zq', Fact m', CElt t z, CElt t zq') - --- poor man's module multiplication for knapsack -(*>>) :: Ring r => r -> Polynomial r -> Polynomial r -(*>>) r = fmap (r *) - -knapsack :: forall t m' z zq' . (KnapsackCtx t m' z zq') - => [Polynomial (Cyc t m' zq')] -> [Cyc t m' z] -> Polynomial (Cyc t m' zq') --- adviseCRT here because we are about to map (*) onto each polynomial coeff -knapsack hint xs = sum (zipWith (*>>) (adviseCRT <$> reduce <$> xs) hint) - -type InnerKeySwitchCtx gad t m' zq zq' = - (RescaleCyc (Cyc t) zq' zq, RescaleCyc (Cyc t) zq zq', - Decompose gad zq', KnapsackCtx t m' (DecompOf zq') zq') - --- Helper function: applies key-switch hint to a ring element. --- Signature is such that we should rescale input and output. -switch :: forall gad t m' zq' zq . (InnerKeySwitchCtx gad t m' zq zq') - => Tagged gad [Polynomial (Cyc t m' zq')] -> Cyc t m' zq -> Polynomial (Cyc t m' zq) -switch hint c = rescaleLinearMSD $ untag $ knapsack <$> - hint <*> decompose (rescaleCyc Pow c :: Cyc t m' zq') - --- | Constraint synonym for key switching. -type KeySwitchCtx gad t m' zp zq zq' = - (ToSDCtx t m' zp zq, InnerKeySwitchCtx gad t m' zq zq') - --- | Switch a linear ciphertext under @s_in@ to a linear one under @s_out@ -keySwitchLinear :: forall gad t m' zp zq zq' z rnd m . - (KeySwitchCtx gad t m' zp zq zq', KSHintCtx gad t m' z zq', MonadRandom rnd) - => SK (Cyc t m' z) -- sout - -> SK (Cyc t m' z) -- sin - -> TaggedT (gad, zq') rnd (CT m zp (Cyc t m' zq) -> CT m zp (Cyc t m' zq)) -keySwitchLinear skout (SK _ sin) = tagT $ do - hint :: Tagged gad [Polynomial (Cyc t m' zq')] <- ksHint skout sin - return $ hint `deepseq` - (\ct -> let CT MSD k l c = toMSD ct - [c0,c1] = coeffs c - in CT MSD k l $ P.const c0 + switch hint c1) - --- | Switch a quadratic ciphertext (i.e., one with three components) --- to a linear one under the /same/ key. -keySwitchQuadCirc :: forall gad t m' zp zq zq' z m rnd . - (KeySwitchCtx gad t m' zp zq zq', KSHintCtx gad t m' z zq', MonadRandom rnd) - => SK (Cyc t m' z) - -> TaggedT (gad, zq') rnd (CT m zp (Cyc t m' zq) -> CT m zp (Cyc t m' zq)) -keySwitchQuadCirc sk@(SK _ s) = tagT $ do - hint :: Tagged gad [Polynomial (Cyc t m' zq')] <- ksHint sk (s*s) - return $ hint `deepseq` (\ct -> - let CT MSD k l c = toMSD ct - [c0,c1,c2] = coeffs c - in CT MSD k l $ P.fromCoeffs [c0,c1] + switch hint c2) - ----------- Misc homomorphic operations ---------- - -type AddScalarCtx t m' zp zq = - (Lift' zp, Reduce (LiftOf zp) zq, ToSDCtx t m' zp zq) - --- | Homomorphically add a public @Z_p@ value to an encrypted value. The --- ciphertext must not carry any @g@ factors. -addScalar :: (AddScalarCtx t m' zp zq) - => zp -> CT m zp (Cyc t m' zq) -> CT m zp (Cyc t m' zq) -addScalar b ct = - let (l,c) = case toLSD ct of - CT LSD 0 l c -> (l,c) - CT LSD _ _ _ -> error "cannot add public scalar to ciphertext with 'g' factors" - _ -> error "internal error: addScalar" - b' = scalarCyc (reduce $ lift $ b * recip l) - in CT LSD 0 l $ c + P.const b' - --- | Constraint synonym for adding a public value to an encrypted value -type AddPublicCtx t m m' zp zq = - (Lift' zp, Reduce (LiftOf zp) zq, m `Divides` m', - CElt t zp, CElt t (LiftOf zp), ToSDCtx t m' zp zq) - --- | Homomorphically add a public @R_p@ value to an encrypted value. -addPublic :: forall t m m' zp zq . (AddPublicCtx t m m' zp zq) - => Cyc t m zp -> CT m zp (Cyc t m' zq) -> CT m zp (Cyc t m' zq) -addPublic b ct = let CT LSD k l c = toLSD ct in - let linv = scalarCyc $ recip l - -- multiply public value by appropriate power of g and divide by the - -- scale, to match the form of the ciphertext - b' :: Cyc t m zq = reduce $ liftCyc Pow $ linv * (iterate mulG b !! k) - in CT LSD k l $ c + P.const (embed b') - --- | Constraint synonym for multiplying a public value with an encrypted value -type MulPublicCtx t m m' zp zq = - (Lift' zp, Reduce (LiftOf zp) zq, Ring zq, m `Divides` m', - CElt t zp, CElt t (LiftOf zp), CElt t zq) - --- | Homomorphically multiply an encrypted value by a public @R_p@ value. -mulPublic :: forall t m m' zp zq . (MulPublicCtx t m m' zp zq) - => Cyc t m zp -> CT m zp (Cyc t m' zq) -> CT m zp (Cyc t m' zq) -mulPublic a (CT enc k l c) = - let a' = embed (reduce $ liftCyc Pow a :: Cyc t m zq) - in CT enc k l $ (a' *) <$> c - --- | Increment the internal g exponent without changing the encrypted --- message. -mulGCT :: (Fact m', CElt t zq) - => CT m zp (Cyc t m' zq) -> CT m zp (Cyc t m' zq) -mulGCT (CT enc k l c) = CT enc (k+1) l $ mulG <$> c - ----------- NumericPrelude instances ---------- - -instance (Eq zp, m `Divides` m', ToSDCtx t m' zp zq) - => Additive.C (CT m zp (Cyc t m' zq)) where - - zero = CT LSD 0 one zero - - -- the scales, g-exponents of ciphertexts, and MSD/LSD types must match. - ct1@(CT enc1 k1 l1 c1) + ct2@(CT enc2 k2 l2 c2) - -- for simplicity, we don't currently support this. Shouldn't be - -- too complicated though. - | l1 /= l2 = error "Cannot add ciphertexts with different scale values" - | k1 < k2 = iterate mulGCT ct1 !! (k2-k1) + ct2 - | k1 > k2 = ct1 + iterate mulGCT ct2 !! (k1-k2) - | enc1 == LSD && enc2 == MSD = toMSD ct1 + ct2 - | enc1 == MSD && enc2 == LSD = ct1 + toMSD ct2 - | otherwise = CT enc1 k1 l1 $ c1 + c2 - - negate (CT enc k l c) = CT enc k l $ negate <$> c - -instance (ToSDCtx t m' zp zq, Additive (CT m zp (Cyc t m' zq))) - => Ring.C (CT m zp (Cyc t m' zq)) where - - one = CT LSD 0 one one - - -- need at least one ct to be in LSD form - ct1@(CT MSD _ _ _) * ct2@(CT MSD _ _ _) = toLSD ct1 * ct2 - - -- first is in LSD - (CT LSD k1 l1 c1) * (CT d2 k2 l2 c2) = - -- mul by g so error maintains invariant: error*g is "round" - CT d2 (k1+k2+1) (l1*l2) (mulG <$> c1 * c2) - - -- else, second must be in LSD - ct1 * ct2 = ct2 * ct1 - -{- CJP: do we want/need this? We have mulPublic... - -instance (MulPublicCtx t m m' zp zq, Reduce z' zp, CElt t z', - l `Divides` m, Additive (CT m zp (c m' zq)), Ring (c l z')) - => Module.C (c l z') (CT m zp (c m' zq)) where - - (*>) a = mulPublic (embed $ reduce a) --} - ----------- Ring switching ---------- - -type AbsorbGCtx t m' zp zq = - (Lift' zp, Reduce (LiftOf zp) zq, Ring zp, Ring zq, Fact m', - CElt t (LiftOf zp), CElt t zp, CElt t zq) - --- | "Absorb" the powers of g associated with the ciphertext, at the --- cost of some increase in noise. This is usually needed before --- changing the index of the ciphertext ring. -absorbGFactors :: forall t zp zq m m' . (AbsorbGCtx t m' zp zq) - => CT m zp (Cyc t m' zq) -> CT m zp (Cyc t m' zq) -absorbGFactors ct@(CT enc k l c) - | k == 0 = ct - | k > 0 = let d :: Cyc t m' zp = iterate divG' one !! k - rep = adviseCRT $ reduce $ liftCyc Pow d - in CT enc 0 l $ (rep *) <$> c - | otherwise = error "k < 0 in absorbGFactors" - --- | Embed a ciphertext in R' encrypting a plaintext in R to a --- ciphertext in T' encrypting a plaintext in T. The target ciphertext --- ring T' must contain both the the source ciphertext ring R' and the --- target plaintext ring T. -embedCT :: (CElt t zq, - r `Divides` r', s `Divides` s', r `Divides` s, r' `Divides` s') - => CT r zp (Cyc t r' zq) -> CT s zp (Cyc t s' zq) --- We could call absorbGFactors first, insead of error. Embedding --- *essentially* maintains the invariant that noise*g is "round." --- While g'/g can be non-spherical, it only stretches by at most a --- factor of 2 per new odd prime. We *cannot* multiply by g, then --- embed, then divide by g' because the result would not remain in R'. --- So this is the best we can do. -embedCT (CT d 0 l c) = CT d 0 l (embed <$> c) -embedCT _ = error "embedCT requires 0 factors of g; call aborbGFactors first" - --- | Embed a secret key from a subring into a superring. -embedSK :: (CElt t z, m `Divides` m') => SK (Cyc t m z) -> SK (Cyc t m' z) -embedSK (SK v s) = SK v $ embed s - --- | "Tweaked trace" function for ciphertexts. Mathematically, the --- target plaintext ring @S@ must contain the intersection of the --- source plaintext ring @T@ and the target ciphertext ring @S\'@. --- Here we make the stricter requirement that @s = gcd(s\', t)@. -twaceCT :: (CElt t zq, r `Divides` r', s' `Divides` r', - s ~ (FGCD s' r)) - => CT r zp (Cyc t r' zq) -> CT s zp (Cyc t s' zq) --- we could call absorbGFactors first, insead of error -twaceCT (CT d 0 l c) = CT d 0 l (twace <$> c) -twaceCT _ = error "twaceCT requires 0 factors of g; call absorbGFactors first" - - --- | Constraint synonym for ring tunneling. -type TunnelCtx t e r s e' r' s' z zp zq zq' gad = - (ExtendLinIdx e r s e' r' s', -- liftLin - e' ~ (e * (r' / r)), -- convenience; implied by prev constraint - KSHintCtx gad t r' z zq', -- ksHint - Reduce z zq, -- Reduce on Linear - Lift zp z, -- liftLin - CElt t zp, -- liftLin - KeySwitchCtx gad t s' zp zq zq') -- keySwitch - --- | Homomorphically apply the @E@-linear function that maps the --- elements of the decoding basis of @R\/E@ to the corresponding --- @S@-elements in the input array. -tunnelCT :: forall gad t e r s e' r' s' z zp zq zq' rnd . - (TunnelCtx t e r s e' r' s' z zp zq zq' gad, - MonadRandom rnd) - => Linear t zp e r s - -> SK (Cyc t s' z) - -> SK (Cyc t r' z) - -> TaggedT (gad,zq') rnd (CT r zp (Cyc t r' zq) -> CT s zp (Cyc t s' zq)) -tunnelCT f skout (SK _ sin) = tagT $ (do -- in rnd - -- generate hints - let f' = extendLin $ lift f :: Linear t z e' r' s' - f'q = reduce f' :: Linear t zq e' r' s' - -- choice of basis here must match coeffsCyc basis below - ps = proxy powBasis (Proxy::Proxy e') - comps = (evalLin f' . (adviseCRT sin *)) <$> ps - hints :: [Tagged gad [Polynomial (Cyc t s' zq')]] <- CM.mapM (ksHint skout) comps - return $ hints `deepseq` \ct' -> - let CT MSD 0 s c = toMSD $ absorbGFactors ct' - [c0,c1] = coeffs c - -- apply E-linear function to constant term c0 - c0' = evalLin f'q c0 - -- apply E-linear function to c1 via key-switching - -- this basis must match the basis used above to generate the hints - c1s = coeffsCyc Pow c1 :: [Cyc t e' zq] - -- CJP: don't embed the c1s before decomposing them (inside - -- switch); instead decompose in smaller ring before - -- embedding (it matters). - -- We may need to generalize switch or define an - -- alternative. - c1s' = zipWith switch hints (embed <$> c1s) - c1' = sum c1s' - in CT MSD 0 s $ P.const c0' + c1') - \\ lcmDivides (Proxy::Proxy r) (Proxy::Proxy e') diff --git a/src/Crypto/Lol/CRTrans.hs b/src/Crypto/Lol/CRTrans.hs deleted file mode 100644 --- a/src/Crypto/Lol/CRTrans.hs +++ /dev/null @@ -1,181 +0,0 @@ -{-# LANGUAGE FlexibleContexts, FlexibleInstances, RebindableSyntax, - ScopedTypeVariables, TypeFamilies #-} - --- | Classes and helper methods for the Chinese remainder transform --- and ring extensions. - -module Crypto.Lol.CRTrans -( CRTrans(..), CRTEmbed(..) -, CRTInfo -, crtInfoFact, crtInfoPPow, crtInfoNatC -, gEmbPPow, gEmbNatC -, omegaPowMod, zqHasCRT -) where - -import Crypto.Lol.LatticePrelude - -import Math.NumberTheory.Primes.Factorisation (carmichael, factorise) - -import Control.Arrow -import Data.Singletons -import Data.Singletons.Prelude -import Data.Type.Natural (Sing (SS)) -import qualified Data.Vector as V - --- | Information that characterizes the (invertible) Chinese remainder --- transformation over a ring @r@, namely: --- --- (1) a function that returns the @i@th power of some @m@th root --- of unity (for any integer @i@) --- --- (2) the multiplicative inverse of @\\hat{m}@ in @r@. - -type CRTInfo r = (Int -> r, r) - --- | A ring that (possibly) supports invertible Chinese remainder --- transformations of various indices. - --- | 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'@. - -class Ring r => CRTrans 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 - --- | A ring with a ring embedding into some ring @CRTExt r@ that has --- an invertible CRT transformation for /every/ positive index @m@. -class (Ring r, Ring (CRTExt r)) => CRTEmbed r where - type CRTExt r - - -- | Embeds from @r@ to @CRTExt r@ - toExt :: r -> CRTExt r - -- | 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)) - --- CRTEmbed instance for product rings -instance (CRTEmbed a, CRTEmbed b) => CRTEmbed (a,b) where - type CRTExt (a,b) = (CRTExt a, CRTExt b) - toExt = toExt *** toExt - fromExt = fromExt *** fromExt - --- | Default implementation of 'omegaPow' for 'Mod' types. The --- implementation finds an integer element of maximal multiplicative --- order, and raises it to the appropriate power. Therefore, the --- functions returned for different values of the first argument are --- consistent, i.e., @omega_{m'}^(m'/m) = omega_m@. -omegaPowMod :: forall r . (Mod r, Enumerable r, Ring r, Eq r) - => Int -> Maybe (Int -> r) -omegaPowMod = -- use Integers for all intermediate calcs - - -- CJP: there's a mismatch here between the semantics of Mod and the - -- use of 'values'. If r really represents *integers* modulo - -- something then we're fine, otherwise we might get weird behavior. - - let -- the exponent of Z_q^* - exponent = carmichael $ fromIntegral (proxy modulus (Proxy::Proxy r)) - -- all prime divisors of exponent - primes = map fst $ factorise exponent - -- the powers we need to check - exps = map (exponent `div`) primes - -- whether an element is a unit with maximal order - isGood x = (x^exponent == one) && all (\e -> x^e /= one) exps - in \m -> let (mq, mr) = exponent `divMod` fromIntegral m - in if mr == 0 - then let omega = head (filter isGood values) ^ mq - omegaPows = V.iterateN m (*omega) one - in Just $ (omegaPows V.!) . (`mod` m) - else Nothing - -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 'NatC' types. -crtInfoNatC :: (NatC p, CRTrans r) => TaggedT p Maybe (CRTInfo r) -crtInfoNatC = (tagT . crtInfo) =<< pureT valueNatC - --- | 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 - -- intentionally no match for zero exponents - (SPP (STuple2 sp (SS _))) -> withWitnessT gEmbNatC sp - --- | A function that returns the @i@th embedding of @g_p@ for @i@ in @Z*_p@, --- i.e., @1-omega_p^i@. -gEmbNatC :: (NatC p, CRTrans r) => TaggedT p Maybe (Int -> r) -gEmbNatC = do - (f, _) <- crtInfoNatC - return $ \i -> one - f i -- not checking that i /= 0 (mod p) - --- | @zqHasCRT m q@ says whether @Z_q@ has an /invertible/ CRT --- transform of index @m@, i.e., @Z_q@ has an element of --- multiplicative order @m@, and @mhat@ is invertible in @Z_q@. -zqHasCRT :: (ToInteger i, PID i) => i -> i -> Bool -zqHasCRT m q = let exponent = fromIntegral $ carmichael $ - fromIntegral q - mhat = if 2 `divides` m then m `div` 2 else m - in m `divides` exponent && fst (extendedGCD mhat q) == one - --- 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) - --- trivial CRTEmbed instance for complex numbers -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 --- 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. -instance CRTEmbed Double where - type CRTExt Double = Complex Double - toExt = fromReal . realToField - fromExt = realToField . real - -instance CRTEmbed Int where - type CRTExt Int = Complex Double - toExt = fromIntegral - fromExt = fst . roundComplex - -instance CRTEmbed Int64 where - type CRTExt Int64 = Complex Double - toExt = fromIntegral - fromExt = fst . roundComplex - -instance CRTEmbed Integer where - -- CJP: sufficient precision? Not in general. - type CRTExt Integer = Complex Double - toExt = fromIntegral - fromExt = fst . roundComplex diff --git a/src/Crypto/Lol/Cyclotomic/Cyc.hs b/src/Crypto/Lol/Cyclotomic/Cyc.hs deleted file mode 100644 --- a/src/Crypto/Lol/Cyclotomic/Cyc.hs +++ /dev/null @@ -1,184 +0,0 @@ -{-# LANGUAGE ConstraintKinds, DataKinds, FlexibleContexts, - FlexibleInstances, GADTs, GeneralizedNewtypeDeriving, - MultiParamTypeClasses, NoImplicitPrelude, PolyKinds, - RankNTypes, ScopedTypeVariables, StandaloneDeriving, - TypeFamilies, TypeOperators, UndecidableInstances #-} - --- | An implementation of cyclotomic rings with safe interface: --- functions and instances involving 'Cyc' expose nothing about the --- internal representations of ring elements (e.g., the basis they are --- represented in). For an experts-only, "unsafe" implementation that --- offers limited exposure of internal representation, use --- 'Crypto.Lol.Cyclotomic.UCyc.UCyc'. - -module Crypto.Lol.Cyclotomic.Cyc -( --- * Data type - Cyc, U.CElt, cyc, unsafeUnCyc --- * Basic operations -, mulG, divG -, scalarCyc, liftCyc -, advisePow, adviseDec, adviseCRT --- * Error sampling -, tGaussian, errorRounded, errorCoset --- * Sub/extension rings -, embed, twace, powBasis, crtSet, coeffsCyc -, module Crypto.Lol.Cyclotomic.Utility -) where - -import Algebra.Additive as Additive (C) -import Algebra.Ring as Ring (C) - -import Crypto.Lol.Cyclotomic.UCyc (CElt, UCyc) -import qualified Crypto.Lol.Cyclotomic.UCyc as U -import Crypto.Lol.Cyclotomic.Utility -import Crypto.Lol.Gadget -import Crypto.Lol.LatticePrelude as LP -import Crypto.Lol.Types.ZPP - -import Control.Applicative hiding ((*>)) -import Control.DeepSeq -import Control.Monad.Random - -import Data.Coerce - -import Test.QuickCheck - --- | Wrapper around 'UCyc' that exposes a narrower, safe interface. -newtype Cyc t m r = Cyc { - -- | Unsafe deconstructor for 'Cyc'. - unsafeUnCyc :: UCyc t m r } - deriving (Arbitrary, Random) - --- See: https://ghc.haskell.org/trac/ghc/ticket/11008 --- for why I have to use StandaloneDeriving here -deriving instance NFData (UCyc t m a) => NFData (Cyc t m a) -deriving instance Show (UCyc t m a) => Show (Cyc t m a) -deriving instance Eq (UCyc t m a) => Eq (Cyc t m a) -deriving instance Additive (UCyc t m a) => Additive.C (Cyc t m a) -deriving instance Ring (UCyc t m a) => Ring.C (Cyc t m a) -deriving instance Gadget gad (UCyc t m a) => Gadget gad (Cyc t m a) -deriving instance Correct gad (UCyc t m a) => Correct gad (Cyc t m a) - --- | Smart constructor (to prevent clients from pattern-matching). -cyc :: UCyc t m r -> Cyc t m r -cyc = Cyc - --- (try to) replace all occurrences of 'Cyc' with 'UCyc' -type family O a where - O (Cyc t m a) = UCyc t m a - O (a -> b) = O a -> O b - O (m a) = m (O a) -- works for concrete m, but not vars - O a = a - --- specialized 'coerce', to aid type inference -coerceCyc :: (Coercible (O a) a) => O a -> a -coerceCyc = coerce - --- Can't seem to auto-derive these, due to constraints with GND and --- MPTCs. -instance (Reduce a b, Fact m, CElt t a, CElt t b) - => Reduce (Cyc t m a) (Cyc t m b) where - reduce = coerceCyc reduce - --- CJP: will this pick the right overlapping instance for UCyc? I --- think so... -instance (RescaleCyc (UCyc t) a b) => RescaleCyc (Cyc t) a b where - rescaleCyc = coerceCyc rescaleCyc - -instance (Decompose gad (UCyc t m zq), - Reduce (Cyc t m (DecompOf zq)) (Cyc t m zq)) - => Decompose gad (Cyc t m zq) where - - type DecompOf (Cyc t m zq) = Cyc t m (DecompOf zq) - decompose = coerceCyc decompose - ----------- Core cyclotomic operations ---------- - -adviseCRT, advisePow, adviseDec :: (Fact m, CElt t r) => Cyc t m r -> Cyc t m r - --- | Yield an equivalent element that /may/ be in a CRT --- representation. This can serve as an optimization hint. E.g., --- call 'adviseCRT' prior to multiplying the same value by many --- other values. -adviseCRT = coerceCyc U.adviseCRT - --- | Same as 'adviseCRT', but for the powerful-basis representation. -advisePow = coerceCyc U.forcePow -- do it, but not required by contract - --- | Same as 'adviseCRT', but for the powerful-basis representation. -adviseDec = coerceCyc U.forceDec - - --- | Multiply by the special element @g@ of the @m@th cyclotomic. -mulG :: (Fact m, CElt t r) => Cyc t m r -> Cyc t m r -mulG = coerceCyc U.mulG - --- | 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 = coerceCyc U.divG - --- | 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. -tGaussian :: (Fact m, OrdFloat q, Random q, CElt t q, - ToRational v, MonadRandom rnd) - => v -> rnd (Cyc t m q) -tGaussian = (Cyc <$>) . U.tGaussian - --- | Generate an LWE error term with given scaled variance, --- deterministically rounded in the decoding basis. -errorRounded :: (ToInteger z, Fact m, CElt t z, - ToRational v, MonadRandom rnd) - => v -> rnd (Cyc t m z) -errorRounded = (Cyc <$>) . U.errorRounded - --- | Generate an LWE error term with given scaled variance @* p^2@ over --- the given coset, deterministically rounded in the decoding basis. -errorCoset :: - (Mod zp, z ~ ModRep zp, Lift zp z, Fact m, - CElt t zp, CElt t z, ToRational v, MonadRandom rnd) - => v -> Cyc t m zp -> rnd (Cyc t m z) -errorCoset v = (Cyc <$>) . U.errorCoset v . unsafeUnCyc - --- | Embed into the extension ring. -embed :: (m `Divides` m', CElt t r) => Cyc t m r -> Cyc t m' r -embed = coerceCyc U.embed - --- | The "tweaked trace" (twace) function --- @Tw(x) = (mhat \/ m'hat) * Tr(g' \/ g * x)@, --- which fixes @R@ pointwise (i.e., @twace . embed == id@). -twace :: (m `Divides` m', CElt t r) => Cyc t m' r -> Cyc t m r -twace = coerceCyc U.twace - --- | Return the given element's coefficient vector with respect to --- the (relative) powerful/decoding basis of the cyclotomic --- extension @O_m' / O_m@. -coeffsCyc :: (m `Divides` m', CElt t r) - => Basis -> Cyc t m' r -> [Cyc t m r] -coeffsCyc = coerceCyc U.coeffsCyc - --- | The relative powerful basis of @O_m' / O_m@. -powBasis :: (m `Divides` m', CElt t r) => Tagged m [Cyc t m' r] -powBasis = coerceCyc U.powBasis - --- | The relative mod-@r@ "CRT set" of the extension. -crtSet :: (m `Divides` m', ZPP r, CElt t r, CElt t (ZPOf r)) - => Tagged m [Cyc t m' r] -crtSet = coerceCyc U.crtSet - --- | Lift in the specified basis. -liftCyc :: (Lift b a, Fact m, CElt t a, CElt t b) - => Basis -> Cyc t m b -> Cyc t m a -liftCyc = coerceCyc U.liftCyc - --- | Embed a scalar from the base ring as a cyclotomic element. -scalarCyc :: (Fact m, CElt t a) => a -> Cyc t m a -scalarCyc = Cyc . U.scalarCyc - - diff --git a/src/Crypto/Lol/Cyclotomic/Linear.hs b/src/Crypto/Lol/Cyclotomic/Linear.hs deleted file mode 100644 --- a/src/Crypto/Lol/Cyclotomic/Linear.hs +++ /dev/null @@ -1,89 +0,0 @@ -{-# LANGUAGE ConstraintKinds, DataKinds, FlexibleContexts, - GeneralizedNewtypeDeriving, KindSignatures, - MultiParamTypeClasses, NoImplicitPrelude, RoleAnnotations, - ScopedTypeVariables, StandaloneDeriving, - TypeFamilies, TypeOperators, UndecidableInstances #-} - --- | Functions from one cyclotomic ring to another that are linear --- over a common subring. - -module Crypto.Lol.Cyclotomic.Linear -( Linear, ExtendLinIdx -, linearDec, evalLin, extendLin -) where - -import Crypto.Lol.Cyclotomic.Cyc -import Crypto.Lol.LatticePrelude - -import Algebra.Additive as Additive (C) - -import Control.Applicative -import Control.DeepSeq - --- | An @E@-linear function from @R@ to @S@. -newtype Linear t z (e::Factored) (r::Factored) (s::Factored) = D [Cyc t s z] - -deriving instance (NFData (Cyc t s z)) => NFData (Linear t z e r s) - --- TODO: have constructor for both relative Pow basis of R/E? - --- some params are phantom but matter for safety -type role Linear representational nominal representational representational nominal - --- | Construct an @E@-linear function given a list of its output values --- (in @S@) on the relative decoding basis of @R/E@. The number of --- elements in the list must not exceed the size of the basis. -linearDec :: forall t z e r s . - (e `Divides` r, e `Divides` s, CElt t z) - => [Cyc t s z] -> Linear t z e r s -linearDec ys = let ps = proxy powBasis (Proxy::Proxy e) `asTypeOf` ys - in if length ys <= length ps then D (adviseCRT <$> ys) - else error $ "linearDec: too many entries: " - ++ show (length ys) ++ " versus " - ++ show (length ps) - --- | Evaluates the given linear function on the input. -evalLin :: forall t z e r s . - (e `Divides` r, e `Divides` s, CElt t z) - => Linear t z e r s -> Cyc t r z -> Cyc t s z -evalLin (D ys) r = sum (zipWith (*) ys $ - embed <$> (coeffsCyc Dec r :: [Cyc t e z])) - -instance Additive (Cyc t s z) => Additive.C (Linear t z e r s) where - zero = D [] - - (D as) + (D bs) = D $ sumall as bs - where sumall [] ys = ys - sumall xs [] = xs - sumall (x:xs) (y:ys) = x+y : sumall xs ys - - negate (D as) = D $ negate <$> as - -instance (Reduce z zq, Fact s, CElt t z, CElt t zq) - => Reduce (Linear t z e r s) (Linear t zq e r s) where - reduce (D ys) = D $ reduce <$> ys - -instance (CElt t zp, CElt t z, z ~ LiftOf zp, Lift zp z, Fact s) - => Lift' (Linear t zp e r s) where - type LiftOf (Linear t zp e r s) = Linear t (LiftOf zp) e r s - - lift (D ys) = D $ liftCyc Pow <$> ys - --- | A convenient constraint synonym for extending a linear function --- to larger rings. -type ExtendLinIdx e r s e' r' s' = - (Fact r, e ~ FGCD r e', r' ~ FLCM r e', -- these imply R'=R\otimes_E E' - e' `Divides` s', s `Divides` s') -- lcm(s,e')|s' <=> (S+E') \subseteq S' - --- | Extend an @E@-linear function @R->S@ to an @E'@-linear function --- @R\'->S\'@. (Mathematically, such extension only requires --- @lcm(r,e\') | r\'@ (not equality), but this generality would --- significantly complicate the implementation, and for our purposes --- there's no reason to use any larger @r'@.) -extendLin :: (ExtendLinIdx e r s e' r' s', CElt t z) - => Linear t z e r s -> Linear t z e' r' s' --- CJP: this simple implementation works because R/E and R'/E' have --- identical decoding bases, because R' \cong R \otimes_E E'. If we --- relax the constraint on E then we'd have to change the --- implementation to something more difficult. -extendLin (D ys) = D (embed <$> ys) diff --git a/src/Crypto/Lol/Cyclotomic/Tensor.hs b/src/Crypto/Lol/Cyclotomic/Tensor.hs deleted file mode 100644 --- a/src/Crypto/Lol/Cyclotomic/Tensor.hs +++ /dev/null @@ -1,412 +0,0 @@ -{-# LANGUAGE ConstraintKinds, DataKinds, FlexibleContexts, - NoImplicitPrelude, RankNTypes, ScopedTypeVariables, - TupleSections, TypeFamilies, TypeOperators, - UndecidableInstances #-} - --- | Interface for cyclotomic tensors, and helper functions for tensor --- indexing. - -module Crypto.Lol.Cyclotomic.Tensor -( Tensor(..) --- * Top-level CRT functions -, hasCRTFuncs -, scalarCRT, mulGCRT, divGCRT, crt, crtInv, twaceCRT, embedCRT --- * Tensor indexing -, Matrix, indexM, twCRTs -, zmsToIndexFact -, indexInfo -, extIndicesPowDec, extIndicesCRT, extIndicesCoeffs -, baseIndicesPow, baseIndicesDec, baseIndicesCRT -, digitRev -) -where - -import Crypto.Lol.CRTrans -import Crypto.Lol.LatticePrelude as LP hiding (lift, (*>)) -import Crypto.Lol.Types.FiniteField - -import Control.Applicative -import Control.DeepSeq -import Control.Monad.Random -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 - --- | 'Tensor' encapsulates all the core linear transformations needed --- for cyclotomic ring arithmetic. - --- | The type @t m r@ represents a cyclotomic coefficient tensor of --- index @m@ over base ring @r@. Most of the methods represent linear --- transforms corresponding to operations in particular bases. --- CRT-related methods are wrapped in 'Maybe' because they are --- well-defined only when a CRT basis exists over the ring @r@ for --- index @m@. - --- | The superclass constraint is for convenience, to ensure that we --- can sample error tensors of 'Double's. - -class (TElt t Double, TElt t (Complex Double)) - => Tensor (t :: Factored -> * -> *) where - - -- | Constraints needed by @t@ to hold type @r@. - type TElt t r :: Constraint - - -- | 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) - ((Eq r, Fact m, TElt t r) :- (Eq (t m r))) - entailZTT :: Tagged (t m r) - ((ZeroTestable r, Fact m, TElt t r) :- (ZeroTestable (t m r))) - entailRingT :: Tagged (t m r) - ((Ring r, Fact m, TElt t r) :- (Ring (t m r))) - entailNFDataT :: Tagged (t m r) - ((NFData r, Fact m, TElt t r) :- (NFData (t m r))) - entailRandomT :: Tagged (t m r) - ((Random r, Fact m, TElt t r) :- (Random (t m r))) - - -- | Converts a scalar to a tensor in the powerful basis - scalarPow :: (Ring 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 :: (Ring r, Fact m, TElt t r) => t m r -> t m r - - -- | Multiply by @g@ in the powerful/decoding basis - mulGPow, mulGDec :: (Ring r, Fact m, TElt t r) => t m r -> t m r - - -- | Divide by @g@ in the powerful/decoding basis. The 'Maybe' - -- output indicates that the operation may fail, which happens - -- exactly when the input is not divisible by @g@. - divGPow, divGDec :: (ZeroTestable r, IntegralDomain r, Fact m, TElt t r) - => t m r -> Maybe (t m r) - - -- | A tuple of all the operations relating to the CRT basis, in a - -- single 'Maybe' value for safety. Clients should typically not - -- 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 :: (ZeroTestable r, IntegralDomain r, CRTrans r, Fact m, TElt 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 - - -- | Sample from the "skewed" Gaussian error distribution @t*D@ - -- in the decoding basis, where @D@ has scaled variance @v@. - tGaussianDec :: (OrdFloat q, Random q, TElt t q, - ToRational v, Fact m, MonadRandom rnd) - => v -> rnd (t m q) - - -- | The @twace@ linear transformation, which is the same in both the - -- powerful and decoding bases. - twacePowDec :: (Ring r, m `Divides` m', TElt t r) => t m' r -> t m r - - -- | The @embed@ linear transformations, for the powerful and - -- decoding bases. - embedPow, embedDec :: (Ring r, m `Divides` m', TElt t r) - => t m r -> t m' r - - -- | A tuple of all the extension-related operations involving the - -- CRT bases, for safety. Clients should typically not use this - -- method directly, but instead call the corresponding top-level - -- functions: the elements of the tuple correpond to the functions - -- 'twaceCRT', 'embedCRT'. - crtExtFuncs :: (ZeroTestable r, IntegralDomain r, CRTrans r, - m `Divides` m', TElt t r) => - Maybe (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@ - -- elements in the same kind of basis. - coeffs :: (Ring r, m `Divides` m', TElt t r) => t m' r -> [t m r] - - -- | The powerful extension basis w.r.t. the powerful basis. - powBasisPow :: (Ring r, TElt t r, m `Divides` m') => Tagged m [t m' r] - - -- | A list of tensors representing the mod-@p@ CRT set of the - -- extension. - crtSetDec :: (PrimeField fp, m `Divides` m', - Coprime (PToF (CharOf fp)) m', TElt t fp) - => Tagged m [t m' fp] - - -- | Potentially optimized version of 'fmap' when the input and - -- output element types 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) - --- | Convenience value indicating whether 'crtFuncs' exists. -hasCRTFuncs :: forall t m r . (ZeroTestable r, IntegralDomain r, CRTrans r, - Tensor t, Fact m, TElt t r) - => TaggedT (t m r) Maybe () -hasCRTFuncs = tagT $ do - (_ :: r -> t m r,_,_,_,_) <- crtFuncs - return () - --- | Yield a tensor for a scalar in the CRT basis. (This function is --- simply an appropriate entry from 'crtFuncs'.) -scalarCRT :: (ZeroTestable r, IntegralDomain r, CRTrans r, - Tensor t, Fact m, TElt t r) => Maybe (r -> t m r) -scalarCRT = (\(f,_,_,_,_) -> f) <$> crtFuncs - - -mulGCRT, divGCRT, crt, crtInv :: - (ZeroTestable r, IntegralDomain r, CRTrans r, Tensor t, Fact m, TElt t r) - => Maybe (t m r -> t m r) --- | Multiply by @g@ in the CRT basis. (This function is simply an --- appropriate entry from 'crtFuncs'.) -mulGCRT = (\(_,f,_,_,_) -> f) <$> crtFuncs --- | Divide by @g@ in the CRT basis. (This function is simply an --- appropriate entry from 'crtFuncs'.) -divGCRT = (\(_,_,f,_,_) -> f) <$> crtFuncs --- | The CRT transform. (This function is simply an appropriate entry --- from 'crtFuncs'.) -crt = (\(_,_,_,f,_) -> f) <$> crtFuncs --- | The inverse CRT transform. (This function is simply an --- appropriate entry from 'crtFuncs'.) -crtInv = (\(_,_,_,_,f) -> f) <$> crtFuncs - --- | The "tweaked trace" function for tensors in the CRT basis: --- 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' . (ZeroTestable r, IntegralDomain r, CRTrans r, - Tensor t, m `Divides` m', TElt t r) - => Maybe (t m' r -> t m r) -twaceCRT = proxyT hasCRTFuncs (Proxy::Proxy (t m' r)) *> - proxyT hasCRTFuncs (Proxy::Proxy (t m r)) *> - (fst <$> crtExtFuncs) - --- | 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' . (ZeroTestable r, IntegralDomain r, CRTrans r, - Tensor t, m `Divides` m', TElt t r) - => Maybe (t m r -> t m' r) -embedCRT = proxyT hasCRTFuncs (Proxy::Proxy (t m' r)) *> - proxyT hasCRTFuncs (Proxy::Proxy (t m r)) *> - (snd <$> crtExtFuncs) - -fMatrix :: forall m r mon . (Fact m, Monad mon, Ring r) - => (forall pp . (PPow pp) => TaggedT pp mon (MatrixC r)) - -> TaggedT m mon (Matrix r) -fMatrix mat = tagT $ go $ sUnF (sing :: SFactored m) - where go :: Sing (pplist :: [PrimePower]) -> mon (Matrix r) - go spps = case spps of - SNil -> return MNil - (SCons spp rest) -> do - rest' <- go rest - mat' <- withWitnessT mat spp - return $ MKron rest' mat' - --- deeply embedded DSL for Kronecker products of matrices - -data MatrixC r = - MC (Int -> Int -> r) -- yields element i,j - Int Int -- dims - --- | A Kronecker product of zero of more matrices over @r@. -data Matrix r = MNil | MKron (Matrix r) (MatrixC r) - --- | 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 = - let (iq,ir) = i `divMod` r - (jq,jr) = j `divMod` c - in indexM m iq jq * mc ir jr - --- | The "tweaked" CRT^* matrix: @CRT^* . diag(sigma(g_m))@. -twCRTs :: (Fact m, CRTrans r) => TaggedT m Maybe (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 = do - phi <- pureT totientPPow - iToZms <- pureT indexToZmsPPow - jToPow <- pureT indexToPowPPow - (wPow, _) <- crtInfoPPow - gEmb <- gEmbPPow - - return $ MC (\j i -> let i' = iToZms i - in wPow (jToPow j * negate i') * gEmb i') phi phi - --- 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 - | e >= 1 = let (q,r) = j `divMod` p - in r * (p^(e-1)) + digitRev (p,e-1) q - -indexToPowPPow, indexToZmsPPow :: PPow pp => Tagged pp (Int -> Int) -indexToPowPPow = indexToPow <$> ppPPow -indexToZmsPPow = indexToZms <$> ppPPow - --- | Convert a @Z_m^*@ index to a linear tensor index in @[m]@. -zmsToIndexFact :: Fact m => Tagged m (Int -> Int) -zmsToIndexFact = zmsToIndex <$> ppsFact - --- | For a prime power @p^e@, map a tensor index to the corresponding --- power j in @[phi(p^e)]@, as in the powerful basis. -indexToPow :: PP -> Int -> Int --- CJP: use accumulator to avoid multiple exponentiations? -indexToPow (p,e) j = let (jq,jr) = j `divMod` (p-1) - in p^(e-1)*jr + digitRev (p,e-1) jq - --- | For a prime power @p^e@, map a tensor index to the corresponding --- 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 - --- | 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 - --- | Inverse of 'indexToZms'. -zmsToIndexPP :: PP -> Int -> Int -zmsToIndexPP (p,_) i = let (i1,i0) = i `divMod` p - in (p-1)*i1 + i0 - 1 - --- Index correspondences for ring extensions - --- | Correspondences between the linear indexes into a basis of O_m', --- and pair indices into (extension basis) \otimes (basis of O_m). --- The work the same for Pow,Dec,CRT bases because all these bases --- have that factorization. The first argument is the list of --- @(phi(m),phi(m'))@ pairs for the (merged) prime powers of @m@,@m'@. -toIndexPair :: [(Int,Int)] -> Int -> (Int,Int) -fromIndexPair :: [(Int,Int)] -> (Int,Int) -> Int - -toIndexPair [] 0 = (0,0) -toIndexPair ((phi,phi'):rest) i' = - let (i'q,i'r) = i' `divMod` phi' - (i'rq,i'rr) = i'r `divMod` phi - (i'q1,i'q0) = toIndexPair rest i'q - in (i'rq + i'q1*(phi' `div` phi), i'rr + i'q0*phi) - -fromIndexPair [] (0,0) = 0 -fromIndexPair ((phi,phi'):rest) (i1,i0) = - let (i0q,i0r) = i0 `divMod` phi - (i1q,i1r) = i1 `divMod` (phi' `div` phi) - i = fromIndexPair rest (i1q,i0q) - in (i0r + i1r*phi) + i*phi' - --- | A collection of useful information for working with tensor --- extensions. The first component is a list of triples @(p,e,e')@ --- where @e@, @e'@ are respectively the exponents of prime @p@ in @m@, --- @m'@. The next two components are @phi(m)@ and @phi(m')@. The --- final component is a pair @(phi(p^e), phi(p^e'))@ for each triple --- in the first component. -indexInfo :: forall m m' . (m `Divides` m') - => Tagged '(m, m') ([(Int,Int,Int)], Int, Int, [(Int,Int)]) -indexInfo = let pps = proxy ppsFact (Proxy::Proxy m) - pps' = proxy ppsFact (Proxy::Proxy m') - mpps = mergePPs pps pps' - phi = totientPPs pps - phi' = totientPPs pps' - tots = totients mpps - in tag (mpps, phi, phi', tots) - --- | A vector of @phi(m)@ entries, where the @i@th entry is the index --- into the powerful\/decoding basis of @O_m'@ of the --- @i@th entry of the powerful\/decoding basis of @O_m@. -extIndicesPowDec :: (m `Divides` m') => Tagged '(m, m') (U.Vector Int) -extIndicesPowDec = do - (_, phi, _, tots) <- indexInfo - return $ U.generate phi (fromIndexPair tots . (0,)) - --- | A vector of @phi(m)@ blocks of @phi(m')\/phi(m)@ consecutive --- entries. Each block contains all those indices into the CRT basis --- of @O_m'@ that "lie above" the corresponding index into the CRT --- basis of @O_m@. -extIndicesCRT :: forall m m' . (m `Divides` m') - => Tagged '(m, m') (U.Vector Int) -extIndicesCRT = do - (_, phi, phi', tots) <- indexInfo - return $ U.generate phi' - (fromIndexPair tots . swap . (`divMod` (phi' `div` phi))) - -baseWrapper :: forall m m' a . (m `Divides` m', U.Unbox a) - => ([(Int,Int,Int)] -> Int -> a) - -> Tagged '(m, m') (U.Vector a) -baseWrapper f = do - (mpps, _, phi', _) <- indexInfo - return $ U.generate phi' (f mpps) - --- | A lookup table for 'toIndexPair' applied to indices @[phi(m')]@. -baseIndicesPow :: forall m m' . (m `Divides` m') - => Tagged '(m, m') (U.Vector (Int,Int)) --- | A lookup table for 'baseIndexDec' applied to indices @[phi(m')]@. -baseIndicesDec :: forall m m' . (m `Divides` m') - => Tagged '(m, m') (U.Vector (Maybe (Int,Bool))) - --- | Same as 'baseIndicesPow', but only includes the second component --- of each pair. -baseIndicesCRT :: forall m m' . (m `Divides` m') - => Tagged '(m, m') (U.Vector Int) - -baseIndicesPow = baseWrapper (toIndexPair . totients) - --- this one is more complicated; requires the prime powers -baseIndicesDec = baseWrapper baseIndexDec - -baseIndicesCRT = - baseWrapper (\pps -> snd . toIndexPair (totients pps)) - - --- | The @i0@th entry of the @i1@th vector is 'fromIndexPair' @(i1,i0)@. -extIndicesCoeffs :: forall m m' . (m `Divides` m') - => Tagged '(m, m') (V.Vector (U.Vector Int)) -extIndicesCoeffs = do - (_, phi, phi', tots) <- indexInfo - return $ V.generate (phi' `div` phi) - (\i1 -> U.generate phi (\i0 -> fromIndexPair tots (i1,i0))) - --- | Convenient reindexing functions - --- | Maps an index of the extension ring array to its corresponding --- index in the base ring array (if it exists), with sign, under the --- decoding basis. -baseIndexDec :: [(Int,Int,Int)] -> Int -> Maybe (Int, Bool) -baseIndexDec [] 0 = Just (0,False) -baseIndexDec ((p,e,e'):rest) i' - = let (i'q, i'r) = i' `divMod` totientPP (p,e') - phi = totientPP (p,e) - curr - | p>2 && e==0 && e' > 0 = case i'r of - 0 -> Just (0,False) - 1 -> Just (0,True) - _ -> Nothing - | otherwise = if i'r < phi then Just (i'r,False) else Nothing - in do - (i,b) <- curr - (j,b') <- baseIndexDec rest i'q - return (i + phi*j, b /= b') - --- the first list of pps must "divide" the other. result is a list of --- all (prime, min e, max e). -mergePPs :: [PP] -> [PP] -> [(Int,Int,Int)] -mergePPs [] pps = LP.map (\(p,e) -> (p,0,e)) pps -mergePPs allpps@((p,e):pps) ((p',e'):pps') - | p == p' && e <= e' = (p, e, e') : mergePPs pps pps' - | p > p' = (p', 0, e') : mergePPs allpps pps' - -totients :: [(Int, Int, Int)] -> [(Int,Int)] -totients = LP.map (\(p,e,e') -> (totientPP (p,e), totientPP (p,e'))) diff --git a/src/Crypto/Lol/Cyclotomic/Tensor/CTensor.hs b/src/Crypto/Lol/Cyclotomic/Tensor/CTensor.hs deleted file mode 100644 --- a/src/Crypto/Lol/Cyclotomic/Tensor/CTensor.hs +++ /dev/null @@ -1,731 +0,0 @@ -{-# LANGUAGE ConstraintKinds, DataKinds, DeriveDataTypeable, GADTs, - FlexibleContexts, FlexibleInstances, TypeOperators, PolyKinds, - GeneralizedNewtypeDeriving, InstanceSigs, RoleAnnotations, - MultiParamTypeClasses, NoImplicitPrelude, StandaloneDeriving, - ScopedTypeVariables, TupleSections, TypeFamilies, RankNTypes, - TypeSynonymInstances, UndecidableInstances, - RebindableSyntax #-} - --- | Wrapper for a C implementation of the 'Tensor' interface. - -module Crypto.Lol.Cyclotomic.Tensor.CTensor -( CT --- Exports below here are due solely to ticket #10338. See CycTests for more details -, CRNS -, Dispatch -) where - -import Algebra.Additive as Additive (C) -import Algebra.Ring as Ring (C) - -import Control.Applicative -import Control.DeepSeq -import Control.Monad -import Control.Monad.Identity -import Control.Monad.Random -import Control.Monad.Trans (lift) - -import Data.Coerce -import Data.Constraint -import Data.Foldable as F -import Data.Int -import Data.Maybe -import Data.Traversable as T -import Data.Typeable -import Data.Vector.Generic as V (zip, unzip) -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.Internal (getPtr) -import Data.Vector.Storable.Mutable as SM hiding (replicate) - -import Foreign.ForeignPtr -import Foreign.Marshal.Array -import Foreign.Ptr -import Foreign.Storable (Storable (..)) -import qualified Foreign.Storable.Record as Store -import Foreign.Storable.Tuple () -import System.IO.Unsafe -import Test.QuickCheck hiding (generate) -import Unsafe.Coerce - -import Crypto.Lol.CRTrans -import Crypto.Lol.LatticePrelude as LP hiding (replicate, unzip, zip, lift) -import Crypto.Lol.Reflects -import Crypto.Lol.Cyclotomic.Tensor - -import Crypto.Lol.Types.IZipVector -import Crypto.Lol.Types.ZqBasic -import Crypto.Lol.GaussRandom - -import Crypto.Lol.Cyclotomic.Tensor.CTensor.Extension - -import Algebra.ZeroTestable as ZeroTestable (C) - - --- | Newtype wrapper around a Vector. -newtype CT' (m :: Factored) r = CT' { unCT :: Vector r } - deriving (Show, Eq, NFData, Typeable) - --- the first argument, though phantom, affects representation -type role CT' representational nominal - --- GADT wrapper that distinguishes between Unbox and unrestricted --- element types - --- | 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 (Typeable) - -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) - -toCT :: (Storable r) => CT m r -> CT m r -toCT v@(CT _) = v -toCT (ZV v) = CT $ zvToCT' v - -toZV :: (Fact m) => CT m r -> CT m r -toZV (CT (CT' v)) = ZV $ fromMaybe (error "toZV: internal error") $ - iZipVector $ convert v -toZV v@(ZV _) = v - -zvToCT' :: forall m r . (Storable r) => IZipVector m r -> CT' m r -zvToCT' v = coerce $ (convert $ unIZipVector v :: Vector r) - -wrap :: (Storable r) => (CT' l r -> CT' m r) -> (CT l r -> CT m r) -wrap f (CT v) = CT $ f v -wrap f (ZV v) = CT $ f $ zvToCT' v - -wrapM :: (Storable r, Monad mon) => (CT' l r -> mon (CT' m r)) - -> (CT l r -> mon (CT m r)) -wrapM f (CT v) = liftM CT $ f v -wrapM f (ZV v) = liftM CT $ f $ zvToCT' v - --- convert an CT' *twace* signature to Tagged one -type family Tw (r :: *) :: * where - Tw (CT' m' r -> CT' m r) = Tagged '(m,m') (Vector r -> Vector r) - Tw (Maybe (CT' m' r -> CT' m r)) = TaggedT '(m,m') Maybe (Vector r -> Vector r) - -type family Em r where - Em (CT' m r -> CT' m' r) = Tagged '(m,m') (Vector r -> Vector r) - Em (Maybe (CT' m r -> CT' m' r)) = TaggedT '(m,m') Maybe (Vector r -> Vector r) - - ----------- NUMERIC PRELUDE INSTANCES ---------- -instance (Additive r, Storable r, CRNS r, Fact m) - => Additive.C (CT m r) where - (CT a@(CT' _)) + (CT b@(CT' _)) = CT $ (zipWrapper $ untag $ cZipDispatch dadd) a b --pack $ SV.zipWith (+) (unpack a) (unpack b) -- Vector code -- - 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 - - zero = CT $ repl zero - -instance (Fact m, Ring r, Storable r, CRNS r) - => Ring.C (CT m r) where - (CT a@(CT' _)) * (CT b@(CT' _)) = CT $ (zipWrapper $ untag $ cZipDispatch dmul) a b --pack $ SV.zipWith (*) (unpack a) (unpack b) -- Vector code -- - a * b = (toCT a) * (toCT b) - - fromInteger = CT . repl . fromInteger - -instance (ZeroTestable r, Storable r, Fact m) - => ZeroTestable.C (CT m r) where - --{-# INLINABLE isZero #-} - isZero (CT (CT' a)) = SV.foldl' (\ b x -> b && isZero x) True a - isZero (ZV v) = isZero v - ----------- "Container" instances ---------- - -instance Fact m => Functor (CT m) where - -- Functor instance is implied by Applicative laws - fmap f x = pure f <*> x - -instance Fact m => Applicative (CT m) where - pure = ZV . pure - - (ZV f) <*> (ZV a) = ZV (f <*> a) - f@(ZV _) <*> v@(CT _) = f <*> toZV v - -instance Fact m => Foldable (CT m) where - -- Foldable instance is implied by Traversable - foldMap = foldMapDefault - -instance Fact m => Traversable (CT m) where - traverse f r@(CT _) = T.traverse f $ toZV r - traverse f (ZV v) = ZV <$> T.traverse f v - -instance Tensor CT where - - type TElt CT r = (Storable r, CRNS r) - - entailIndexT = tag $ Sub Dict - entailEqT = tag $ Sub Dict - entailZTT = tag $ Sub Dict - entailRingT = tag $ Sub Dict - entailNFDataT = tag $ Sub Dict - entailRandomT = tag $ Sub Dict - - - scalarPow = CT . scalarPow' -- Vector code - - l = wrap $ lgWrapper $ untag $ lgDispatch dl - lInv = wrap $ lgWrapper $ untag $ lgDispatch dlinv - - mulGPow = wrap mulGPow' -- mulGPow' already has lgWrapper - mulGDec = wrap $ lgWrapper $ untag $ lgDispatch dmulgdec - - divGPow = wrapM $ divGPow' - -- we divide by p in the C code (for divGDec only(?)), do NOT call checkDiv! - divGDec = wrapM $ divGWrapper $ Just . (untag $ lgDispatch dginvdec) - - crtFuncs = (,,,,) <$> - Just (CT . repl) <*> - (liftM wrap $ crtWrapper $ (untag $ cZipDispatch dmul) <$> untagT gCoeffsCRT) <*> - (liftM wrap $ crtWrapper $ (untag $ cZipDispatch dmul) <$> untagT gInvCoeffsCRT) <*> - (liftM wrap $ untagT $ crt') <*> - (liftM wrap $ crtWrapper $ untagT ctCRTInv) - - twacePowDec = wrap $ runIdentity $ coerceTw twacePowDec' - embedPow = wrap $ runIdentity $ coerceEm embedPow' - embedDec = wrap $ runIdentity $ coerceEm embedDec' - - tGaussianDec v = liftM CT $ gaussWrapper $ cDispatchGaussian v - --tGaussianDec v = liftM CT $ coerceT' $ gaussianDec v - - crtExtFuncs = (,) <$> (liftM wrap $ coerceTw twaceCRT') - <*> (liftM wrap $ coerceEm embedCRT') - - coeffs = wrapM $ coerceCoeffs $ coeffs' - - powBasisPow = (CT <$>) <$> coerceBasis powBasisPow' - - crtSetDec = (CT <$>) <$> coerceBasis crtSetDec' - - fmapT f (CT v) = CT $ coerce (SV.map f) v - fmapT f v@(ZV _) = fmapT f $ toCT v - - fmapTM f (CT (CT' arr)) = liftM (CT . CT') $ SV.mapM f arr - fmapTM f v@(ZV _) = fmapTM f $ toCT v - -coerceTw :: (Functor mon) => (TaggedT '(m, m') mon (Vector r -> Vector r)) -> mon (CT' m' r -> CT' m r) -coerceTw = (coerce <$>) . untagT - -coerceEm :: (Functor mon) => (TaggedT '(m, m') mon (Vector r -> Vector r)) -> mon (CT' m r -> CT' m' r) -coerceEm = (coerce <$>) . untagT - --- | Useful coersion for defining @coeffs@ in the @Tensor@ --- interface. Using 'coerce' alone is insufficient for type inference. -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 :: - (Fact m, Fact m') - => Tagged '(m,m') ([Vector r]) -> Tagged m [CT' m' r] -coerceBasis = coerce - --- | Class to dispatch to the C backend for various element types. -class CRNS r where - - zipWrapper :: (Fact m, Additive r) => - (forall a . (TElt CT a, Dispatch a, Additive a) => CT' m a -> CT' m a -> CT' m a) - -> CT' m r -> CT' m r -> CT' m r - - crtWrapper :: (Fact m, CRTrans r, ZeroTestable r, IntegralDomain r) => - (forall a . (TElt CT a, CRTrans a, Dispatch a, ZeroTestable a, IntegralDomain a) => Maybe (CT' m a -> CT' m a)) - -> Maybe (CT' m r -> CT' m r) - - lgWrapper :: (Fact m, Additive r) => - (forall a . (TElt CT a, Dispatch a, Additive a) => CT' m a -> CT' m a) - -> CT' m r -> CT' m r - - divGWrapper :: (Fact m, IntegralDomain r, ZeroTestable r) => - (forall a . (TElt CT a, Dispatch a, IntegralDomain a, ZeroTestable a) => CT' m a -> Maybe (CT' m a)) - -> CT' m r -> Maybe (CT' m r) - - gaussWrapper :: (Fact m, MonadRandom rnd, Random r) => - (forall a . (TElt CT a, Dispatch a, OrdFloat a, MonadRandom rnd, Random a) => rnd (CT' m a)) - -> rnd (CT' m r) - -instance CRNS Double where - zipWrapper f = f - crtWrapper f = f - lgWrapper f = f - divGWrapper f = f - gaussWrapper f = f - -instance CRNS Int64 where - zipWrapper f = f - crtWrapper f = f - lgWrapper f = f - divGWrapper f = f - gaussWrapper = error "Cannot call gaussianDec for Int64" - -instance (TElt CT (Complex a), Dispatch (Complex a)) => CRNS (Complex a) where - zipWrapper f = f - crtWrapper f = f - lgWrapper f = f - divGWrapper f = f - gaussWrapper = error "Cannot call gaussianDec for Complex" - --- EAC: we need PolyKinds in paritcular for this instance -instance (TElt CT (ZqBasic q i), Dispatch (ZqBasic q i)) => CRNS (ZqBasic q i) where - zipWrapper f = f - crtWrapper f = f - lgWrapper f = f - divGWrapper f = f - gaussWrapper = error "Cannot call gaussianDec for ZqBasic" - -instance (Storable a, Storable b, - CRNS a, CRNS b, - CRTrans a, CRTrans b, - ZeroTestable a, ZeroTestable b, - IntegralDomain a, IntegralDomain b, - Random a, Random b) - => CRNS (a,b) where - zipWrapper f (CT' x :: CT' m (a,b)) (CT' y) = - let (a,b) = unzip x - (c,d) = unzip y - (CT' ac) = zipWrapper f (CT' a :: CT' m a) (CT' c) - (CT' bd) = zipWrapper f (CT' b :: CT' m b) (CT' d) - in CT' $ zip ac bd - - crtWrapper f = do - fa <- crtWrapper f - fb <- crtWrapper f - return $ \ (CT' x :: CT' m (a,b)) -> - let (a,b) = unzip x - (CT' a') = fa (CT' a :: CT' m a) - (CT' b') = fb (CT' b :: CT' m b) - in CT' $ zip a' b' - - lgWrapper f (CT' x :: CT' m (a,b)) = - let (a, b) = unzip x - (CT' a') = lgWrapper f (CT' a :: CT' m a) - (CT' b') = lgWrapper f (CT' b :: CT' m b) - in CT' $ zip a' b' - - divGWrapper f (CT' x :: CT' m (a,b)) = - let (a, b) = unzip x - in do -- in Maybe - (CT' a') <- divGWrapper f (CT' a :: CT' m a) - (CT' b') <- divGWrapper f (CT' b :: CT' m b) - return $ CT' $ zip a' b' - - gaussWrapper f = do - (CT' a) <- gaussWrapper f - (CT' b) <- gaussWrapper f - return $ CT' $ zip a b - -mulGPow' :: (TElt CT r, Fact m, Additive r) => CT' m r -> CT' m r -mulGPow' = lgWrapper $ untag $ lgDispatch dmulgpow - -divGPow' :: forall m r . (TElt CT r, Fact m, IntegralDomain r, ZeroTestable r) => CT' m r -> Maybe (CT' m r) -divGPow' = divGWrapper $ untag $ checkDiv $ lgDispatch dginvpow - -crt' :: forall m r . (TElt CT r, Fact m, CRTrans r, ZeroTestable r, IntegralDomain r) - => TaggedT m Maybe (CT' m r -> CT' m r) -crt' = tagT $ crtWrapper $ do - f <- proxyT ctCRT (Proxy::Proxy m) - return $ CT' . f . unCT - ---{-# INLINE lgDispatch #-} -lgDispatch :: forall m r . - (Storable r, Fact m, Additive r) - => (Ptr r -> Int64 -> Ptr CPP -> Int16 -> IO ()) - -> Tagged m (CT' m r -> CT' m r) -lgDispatch f = do - factors <- liftM marshalFactors ppsFact - totm <- liftM fromIntegral totientFact - let numFacts = fromIntegral $ SV.length factors - return $ coerce $ \yin -> unsafePerformIO $ do -- in IO - yout <- SV.thaw yin - SM.unsafeWith yout (\pout -> - SV.unsafeWith factors (\pfac -> - f pout totm pfac numFacts)) - unsafeFreeze yout - ---{-# INLINE ctCRT #-} -ctCRT :: forall m r . - (Storable r, CRTrans r, Dispatch r, - Fact m) - => TaggedT m Maybe (Vector r -> Vector r) -ctCRT = do -- in TaggedT m Maybe - ru' <- ru - factors <- pureT $ liftM marshalFactors ppsFact - totm <- pureT $ liftM fromIntegral totientFact - let numFacts = fromIntegral $ SV.length factors - return $ \yin -> unsafePerformIO $ do -- in IO - yout <- SV.thaw yin - SM.unsafeWith yout (\pout -> - SV.unsafeWith factors (\pfac -> - withPtrArray ru' (\ruptr -> - dcrt pout totm pfac numFacts ruptr))) - unsafeFreeze yout - --- CTensor CRT^(-1) functions take inverse rus ---{-# INLINE ctCRTInv #-} -ctCRTInv :: (Storable r, CRTrans r, Dispatch r, - Fact m) - => TaggedT m Maybe (CT' m r -> CT' m r) -ctCRTInv = do -- in Maybe - mhatInv <- liftM snd $ crtInfoFact - ruinv' <- ruInv - factors <- pureT $ liftM marshalFactors ppsFact - totm <- pureT $ liftM fromIntegral totientFact - let numFacts = fromIntegral $ SV.length factors - -- EAC: can't use coerce here? - return $ \(CT' yin) -> unsafePerformIO $ do - yout <- SV.thaw yin - SM.unsafeWith yout (\pout -> - SV.unsafeWith factors (\pfac -> - withPtrArray ruinv' (\ruptr -> - dcrtinv pout totm pfac numFacts ruptr mhatInv))) - CT' <$> unsafeFreeze yout - -checkDiv :: forall m r . - (IntegralDomain r, Storable 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' <- liftM fromIntegral oddRadicalFact - return $ \x -> - let (CT' y) = f' x - in CT' <$> (SV.mapM (`divIfDivis` oddRad')) y - -divIfDivis :: (IntegralDomain r, ZeroTestable r) => r -> r -> Maybe r -divIfDivis num den = let (q,r) = num `divMod` den - in if isZero r then Just q else Nothing - -cZipDispatch :: (Storable r, Fact m, Additive r) - => (Ptr r -> Ptr r -> Int64 -> IO ()) - -> Tagged m (CT' m r -> CT' m r -> CT' m r) -cZipDispatch f = do -- in Tagged m - totm <- liftM fromIntegral $ totientFact - return $ coerce $ \a b -> unsafePerformIO $ do - yout <- SV.thaw a - SM.unsafeWith yout (\pout -> - SV.unsafeWith b (\pin -> - f pout pin totm)) - unsafeFreeze yout - -cDispatchGaussian :: forall m r var rnd . - (Storable r, Transcendental r, Dispatch r, Ord r, - Fact m, ToRational var, Random r, MonadRandom rnd) - => var -> rnd (CT' m r) -cDispatchGaussian var = liftM CT' $ flip proxyT (Proxy::Proxy m) $ do -- in TaggedT m rnd - -- get rus for (Complex r) - ruinv' <- mapTaggedT (return . fromMaybe (error "complexGaussianRoots")) $ ruInv - factors <- liftM marshalFactors $ pureT ppsFact - totm <- pureT totientFact - m <- pureT valueFact - rad <- pureT radicalFact - yin <- lift $ realGaussians (var * fromIntegral (m `div` rad)) totm - let numFacts = fromIntegral $ SV.length factors - return $ unsafePerformIO $ do -- in IO - --let yin = create $ SM.new totm :: Vector r -- contents will be overwritten, so no need to initialize - yout <- SV.thaw yin - SM.unsafeWith yout (\pout -> - SV.unsafeWith factors (\pfac -> - withPtrArray ruinv' (\ruptr -> - dgaussdec pout (fromIntegral totm) pfac numFacts ruptr))) - unsafeFreeze yout - -instance (Arbitrary r, Fact m, Storable r) => Arbitrary (CT' m r) where - arbitrary = replM arbitrary - shrink = shrinkNothing - -instance (Storable r, Arbitrary (CT' m r)) => Arbitrary (CT m r) where - arbitrary = CT <$> arbitrary - -instance (Storable r, Random r, Fact m) => Random (CT' m r) where - --{-# INLINABLE random #-} - random = runRand $ replM (liftRand random) - - randomR = error "randomR nonsensical for CT'" - -instance (Storable r, Random (CT' m r)) => Random (CT m r) where - --{-# INLINABLE random #-} - random = runRand $ liftM CT (liftRand random) - - randomR = error "randomR nonsensical for CT" - -instance (NFData r) => NFData (CT m r) where - rnf (CT v) = rnf v - rnf (ZV v) = rnf v - -repl :: forall m r . (Fact m, Storable r) => r -> CT' m r -repl = let n = proxy totientFact (Proxy::Proxy m) - in coerce . SV.replicate n - -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 liftM coerce . SV.replicateM n - ---{-# INLINE scalarPow' #-} -scalarPow' :: forall t m r v . - (Fact m, Additive r, Storable r) - => r -> CT' m r --- constant-term coefficient is first entry wrt powerful basis -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 = do - mval <- pureT valueFact - wPow <- liftM fst $ crtInfoFact - liftM (LP.map - (\(p,e) -> do - let pp = p^e - pow = mval `div` pp - generate pp (wPow . (*pow)))) $ - pureT ppsFact - ---{-# INLINE ruInv #-} -ruInv = do - mval <- pureT valueFact - wPow <- liftM fst $ crtInfoFact - liftM (LP.map - (\(p,e) -> do - let pp = p^e - pow = mval `div` pp - 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 = crt' <*> (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) <$> crt' - --- 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) - embed <- proxyT embedCRT' (Proxy::Proxy '(m,m')) - indices <- pure $ proxy extIndicesCRT (Proxy::Proxy '(m,m')) - (_, m'hatinv) <- proxyT crtInfoFact (Proxy::Proxy m') - let phi = proxy totientFact (Proxy::Proxy m) - phi' = proxy totientFact (Proxy::Proxy m') - mhat = fromIntegral $ proxy valueHatFact (Proxy::Proxy m) - hatRatioInv = m'hatinv * mhat - reltot = phi' `div` phi - -- tweak = mhat * g' / (m'hat * g) - tweak = SV.map (* hatRatioInv) $ SV.zipWith (*) (embed gInv) g' - return $ \ arr -> -- take true trace after mul-by-tweak - let v = backpermute' indices (SV.zipWith (*) tweak arr) - in generate phi $ \i -> foldl1' (+) $ SV.unsafeSlice (i*reltot) reltot v - - - - - - - - - - - - --- C-backend support - -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 -withPtrArray :: (Storable a) => [Vector a] -> (Ptr (Ptr a) -> IO b) -> IO b -withPtrArray v f = do - let vs = LP.map SV.unsafeToForeignPtr0 v - ptrV = LP.map (\(fp,_) -> getPtr fp) vs - res <- withArray ptrV f - LP.mapM_ (\(fp,_) -> touchForeignPtr fp) vs - return res - -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 -instance Storable CPP where - sizeOf = Store.sizeOf store - alignment = Store.alignment store - peek = Store.peek store - poke = Store.poke store - -store :: Store.Dictionary CPP -store = Store.run $ - liftA2 CPP - (Store.element p') - (Store.element e') - -instance Show CPP where - show (CPP p e) = "(" LP.++ (show p) LP.++ "," LP.++ (show e) LP.++ ")" - -foreign import ccall unsafe "tensorLR" tensorLR :: Ptr Int64 -> Int64 -> Ptr CPP -> Int16 -> IO () -foreign import ccall unsafe "tensorLInvR" tensorLInvR :: Ptr Int64 -> Int64 -> Ptr CPP -> Int16 -> IO () -foreign import ccall unsafe "tensorLRq" tensorLRq :: Ptr (ZqBasic q Int64) -> Int64 -> Ptr CPP -> Int16 -> Int64 -> IO () -foreign import ccall unsafe "tensorLInvRq" tensorLInvRq :: Ptr (ZqBasic q Int64) -> Int64 -> Ptr CPP -> Int16 -> Int64 -> IO () -foreign import ccall unsafe "tensorLDouble" tensorLDouble :: Ptr Double -> Int64 -> Ptr CPP -> Int16 -> IO () -foreign import ccall unsafe "tensorLInvDouble" tensorLInvDouble :: Ptr Double -> Int64 -> Ptr CPP -> Int16 -> IO () -foreign import ccall unsafe "tensorLC" tensorLC :: Ptr (Complex Double) -> Int64 -> Ptr CPP -> Int16 -> IO () -foreign import ccall unsafe "tensorLInvC" tensorLInvC :: Ptr (Complex Double) -> Int64 -> Ptr CPP -> Int16 -> IO () - -foreign import ccall unsafe "tensorGPowR" tensorGPowR :: Ptr Int64 -> Int64 -> Ptr CPP -> Int16 -> IO () -foreign import ccall unsafe "tensorGPowRq" tensorGPowRq :: Ptr (ZqBasic q Int64) -> Int64 -> Ptr CPP -> Int16 -> Int64 -> IO () -foreign import ccall unsafe "tensorGDecR" tensorGDecR :: Ptr Int64 -> Int64 -> Ptr CPP -> Int16 -> IO () -foreign import ccall unsafe "tensorGDecRq" tensorGDecRq :: Ptr (ZqBasic q Int64) -> Int64 -> Ptr CPP -> Int16 -> Int64 -> IO () -foreign import ccall unsafe "tensorGInvPowR" tensorGInvPowR :: Ptr Int64 -> Int64 -> Ptr CPP -> Int16 -> IO () -foreign import ccall unsafe "tensorGInvPowRq" tensorGInvPowRq :: Ptr (ZqBasic q Int64) -> Int64 -> Ptr CPP -> Int16 -> Int64 -> IO () -foreign import ccall unsafe "tensorGInvDecR" tensorGInvDecR :: Ptr Int64 -> Int64 -> Ptr CPP -> Int16 -> IO () -foreign import ccall unsafe "tensorGInvDecRq" tensorGInvDecRq :: Ptr (ZqBasic q Int64) -> Int64 -> Ptr CPP -> Int16 -> Int64 -> IO () ---foreign import ccall unsafe "tensorGCRTRq" tensorGCRTRq :: Ptr (ZqBasic q Int64) -> Int64 -> Ptr CPP -> Int16 -> Ptr (Ptr (ZqBasic q Int64)) -> Int64 -> IO () ---foreign import ccall unsafe "tensorGCRTC" tensorGCRTC :: Ptr (Complex Double) -> Int64 -> Ptr CPP -> Int16 -> Ptr (Ptr (Complex Double)) -> IO () ---foreign import ccall unsafe "tensorGInvCRTRq" tensorGInvCRTRq :: Ptr (ZqBasic q Int64) -> Int64 -> Ptr CPP -> Int16 -> Ptr (Ptr (ZqBasic q Int64)) -> Int64 -> IO () ---foreign import ccall unsafe "tensorGInvCRTC" tensorGInvCRTC :: Ptr (Complex Double) -> Int64 -> Ptr CPP -> Int16 -> Ptr (Ptr (Complex Double)) -> IO () - -foreign import ccall unsafe "tensorCRTRq" tensorCRTRq :: Ptr (ZqBasic q Int64) -> Int64 -> Ptr CPP -> Int16 -> Ptr (Ptr (ZqBasic q Int64)) -> Int64 -> IO () -foreign import ccall unsafe "tensorCRTC" tensorCRTC :: Ptr (Complex Double) -> Int64 -> Ptr CPP -> Int16 -> Ptr (Ptr (Complex Double)) -> IO () -foreign import ccall unsafe "tensorCRTInvRq" tensorCRTInvRq :: Ptr (ZqBasic q Int64) -> Int64 -> Ptr CPP -> Int16 -> Ptr (Ptr (ZqBasic q Int64)) -> Int64 -> Int64 -> IO () -foreign import ccall unsafe "tensorCRTInvC" tensorCRTInvC :: Ptr (Complex Double) -> Int64 -> Ptr CPP -> Int16 -> Ptr (Ptr (Complex Double)) -> Double -> IO () - -foreign import ccall unsafe "tensorGaussianDec" tensorGaussianDec :: Ptr Double -> Int64 -> Ptr CPP -> Int16 -> Ptr (Ptr (Complex Double)) -> IO () - -foreign import ccall unsafe "mulRq" mulRq :: Ptr (ZqBasic q Int64) -> Ptr (ZqBasic q Int64) -> Int64 -> Int64 -> IO () -foreign import ccall unsafe "mulC" mulC :: Ptr (Complex Double) -> Ptr (Complex Double) -> Int64 -> IO () - -foreign import ccall unsafe "addRq" addRq :: Ptr (ZqBasic q Int64) -> Ptr (ZqBasic q Int64) -> Int64 -> Int64 -> IO () -foreign import ccall unsafe "addR" addR :: Ptr Int64 -> Ptr Int64 -> Int64 -> IO () -foreign import ccall unsafe "addC" addC :: Ptr (Complex Double) -> Ptr (Complex Double) -> Int64 -> IO () -foreign import ccall unsafe "addD" addD :: Ptr Double -> Ptr Double -> Int64 -> IO () - --- | Class to safely match Haskell types with the appropriate C function. -class Dispatch r where - dcrt :: Ptr r -> Int64 -> Ptr CPP -> Int16 -> Ptr (Ptr r) -> IO () - dcrtinv :: Ptr r -> Int64 -> Ptr CPP -> Int16 -> Ptr (Ptr r) -> r -> IO () - dl :: Ptr r -> Int64 -> Ptr CPP -> Int16 -> IO () - dlinv :: Ptr r -> Int64 -> Ptr CPP -> Int16 -> IO () - dmulgpow :: Ptr r -> Int64 -> Ptr CPP -> Int16 -> IO () - dmulgdec :: Ptr r -> Int64 -> Ptr CPP -> Int16 -> IO () - dginvpow :: Ptr r -> Int64 -> Ptr CPP -> Int16 -> IO () - dginvdec :: Ptr r -> Int64 -> Ptr CPP -> Int16 -> IO () - dadd :: Ptr r -> Ptr r -> Int64 -> IO () - dmul :: Ptr r -> Ptr r -> Int64 -> IO () - dgcrt :: Ptr r -> Int64 -> Ptr CPP -> Int16 -> Ptr (Ptr r) -> IO () - dginvcrt :: Ptr r -> Int64 -> Ptr CPP -> Int16 -> Ptr (Ptr r) -> IO () - dgaussdec :: Ptr r -> Int64 -> Ptr CPP -> Int16 -> Ptr (Ptr (Complex r)) -> IO () - -instance (Reflects q Int64) => Dispatch (ZqBasic q Int64) where - dcrt pout totm pfac numFacts ruptr = - let q = proxy value (Proxy::Proxy q) - in tensorCRTRq pout totm pfac numFacts ruptr q - dcrtinv pout totm pfac numFacts ruptr minv = - let q = proxy value (Proxy::Proxy q) - --EAC: GHC doesn't like it if I change the type of minv to ZqBasic in the - -- signature of tensorCRTInvRq, and the constructor of ZqBasic isn't exposed - -- so using unsafeCoerce for now - in tensorCRTInvRq pout totm pfac numFacts ruptr (unsafeCoerce minv) q - dl pout totm pfac numFacts = - let q = proxy value (Proxy::Proxy q) - in tensorLRq pout totm pfac numFacts q - dlinv pout totm pfac numFacts = - let q = proxy value (Proxy::Proxy q) - in tensorLInvRq pout totm pfac numFacts q - dmulgpow pout totm pfac numFacts = - let q = proxy value (Proxy::Proxy q) - in tensorGPowRq pout totm pfac numFacts q - dmulgdec pout totm pfac numFacts = - let q = proxy value (Proxy::Proxy q) - in tensorGDecRq pout totm pfac numFacts q - dginvpow pout totm pfac numFacts = - let q = proxy value (Proxy::Proxy q) - in tensorGInvPowRq pout totm pfac numFacts q - dginvdec pout totm pfac numFacts = - let q = proxy value (Proxy::Proxy q) - in tensorGInvDecRq pout totm pfac numFacts q - dadd aout bout totm = - let q = proxy value (Proxy::Proxy q) - in addRq aout bout totm q - dmul aout bout totm = - let q = proxy value (Proxy::Proxy q) - in mulRq aout bout totm q - dgcrt pout totm pfac numFacts gcoeffs' = error "dgcrt zq" - --let q = proxy value (Proxy::Proxy q) - --in tensorGCRTRq pout totm pfac numFacts gcoeffs' q - dginvcrt pout totm pfac numFacts gcoeffs' = error "dginvcrt zq" - --let q = proxy value (Proxy::Proxy q) - --in tensorGInvCRTRq pout totm pfac numFacts gcoeffs' q - dgaussdec = error "cannot call CT gaussianDec on type ZqBasic" - -instance Dispatch (Complex Double) where - dcrt = tensorCRTC - dcrtinv pout totm pfac numFacts ruptr minv = - tensorCRTInvC pout totm pfac numFacts ruptr (real minv) - dl = tensorLC - dlinv = tensorLInvC - dmulgpow = error "cannot call CT mulGPow on type Complex Double" - dmulgdec = error "cannot call CT mulGDec on type Complex Double" - dginvpow = error "cannot call CT divGPow on type Complex Double" - dginvdec = error "cannot call CT divGDec on type Complex Double" - dadd = addC - dmul = mulC - dgcrt = error "tensorGCRTC" - dginvcrt = error "tensorGInvCRTC" - dgaussdec = error "cannot call CT gaussianDec on type Comple Double" - -instance Dispatch Double where - dcrt = error "cannot call CT Crt on type Double" - dcrtinv = error "cannot call CT CrtInv on type Double" - dl = tensorLDouble - dlinv = tensorLInvDouble - 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 = addD - dmul = error "cannot call CT (*) on type Double" - dgcrt = error "cannot call CT mulGCRT on type Double" - dginvcrt = error "cannot call CT divGCRT on type Double" - dgaussdec = tensorGaussianDec - -instance Dispatch Int64 where - dcrt = error "cannot call CT Crt on type Int64" - dcrtinv = error "cannot call CT CrtInv on type Int64" - dl = tensorLR - dlinv = tensorLInvR - dmulgpow = tensorGPowR - dmulgdec = tensorGDecR - dginvpow = tensorGInvPowR - dginvdec = tensorGInvDecR - dadd = addR - dmul = error "cannot call CT (*) on type Int64" - dgcrt = error "cannot call CT mulGCRT on type Int64" - dginvcrt = error "cannot call CT divGCRT on type Int64" - dgaussdec = error "cannot call CT gaussianDec on type Int64" diff --git a/src/Crypto/Lol/Cyclotomic/Tensor/CTensor/Extension.hs b/src/Crypto/Lol/Cyclotomic/Tensor/CTensor/Extension.hs deleted file mode 100644 --- a/src/Crypto/Lol/Cyclotomic/Tensor/CTensor/Extension.hs +++ /dev/null @@ -1,122 +0,0 @@ -{-# LANGUAGE ConstraintKinds, FlexibleContexts, MultiParamTypeClasses, - NoImplicitPrelude, RebindableSyntax, ScopedTypeVariables, - TypeFamilies, TypeOperators, DataKinds #-} - --- | CT-specific functions for embedding/twacing in various bases - -module Crypto.Lol.Cyclotomic.Tensor.CTensor.Extension -( embedPow', embedDec', embedCRT' -, twacePowDec' -- , twaceCRT' -, coeffs', powBasisPow' -, crtSetDec' -, backpermute' -) where - -import Crypto.Lol.CRTrans -import Crypto.Lol.LatticePrelude as LP hiding (null, lift) -import Crypto.Lol.Cyclotomic.Tensor as T -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 qualified Data.Vector.Storable as SV - - --- | /O(n)/ Yield the vector obtained by replacing each element @i@ of the --- index vector by @xs'!'i@. This is equivalent to @'map' (xs'!') is@ but is --- often much more efficient. --- --- > backpermute <0,3,2,3,1,0> = -backpermute' :: (Vector v a) - => U.Vector Int -- ^ @is@ index vector (of length @n@) - -> v a -- ^ @xs@ value vector - -> v a ---{-# INLINE backpermute' #-} -backpermute' is v = generate (G.length is) (\i -> v ! (is ! i)) - -embedPow', embedDec' :: (Additive r, Vector v r, m `Divides` m') - => 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 -> - let (j0,j1) = indices ! idx - in if j0 == 0 - then arr ! j1 - else zero) <$> baseIndicesPow --- | Embeds an vector in the decoding basis of the the mth cyclotomic ring --- to an vector in the decoding basis of the m'th cyclotomic ring when @m | m'@ -embedDec' = (\indices arr -> generate (U.length indices) - (\idx -> maybe LP.zero - (\(sh,b) -> if b then negate (arr ! sh) else arr ! sh) - (indices U.! idx))) <$> baseIndicesDec - --- | 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))) >> - (pureT $ backpermute' <$> baseIndicesCRT) - --- | maps a vector in the powerful/decoding basis, representing an --- O_m' element, to a vector of arrays representing O_m elements in --- the same type of basis -coeffs' :: (Vector v r, m `Divides` m') - => Tagged '(m, m') (v r -> [v r]) -coeffs' = flip (\x -> V.toList . V.map (`backpermute'` x)) - <$> extIndicesCoeffs - --- | The "tweaked trace" function in either the powerful or decoding --- 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) -twacePowDec' = backpermute' <$> extIndicesPowDec - - --- EAC: twaceCRT is defined in CTensor because it needs access to C-backend functions - - --- | The powerful extension basis, wrt the powerful basis. --- Outputs a list of vectors in O_m' that are an O_m basis for O_m' -powBasisPow' :: forall m m' r . (m `Divides` m', Ring r, SV.Storable r) - => Tagged '(m, m') [SV.Vector r] -powBasisPow' = do - (_, phi, phi', _) <- indexInfo - idxs <- baseIndicesPow - 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] - --- | A list of vectors representing the mod-p CRT set of the --- extension O_m'/O_m -crtSetDec' :: forall m m' fp . - (m `Divides` m', PrimeField fp, Coprime (PToF (CharOf fp)) m', - SV.Storable fp) - => Tagged '(m, m') [SV.Vector fp] -crtSetDec' = - let m'p = Proxy :: Proxy m' - p = proxy value (Proxy::Proxy (CharOf fp)) - phi = proxy totientFact m'p - d = proxy (order p) m'p - h :: Int = proxy valueHatFact m'p - hinv = recip $ fromIntegral h - in reify d $ \(_::Proxy d) -> do - let twCRTs' :: Matrix (GF fp d) - = fromMaybe (error "internal error: crtSetDec': twCRTs") $ proxyT twCRTs m'p - zmsToIdx = proxy T.zmsToIndexFact m'p - elt j i = indexM twCRTs' j (zmsToIdx i) - trace' = trace :: GF fp d -> fp -- to avoid recomputing powTraces - cosets <- partitionCosets p - return $ LP.map (\is -> generate phi - (\j -> hinv * trace' - (sum $ LP.map (elt j) is))) cosets diff --git a/src/Crypto/Lol/Cyclotomic/Tensor/CTensor/basic.c b/src/Crypto/Lol/Cyclotomic/Tensor/CTensor/basic.c deleted file mode 100644 --- a/src/Crypto/Lol/Cyclotomic/Tensor/CTensor/basic.c +++ /dev/null @@ -1,162 +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 (hInt_t* a, hInt_t* b, hDim_t totm, hInt_t q) { -#ifdef STATS - mulCtr++; - struct timespec s1,t1; - clock_gettime(CLOCK_REALTIME, &s1); -#endif - for(int i = 0; i < totm; i++) { - a[i] = (a[i]*b[i])%q; - } -#ifdef STATS - clock_gettime(CLOCK_REALTIME, &t1); - mulTime = tsAdd(mulTime, tsSubtract(t1,s1)); -#endif -} - -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) { -#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 (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; 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 (hInt_t* a, const hInt_t* b, const hDim_t totm, const hInt_t q) { -#ifdef STATS - addCtr++; - struct timespec s1,t1; - clock_gettime(CLOCK_REALTIME, &s1); -#endif -#ifdef CINTRIN - __m128i qs = _mm_set1_epi64x(q); - for(int i = 0; i < totm; i+=2) { - __m128i xs = _mm_load_si128((const __m128i*)(a+i)); - __m128i ys = _mm_load_si128((const __m128i*)(b+i)); - __m128i zs = _mm_add_epi64(xs,ys); - zs = _mm_rem_epi64(zs,qs); - _mm_store_si128((__m128i*)(a+i),zs); - } -#else - for(int i = 0; i < totm; i++) { - hInt_t temp = a[i]+b[i]; - if (temp >= q) a[i]=temp-q; - else a[i] = 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 (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; i++) { - a[i] += b[i]; - } -#ifdef STATS - clock_gettime(CLOCK_REALTIME, &t1); - addTime = tsAdd(addTime, tsSubtract(t1,s1)); -#endif -} - -void addC (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; i++) - { - CMPLX_IADD(a[i],b[i]); - } -#ifdef STATS - clock_gettime(CLOCK_REALTIME, &t1); - addTime = tsAdd(addTime, tsSubtract(t1,s1)); -#endif -} - -void addD (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; i++) - { - a[i]+=b[i]; - } -#ifdef STATS - clock_gettime(CLOCK_REALTIME, &t1); - addTime = tsAdd(addTime, tsSubtract(t1,s1)); -#endif -} - diff --git a/src/Crypto/Lol/Cyclotomic/Tensor/CTensor/crt.c b/src/Crypto/Lol/Cyclotomic/Tensor/CTensor/crt.c deleted file mode 100644 --- a/src/Crypto/Lol/Cyclotomic/Tensor/CTensor/crt.c +++ /dev/null @@ -1,1305 +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, 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)]; - - 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; - 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)]; - - 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; - y[idx] = (y[idx]*twid) % q; - } - } - } - } - } -} - -// dim is power of p -void dftptwidRq (hInt_t* y, 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]; - - 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; - 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]; - - 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; - 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, 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]; - hInt_t t = y[tensorOffset+rts]; - y[tensorOffset] = (u + t) % q; - y[tensorOffset+rts] = (u - t) % q; - } - } - } - else if(p == 3) - { - hInt_t ru1 = ru[rustride]; - hInt_t ru2 = ru[rustride<<1]; - 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]; - y2 = y[tensorOffset+rts]; - y3 = y[tensorOffset+(rts<<1)]; - //q is <32 bits, so we can do 3 additions without overflow - y[tensorOffset] = (y1 + y2 + y3) % q; - y[tensorOffset+rts] = (y1 + ((ru1*y2) % q) + ((ru2*y3) % q)) % q; - y[tensorOffset+(rts<<1)] = (y1 + ((ru2*y2) % q) + ((ru1*y3) % q)) % q; - } - } - - } - else if(p == 5) - { - hDim_t temp1 = rts*5; - hInt_t ru1 = ru[rustride]; - hInt_t ru2 = ru[rustride<<1]; - hInt_t ru3 = ru[rustride*3]; - hInt_t ru4 = ru[rustride<<2]; - - 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]; - y2 = y[tensorOffset+rts]; - y3 = y[tensorOffset+(rts<<1)]; - y4 = y[tensorOffset+3*rts]; - y5 = y[tensorOffset+(rts<<2)]; - y[tensorOffset] = (y1 + y2 + y3 + y4 + y5) % q; - y[tensorOffset+rts] = (y1 + ((ru1*y2) % q) + ((ru2*y3) % q) + ((ru3*y4) % q) + ((ru4*y5) % q)) % q; - y[tensorOffset+(rts<<1)] = (y1 + ((ru2*y2) % q) + ((ru4*y3) % q) + ((ru1*y4) % q) + ((ru3*y5) % q)) % q; - y[tensorOffset+rts*3] = (y1 + ((ru3*y2) % q) + ((ru1*y3) % q) + ((ru4*y4) % q) + ((ru2*y5) % q)) % q; - y[tensorOffset+(rts<<2)] = (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]; - hInt_t ru2 = ru[rustride<<1]; - hInt_t ru3 = ru[rustride*3]; - hInt_t ru4 = ru[rustride<<2]; - hInt_t ru5 = ru[rustride*5]; - hInt_t ru6 = ru[rustride*6]; - - 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]; - y2 = y[tensorOffset+rts]; - y3 = y[tensorOffset+(rts<<1)]; - y4 = y[tensorOffset+3*rts]; - y5 = y[tensorOffset+(rts<<2)]; - y6 = y[tensorOffset+rts*5]; - y7 = y[tensorOffset+rts*6]; - y[tensorOffset] = (y1 + y2 + y3 + y4 + y5 + y6 + y7) % q; - y[tensorOffset+rts] = (y1 + ((ru1*y2) % q) + ((ru2*y3) % q) + ((ru3*y4) % q) + ((ru4*y5) % q) + ((ru5*y6) % q) + ((ru6*y7) % q)) % q; - y[tensorOffset+(rts<<1)] = (y1 + ((ru2*y2) % q) + ((ru4*y3) % q) + ((ru6*y4) % q) + ((ru1*y5) % q) + ((ru3*y6) % q) + ((ru5*y7) % q)) % q; - y[tensorOffset+rts*3] = (y1 + ((ru3*y2) % q) + ((ru6*y3) % q) + ((ru2*y4) % q) + ((ru5*y5) % q) + ((ru1*y6) % q) + ((ru4*y7) % q)) % q; - y[tensorOffset+(rts<<2)] = (y1 + ((ru4*y2) % q) + ((ru1*y3) % q) + ((ru5*y4) % q) + ((ru2*y5) % q) + ((ru6*y6) % q) + ((ru3*y7) % q)) % q; - y[tensorOffset+rts*5] = (y1 + ((ru5*y2) % q) + ((ru3*y3) % q) + ((ru1*y4) % q) + ((ru6*y5) % q) + ((ru4*y6) % q) + ((ru2*y7) % q)) % q; - y[tensorOffset+rts*6] = (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]*ru[((col*row) % p)*rustride])%q); - } - tempSpace[row] = acc % q; - } - - for(hDim_t row = 0; row < p; row++) - { - y[tensorOffset+rts*row] = tempSpace[row]; - } - } - } - } -} - -void crtpRq (hInt_t* y, 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]; - hInt_t ru2 = ru[rustride<<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 y1, y2; - y1 = y[tensorOffset]; - y2 = y[tensorOffset+rts]; - y[tensorOffset] = (y1 + ((ru1*y2)%q)) % q; - y[tensorOffset+rts] = (y1 + ((ru2*y2)%q)) % q; - } - } - } - else if(p == 5) - { - hDim_t temp1 = rts*4; - hInt_t ru1 = ru[rustride]; - hInt_t ru2 = ru[rustride<<1]; - hInt_t ru3 = ru[rustride*3]; - hInt_t ru4 = ru[rustride<<2]; - - 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]; - y2 = y[tensorOffset+rts]; - y3 = y[tensorOffset+(rts<<1)]; - y4 = y[tensorOffset+3*rts]; - - y[tensorOffset] = (y1 + ((ru1*y2) % q) + ((ru2*y3) % q) + ((ru3*y4) % q)) % q; - y[tensorOffset+rts] = (y1 + ((ru2*y2) % q) + ((ru4*y3) % q) + ((ru1*y4) % q)) % q; - y[tensorOffset+(rts<<1)] = (y1 + ((ru3*y2) % q) + ((ru1*y3) % q) + ((ru4*y4) % q)) % q; - y[tensorOffset+rts*3] = (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]; - hInt_t ru2 = ru[rustride<<1]; - hInt_t ru3 = ru[rustride*3]; - hInt_t ru4 = ru[rustride<<2]; - hInt_t ru5 = ru[rustride*5]; - hInt_t ru6 = ru[rustride*6]; - - 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]; - y2 = y[tensorOffset+rts]; - y3 = y[tensorOffset+(rts<<1)]; - y4 = y[tensorOffset+3*rts]; - y5 = y[tensorOffset+(rts<<2)]; - y6 = y[tensorOffset+rts*5]; - y[tensorOffset] = (y1 + ((ru1*y2) % q) + ((ru2*y3) % q) + ((ru3*y4) % q) + ((ru4*y5) % q) + ((ru5*y6) % q)) % q; - y[tensorOffset+rts] = (y1 + ((ru2*y2) % q) + ((ru4*y3) % q) + ((ru6*y4) % q) + ((ru1*y5) % q) + ((ru3*y6) % q)) % q; - y[tensorOffset+(rts<<1)] = (y1 + ((ru3*y2) % q) + ((ru6*y3) % q) + ((ru2*y4) % q) + ((ru5*y5) % q) + ((ru1*y6) % q)) % q; - y[tensorOffset+rts*3] = (y1 + ((ru4*y2) % q) + ((ru1*y3) % q) + ((ru5*y4) % q) + ((ru2*y5) % q) + ((ru6*y6) % q)) % q; - y[tensorOffset+(rts<<2)] = (y1 + ((ru5*y2) % q) + ((ru3*y3) % q) + ((ru1*y4) % q) + ((ru6*y5) % q) + ((ru4*y6) % q)) % q; - y[tensorOffset+rts*5] = (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]*ru[((col*row) % p)*rustride]) % q); - } - tempSpace[row-1] = acc % q; - } - - for(hDim_t row = 0; row < p-1; row++) - { - y[tensorOffset+rts*row] = tempSpace[row]; - } - } - } - free(tempSpace); - } -} - -//takes inverse rus -void crtpinvRq (hInt_t* y, 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] * ruinv[ruIdx*rustride]) % 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] * ruinv[rustride*(p-(i+1))]) % q); - } - - for(i = 0; i < p-1; i++) - { - y[tensorOffset+i*rts] = (tempSpace[i] - shift) % q; - } - } - } - } -} - -void ppDFTRq (hInt_t* y, hDim_t lts, hDim_t rts, PrimeExponent pe, hDim_t rustride, hInt_t* ru, hInt_t q) -{ - hDim_t p = pe.prime; - hShort_t e = pe.exponent; - - if(e == 0) - { - return; - } - - hDim_t primeRuStride = rustride*ipow(p,e-1); - hInt_t* temp = 0; - if(p >= DFTP_GENERIC_SIZE) - { - temp = (hInt_t*)malloc(p*sizeof(hInt_t)); - } - 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, lts*ltsScale, rtsDim, p, primeRuStride, ru, temp, q); - dftptwidRq (y, lts, rtsDim, pe, ltsScale*p, twidRuStride, ru, q); - - ltsScale /= p; - rtsScale *= p; - twidRuStride *= p; - pe.exponent -= 1; - } - - if(p >= DFTP_GENERIC_SIZE) - { - free(temp); - } -} - -void ppDFTInvRq (hInt_t* y, hDim_t lts, hDim_t rts, PrimeExponent pe, hDim_t rustride, hInt_t* ru, hInt_t q) -{ - hDim_t p = pe.prime; - hShort_t e = pe.exponent; - - if(e == 0) - { - return; - } - hDim_t primeRuStride = rustride*ipow(p,e-1); - hInt_t* temp = 0; - if(p >= DFTP_GENERIC_SIZE) - { - temp = (hInt_t*)malloc(p*sizeof(hInt_t)); - } - 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, lts, rtsDim, pe, ltsScaleP, twidRuStride, ru, q); - dftpRq (y, lts*ltsScale, rtsDim, p, primeRuStride, ru, temp, q); - - ltsScale = ltsScaleP; - rtsScale /= p; - twidRuStride /= p; - pe.exponent += 1; - } - - if(p >= DFTP_GENERIC_SIZE) - { - free(temp); - } -} - -void ppcrtRq (void* y, hDim_t lts, hDim_t rts, PrimeExponent pe, void* ru, hInt_t q) -{ - 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]); - } - printf("]\n"); -#endif - - crtpRq ((hInt_t*)y, lts*mprime, rts, p, mprime, (hInt_t*)ru, q); - crtTwiddleRq ((hInt_t*)y, lts, rts, pe, (hInt_t*)ru, q); - pe.exponent -= 1; - ppDFTRq ((hInt_t*)y, lts, rts*(p-1), pe, p, (hInt_t*)ru, q); -} - -void ppcrtinvRq (void* y, hDim_t lts, hDim_t rts, PrimeExponent pe, void* ru, hInt_t q) -{ - 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]); - } - printf("]\n"); -#endif - pe.exponent -= 1; - ppDFTInvRq ((hInt_t*)y, lts, rts*(p-1), pe, p, (hInt_t*)ru, q); - pe.exponent += 1; - crtTwiddleRq ((hInt_t*)y, lts, rts, pe, (hInt_t*)ru, q); - crtpinvRq ((hInt_t*)y, lts*mprime, rts, p, mprime, (hInt_t*)ru, q); -} - -// EAC: Somebody who knows C/C++ should find a better way to handle pointers-to-pointers in a generic way -void tensorCRTRq (hInt_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, hInt_t** ru, hInt_t q) -{ - - 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 "\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 - void** rus = (void**)malloc(sizeOfPE*sizeof(void*)); - - for(i = 0; i < sizeOfPE; i++) - { - rus[i] = (void*) (ru[i]); - } - tensorFuserCRT (y, ppcrtRq, totm, peArr, sizeOfPE, rus, q); - - for(hDim_t j = 0; j < totm; j++) - { - if(y[j]<0) - { - y[j]+=q; - } -#ifdef DEBUG_MODE - if(y[j]<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 (hInt_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, hInt_t** ruinv, hInt_t mhatInv, hInt_t q) -{ - 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 "\tminv=%" PRId64 "\tq=%" PRId64 "\n[", totm, sizeOfPE, mhatInv, 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 - - void** rus = (void**)malloc(sizeOfPE*sizeof(void*)); - for(i = 0; i < sizeOfPE; i++) - { - rus[i] = (void*) (ruinv[i]); - } - - tensorFuserCRT (y, ppcrtinvRq, totm, peArr, sizeOfPE, rus, q); - - for (hDim_t j = 0; j < totm; j++) - { - y[j] = (y[j]*mhatInv)%q; - if(y[j] < 0) - { - y[j] +=q; - } -#ifdef DEBUG_MODE - if(y[j]<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, 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)]; - - 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],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)]; - - 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],twid); - } - } - } - } - } -} - -// dim is power of p -void dftptwidC (complex_t* y, 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]; - - 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],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]; - - 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],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, 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]; - complex_t t = y[tensorOffset+rts]; - y[tensorOffset] = CMPLX_ADD(u,t); - y[tensorOffset+rts] = CMPLX_SUB(u,t); - } - } - } - else if(p == 3) - { - hDim_t temp1 = rts*3; - complex_t ru1 = ru[rustride]; - complex_t ru2 = ru[rustride<<1]; - - 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]; - y2 = y[tensorOffset+rts]; - y3 = y[tensorOffset+(rts<<1)]; - y[tensorOffset] = CMPLX_ADD3(y1, y2, y3); - y[tensorOffset+rts] = CMPLX_ADD3(y1, CMPLX_MUL(ru1,y2), CMPLX_MUL(ru2,y3)); - y[tensorOffset+(rts<<1)] = 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]; - complex_t ru2 = ru[rustride<<1]; - complex_t ru3 = ru[rustride*3]; - complex_t ru4 = ru[rustride<<2]; - - 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]; - y2 = y[tensorOffset+rts]; - y3 = y[tensorOffset+(rts<<1)]; - y4 = y[tensorOffset+3*rts]; - y5 = y[tensorOffset+(rts<<2)]; - y[tensorOffset] = CMPLX_ADD5(y1, y2, y3, y4, y5); - y[tensorOffset+rts] = CMPLX_ADD5(y1, CMPLX_MUL(ru1,y2), CMPLX_MUL(ru2,y3), CMPLX_MUL(ru3,y4), CMPLX_MUL(ru4,y5)); - y[tensorOffset+(rts<<1)] = CMPLX_ADD5(y1, CMPLX_MUL(ru2,y2), CMPLX_MUL(ru4,y3), CMPLX_MUL(ru1,y4), CMPLX_MUL(ru3,y5)); - y[tensorOffset+rts*3] = CMPLX_ADD5(y1, CMPLX_MUL(ru3,y2), CMPLX_MUL(ru1,y3), CMPLX_MUL(ru4,y4), CMPLX_MUL(ru2,y5)); - y[tensorOffset+(rts<<2)] = 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]; - complex_t ru2 = ru[rustride<<1]; - complex_t ru3 = ru[rustride*3]; - complex_t ru4 = ru[rustride<<2]; - complex_t ru5 = ru[rustride*5]; - complex_t ru6 = ru[rustride*6]; - - 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]; - y2 = y[tensorOffset+rts]; - y3 = y[tensorOffset+(rts<<1)]; - y4 = y[tensorOffset+3*rts]; - y5 = y[tensorOffset+(rts<<2)]; - y6 = y[tensorOffset+rts*5]; - y7 = y[tensorOffset+rts*6]; - y[tensorOffset] = CMPLX_ADD7(y1, y2, y3, y4, y5, y6, y7); - y[tensorOffset+rts] = 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)] = 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] = 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)] = 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] = 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] = 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], ru[((col*row) % p)*rustride])); - } - tempSpace[row] = acc; - } - - for(row = 0; row < p; row++) - { - y[tensorOffset+rts*row] = tempSpace[row]; - } - } - } - } -} - -void crtpC (complex_t* y, 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]; - complex_t ru2 = ru[rustride<<1]; - - 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]; - y2 = y[tensorOffset+rts]; - y[tensorOffset] = CMPLX_ADD(y1, CMPLX_MUL(ru1,y2)); - y[tensorOffset+rts] = CMPLX_ADD(y1, CMPLX_MUL(ru2,y2)); - } - } - } - else if(p == 5) - { - hDim_t temp1 = rts*4; - complex_t ru1 = ru[rustride]; - complex_t ru2 = ru[rustride<<1]; - complex_t ru3 = ru[rustride*3]; - complex_t ru4 = ru[rustride<<2]; - - 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]; - y2 = y[tensorOffset+rts]; - y3 = y[tensorOffset+(rts<<1)]; - y4 = y[tensorOffset+3*rts]; - y[tensorOffset] = CMPLX_ADD4(y1, CMPLX_MUL(ru1,y2), CMPLX_MUL(ru2,y3), CMPLX_MUL(ru3,y4)); - y[tensorOffset+rts] = CMPLX_ADD4(y1, CMPLX_MUL(ru2,y2), CMPLX_MUL(ru4,y3), CMPLX_MUL(ru1,y4)); - y[tensorOffset+(rts<<1)] = CMPLX_ADD4(y1, CMPLX_MUL(ru3,y2), CMPLX_MUL(ru1,y3), CMPLX_MUL(ru4,y4)); - y[tensorOffset+rts*3] = 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]; - complex_t ru2 = ru[rustride<<1]; - complex_t ru3 = ru[rustride*3]; - complex_t ru4 = ru[rustride<<2]; - complex_t ru5 = ru[rustride*5]; - complex_t ru6 = ru[rustride*6]; - - 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]; - y2 = y[tensorOffset+rts]; - y3 = y[tensorOffset+(rts<<1)]; - y4 = y[tensorOffset+3*rts]; - y5 = y[tensorOffset+(rts<<2)]; - y6 = y[tensorOffset+rts*5]; - y[tensorOffset] = 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] = 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)] = 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] = 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)] = 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] = 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], ru[((col*row) % p)*rustride])); - } - tempSpace[row-1] = acc; - } - - for(row = 0; row < p-1; row++) - { - y[tensorOffset+rts*row] = tempSpace[row]; - } - } - } - free(tempSpace); - } -} - -//takes inverse rus -void crtpinvC (complex_t* y, 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],ruinv[ruIdx])); - } - 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], ruinv[rustride*ruIdx])); - } - - for(i = 0; i < p-1; i++) - { - y[tensorOffset+i*rts] = CMPLX_SUB(tempSpace[i], shift); - } - } - } - } -} - -void ppDFTC (complex_t* y, hDim_t lts, hDim_t rts, PrimeExponent pe, hDim_t rustride, complex_t* ru) -{ - hDim_t p = pe.prime; - hShort_t e = pe.exponent; - - if(e == 0) - { - return; - } - - hDim_t primeRuStride = rustride*ipow(p,e-1); - complex_t* temp = 0; - if(p >= DFTP_GENERIC_SIZE) - { - temp = (complex_t*)malloc(p*sizeof(complex_t)); - } - 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, lts*ltsScale, rtsDim, p, primeRuStride, ru, temp); - dftptwidC (y, lts, rtsDim, pe, ltsScale*p, twidRuStride, ru); - - ltsScale /= p; - rtsScale *= p; - twidRuStride *= p; - pe.exponent -= 1; - } - - if(p >= DFTP_GENERIC_SIZE) - { - free(temp); - } -} - -void ppDFTInvC (complex_t* y, hDim_t lts, hDim_t rts, PrimeExponent pe, hDim_t rustride, complex_t* ru) -{ - - hDim_t p = pe.prime; - hShort_t e = pe.exponent; - - if(e == 0) - { - return; - } - hDim_t primeRuStride = rustride*ipow(p,e-1); - complex_t* temp = 0; - if(p >= DFTP_GENERIC_SIZE) - { - temp = (complex_t*)malloc(p*sizeof(complex_t)); - } - 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, lts, rtsDim, pe, ltsScaleP, twidRuStride, ru); - dftpC (y, lts*ltsScale, rtsDim, p, primeRuStride, ru, temp); - - ltsScale = ltsScaleP; - rtsScale /= p; - twidRuStride /= p; - pe.exponent += 1; - } - - if(p >= DFTP_GENERIC_SIZE) - { - free(temp); - } -} - -void ppcrtC (void* y, hDim_t lts, hDim_t rts, PrimeExponent pe, void* ru, hInt_t q) -{ - 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 - - crtpC ((complex_t*)y, lts*mprime, rts, p, mprime, (complex_t*)ru); - crtTwiddleC ((complex_t*)y, lts, rts, pe, (complex_t*)ru); - pe.exponent -= 1; - ppDFTC ((complex_t*)y, lts, rts*(p-1), pe, p, (complex_t*)ru); -} - -void ppcrtinvC (void* y, hDim_t lts, hDim_t rts, PrimeExponent pe, void* ru, hInt_t q) -{ - hDim_t p = pe.prime; - hDim_t e = pe.exponent; -#ifdef DEBUG_MODE - ASSERT(e != 0); -#endif - hDim_t mprime = ipow(p,e-1); - - pe.exponent -= 1; - ppDFTInvC ((complex_t*)y, lts, rts*(p-1), pe, p, (complex_t*)ru); - pe.exponent += 1; - crtTwiddleC ((complex_t*)y, lts, rts, pe, (complex_t*)ru); - crtpinvC ((complex_t*)y, lts*mprime, rts, p, mprime, (complex_t*)ru); -} - -void tensorCRTC (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, ppcrtC, totm, peArr, sizeOfPE, rus, 0); - free(rus); -#ifdef STATS - clock_gettime(CLOCK_REALTIME, &t1); - crtCTime = tsAdd(crtCTime, tsSubtract(t1,s1)); -#endif -} - -//takes inverse rus -void tensorCRTInvC (complex_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, complex_t** ruinv, double 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, ppcrtinvC, totm, peArr, sizeOfPE, rus, 0); - complex_t minvcmplx = ((complex_t){mhatInv,0}); - - for (hDim_t j = 0; j < totm; j++) - { - CMPLX_IMUL(y[j], minvcmplx); - } - - free(rus); -#ifdef STATS - clock_gettime(CLOCK_REALTIME, &t1); - crtInvCTime = tsAdd(crtInvCTime, tsSubtract(t1,s1)); -#endif -} diff --git a/src/Crypto/Lol/Cyclotomic/Tensor/CTensor/g.c b/src/Crypto/Lol/Cyclotomic/Tensor/CTensor/g.c deleted file mode 100644 --- a/src/Crypto/Lol/Cyclotomic/Tensor/CTensor/g.c +++ /dev/null @@ -1,685 +0,0 @@ -#include "tensorTypes.h" - - -void gPowR (hInt_t* y, 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]; - for (i = p-2; i != 0; --i) - { - hDim_t idx = tensorOffset + i * rts; - y[idx] += last - y[idx-rts]; - } - y[tensorOffset] += last; - } - } -} - -void gPowRq (hInt_t* y, 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]; - for (i = p-2; i != 0; --i) - { - hDim_t idx = tensorOffset + i * rts; - y[idx] = (y[idx] + last - y[idx-rts]) % q; - } - y[tensorOffset] = (y[tensorOffset] + last) % q; - } - } -} - - -void ppGPowR (void* y, PrimeExponent pe, hDim_t lts, hDim_t rts, hInt_t q) -{ -#ifdef DEBUG_MODE - ASSERT (q==0); -#endif - hDim_t p = pe.prime; - hShort_t e = pe.exponent; - - if (p != 2) - { - gPowR ((hInt_t*)y, lts*ipow(p,e-1), rts, p); - } -} - - -void ppGPowRq (void* y, PrimeExponent pe, hDim_t lts, hDim_t rts, hInt_t q) -{ - hDim_t p = pe.prime; - hShort_t e = pe.exponent; - if (p != 2) - { - gPowRq ((hInt_t*)y, lts*ipow(p,e-1), rts, p, q); - } -} - - - -void gDecR (hInt_t* y, 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]; - for (i = p-2; i != 0; --i) - { - hDim_t idx = tensorOffset + i * rts; - acc += y[idx]; - y[idx] -= y[idx-rts]; - } - y[tensorOffset] += acc; - } - } -} - -void gDecRq (hInt_t* y, 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]; - 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]; - y[idx] = (y[idx] - y[idx-rts]) % q; - } - y[tensorOffset] = (y[tensorOffset] + acc) % q; - } - } -} - -void ppGDecR (void* y, PrimeExponent pe, hDim_t lts, hDim_t rts, hInt_t q) -{ -#ifdef DEBUG_MODE - ASSERT (q==0); -#endif - hDim_t p = pe.prime; - hShort_t e = pe.exponent; - if (p != 2) - { - gDecR ((hInt_t*)y, lts*ipow(p,e-1), rts, p); - } -} - -void ppGDecRq (void* y, PrimeExponent pe, hDim_t lts, hDim_t rts, hInt_t q) -{ - hDim_t p = pe.prime; - hShort_t e = pe.exponent; - if (p != 2) - { - gDecRq ((hInt_t*)y, lts*ipow(p,e-1), rts, p, q); - } -} - - -void gInvPowR (hInt_t* y, 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]; - } - hInt_t relts = 0; - for (i = p-2; i >= 0; --i) - { - hDim_t idx = tensorOffset + i*rts; - hInt_t z = y[idx]; - y[idx] = (p-1-i) * lelts - (i+1)*relts; - lelts -= z; - relts += z; - } - } - } -} - -void gInvPowRq (hInt_t* y, 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]; - } - 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]; - y[idx] = (((p-1-i) * lelts) - ((i+1)*relts)) % q; - lelts -= z; - relts += z; - } - } - } -} - - -void ppGInvPowR (void* y, PrimeExponent pe, hDim_t lts, hDim_t rts, hInt_t q) -{ -#ifdef DEBUG_MODE - ASSERT (q==0); -#endif - hDim_t p = pe.prime; - hShort_t e = pe.exponent; - if (p != 2) - { - gInvPowR ((hInt_t*)y, lts*ipow(p,e-1), rts, p); - } -} - -void ppGInvPowRq (void* y, PrimeExponent pe, hDim_t lts, hDim_t rts, hInt_t q) -{ - hDim_t p = pe.prime; - hShort_t e = pe.exponent; - if (p != 2) - { - gInvPowRq ((hInt_t*)y, lts*ipow(p,e-1), rts, p, q); - } -} - -//do not call for p=2! -void gCRTRq (hInt_t* y, 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]; - 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] = (y[idx]*coeff)%q; - } - } - } -} - -//do not call for p=2! -void gCRTC (complex_t* y, 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]; - 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],coeff); - } - } - } -} - -void ppGCRTRq (void* y, hDim_t lts, hDim_t rts, PrimeExponent pe, void* gcoeffs, hInt_t q) -{ - 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) - { - gCRTRq ((hInt_t*)y, lts*ipow(p,e-1), rts, p, (hInt_t*)gcoeffs, q); - } -} - -void ppGCRTC (void* y, hDim_t lts, hDim_t rts, PrimeExponent pe, void* gcoeffs, hInt_t q) -{ - 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) - { - gCRTC ((complex_t*)y, lts*ipow(p,e-1), rts, p, (complex_t*)gcoeffs); - } -} - -void gInvDecR (hInt_t* y, 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]; - } - 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]; // we already divided acc by p, do not multiply y[idx] by p - y[idx] = tmp; - } - y[tensorOffset] = acc; - } - } -} - -void gInvDecRq (hInt_t* y, 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]); - } - //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]; - y[idx] = tmp % q; - } - y[tensorOffset] = acc % q; - } - } -} - -void ppGInvDecR (void* y, PrimeExponent pe, hDim_t lts, hDim_t rts, hInt_t q) -{ -#ifdef DEBUG_MODE - ASSERT (q==0); -#endif - hDim_t p = pe.prime; - hShort_t e = pe.exponent; - if (p != 2) - { - gInvDecR ((hInt_t*)y, lts*ipow(p,e-1), rts, p); - } -} - -void ppGInvDecRq (void* y, PrimeExponent pe, hDim_t lts, hDim_t rts, hInt_t q) -{ - hDim_t p = pe.prime; - hShort_t e = pe.exponent; - if (p != 2) - { - gInvDecRq ((hInt_t*)y, lts*ipow(p,e-1), rts, p, q); - } -} - -#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 (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, ppGPowR, totm, peArr, sizeOfPE, 0); - -#ifdef STATS - clock_gettime(CLOCK_REALTIME, &t1); - gprTime = tsAdd(gprTime, tsSubtract(t1,s1)); -#endif -} - -void tensorGPowRq (hInt_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, hInt_t q) -{ -#ifdef STATS - gprqCtr++; - struct timespec s1,t1; - clock_gettime(CLOCK_REALTIME, &s1); -#endif - tensorFuser (y, ppGPowRq, totm, peArr, sizeOfPE, q); - - hDim_t j; - for(j = 0; j < totm; j++) - { - if(y[j]<0) - { - y[j]+=q; - } - } - -#ifdef STATS - clock_gettime(CLOCK_REALTIME, &t1); - gprqTime = tsAdd(gprqTime, tsSubtract(t1,s1)); -#endif -} - -void tensorGDecR (hInt_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE) -{ -#ifdef STATS - gdrCtr++; - struct timespec s1,t1; - clock_gettime(CLOCK_REALTIME, &s1); -#endif - tensorFuser (y, ppGDecR, totm, peArr, sizeOfPE, 0); -#ifdef STATS - clock_gettime(CLOCK_REALTIME, &t1); - gdrTime = tsAdd(gdrTime, tsSubtract(t1,s1)); -#endif -} - -void tensorGDecRq (hInt_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, hInt_t q) -{ -#ifdef STATS - gdrqCtr++; - struct timespec s1,t1; - clock_gettime(CLOCK_REALTIME, &s1); -#endif - tensorFuser (y, ppGDecRq, totm, peArr, sizeOfPE, q); - - hDim_t j; - for(j = 0; j < totm; j++) - { - if(y[j]<0) - { - y[j]+=q; - } - } -#ifdef STATS - clock_gettime(CLOCK_REALTIME, &t1); - gdrqTime = tsAdd(gdrqTime, tsSubtract(t1,s1)); -#endif -} - -void tensorGInvPowR (hInt_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE) -{ -#ifdef STATS - giprCtr++; - struct timespec s1,t1; - clock_gettime(CLOCK_REALTIME, &s1); -#endif - tensorFuser (y, ppGInvPowR, totm, peArr, sizeOfPE, 0); - -#ifdef STATS - clock_gettime(CLOCK_REALTIME, &t1); - giprTime = tsAdd(giprTime, tsSubtract(t1,s1)); -#endif -} - -void tensorGInvPowRq (hInt_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, hInt_t q) -{ -#ifdef STATS - giprqCtr++; - struct timespec s1,t1; - clock_gettime(CLOCK_REALTIME, &s1); -#endif - tensorFuser (y, ppGInvPowRq, totm, peArr, sizeOfPE, q); - - hDim_t j; - for(j = 0; j < totm; j++) - { - if(y[j]<0) - { - y[j]+=q; - } - } -#ifdef STATS - clock_gettime(CLOCK_REALTIME, &t1); - giprqTime = tsAdd(giprqTime, tsSubtract(t1,s1)); -#endif -} - -void tensorGInvDecR (hInt_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE) -{ -#ifdef STATS - gidrCtr++; - struct timespec s1,t1; - clock_gettime(CLOCK_REALTIME, &s1); -#endif - tensorFuser (y, ppGInvDecR, totm, peArr, sizeOfPE, 0); -#ifdef STATS - clock_gettime(CLOCK_REALTIME, &t1); - gidrTime = tsAdd(gidrTime, tsSubtract(t1,s1)); -#endif -} - -void tensorGInvDecRq (hInt_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, hInt_t q) -{ -#ifdef STATS - gidrqCtr++; - struct timespec s1,t1; - clock_gettime(CLOCK_REALTIME, &s1); -#endif - tensorFuser (y, ppGInvDecRq, totm, peArr, sizeOfPE, q); - - hDim_t j; - for(j = 0; j < totm; j++) - { - if(y[j]<0) - { - y[j]+=q; - } - } - -#ifdef STATS - clock_gettime(CLOCK_REALTIME, &t1); - gidrqTime = tsAdd(gidrqTime, tsSubtract(t1,s1)); -#endif -} - -void tensorGCRTRq (hInt_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, hInt_t** gcoeffs, hInt_t q) -{ -#ifdef STATS - gcrqCtr++; - struct timespec s1,t1; - clock_gettime(CLOCK_REALTIME, &s1); -#endif -#ifdef DEBUG_MODE - printf("\n\nEntered tensorGCRTRq\ttotm=%" PRId32 "\tnumFacts=%" PRId16 "\tq=%" PRId64 "\n[", totm, sizeOfPE, q); - hDim_t j; - for(j = 0; j < totm; j++) { - printf("%" PRId64 ",", y[j]); - } - printf("]\n["); - for(j = 0; j < sizeOfPE; j++) { - printf("(%" PRId32 ",%" PRId16 "),", peArr[j].prime, peArr[j].exponent); - } - printf("]\n"); -#endif - void** vgcoeffs = (void**)malloc(sizeOfPE*sizeof(void*)); - hDim_t i; - for(i = 0; i < sizeOfPE; i++) - { - vgcoeffs[i] = (void*) (gcoeffs[i]); - } - - tensorFuserCRT (y, ppGCRTRq, totm, peArr, sizeOfPE, vgcoeffs, q); - -#ifdef DEBUG_MODE - for(j = 0; j < totm; j++) - { - if(y[j]<0) - { - printf("tensorGCRTRq\n"); - } - } -#endif -#ifdef STATS - clock_gettime(CLOCK_REALTIME, &t1); - gcrqTime = tsAdd(gcrqTime, tsSubtract(t1,s1)); -#endif -} -void tensorGCRTC (complex_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, complex_t** gcoeffs) -{ -#ifdef STATS - gccCtr++; - struct timespec s1,t1; - clock_gettime(CLOCK_REALTIME, &s1); -#endif -#ifdef DEBUG_MODE - printf("\n\nEntered tensorGCRTC\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** vgcoeffs = (void**)malloc(sizeOfPE*sizeof(void*)); - hDim_t i; - for(i = 0; i < sizeOfPE; i++) - { - vgcoeffs[i] = (void*) (gcoeffs[i]); - } - - tensorFuserCRT (y, ppGCRTC, totm, peArr, sizeOfPE, vgcoeffs, 0); - -#ifdef STATS - clock_gettime(CLOCK_REALTIME, &t1); - gccTime = tsAdd(gccTime, tsSubtract(t1,s1)); -#endif -} -void tensorGInvCRTRq (hInt_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, hInt_t** gcoeffs, hInt_t q) -{ -#ifdef STATS - gicrqCtr++; -#endif - tensorGCRTRq (y, totm, peArr, sizeOfPE, gcoeffs, q); //output is already shifted -} -void tensorGInvCRTC (complex_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, complex_t** gcoeffs) -{ -#ifdef STATS - giccCtr++; -#endif - tensorGCRTC (y, totm, peArr, sizeOfPE, gcoeffs); -} - diff --git a/src/Crypto/Lol/Cyclotomic/Tensor/CTensor/generalfuncs.c b/src/Crypto/Lol/Cyclotomic/Tensor/CTensor/generalfuncs.c deleted file mode 100644 --- a/src/Crypto/Lol/Cyclotomic/Tensor/CTensor/generalfuncs.c +++ /dev/null @@ -1,293 +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, funcPtr f, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, 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, pe, lts, rts, q); - rts *= dim; - } -} - -void tensorFuserCRT (void* y, 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, 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("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("\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(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; - gprqCtr = 0; - gdrCtr = 0; - gdrqCtr = 0; - giprCtr = 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; - - 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}; - - gprTime = (struct timespec){0,0}; - gprqTime = (struct timespec){0,0}; - gdrTime = (struct timespec){0,0}; - gdrqTime = (struct timespec){0,0}; - giprTime = (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/src/Crypto/Lol/Cyclotomic/Tensor/CTensor/l.c b/src/Crypto/Lol/Cyclotomic/Tensor/CTensor/l.c deleted file mode 100644 --- a/src/Crypto/Lol/Cyclotomic/Tensor/CTensor/l.c +++ /dev/null @@ -1,410 +0,0 @@ -#include "tensorTypes.h" - -void lpRq (hInt_t* y, 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] + y[idx]; - if (temp >= q) y[idx]=temp-q; - else y[idx] = temp; - idx += rts; - } - } - } -} - -void lpR (hInt_t* y, 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] += y[idx-rts]; - idx += rts; - } - } - } -} - -void lpDouble (double* y, 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] += y[idx-rts]; - idx += rts; - } - } - } -} - -void lpC (complex_t* y, 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], y[idx-rts]); - idx += rts; - } - } - } -} - -void lpInvRq (hInt_t* y, 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] - y[idx-rts] + q; - if (temp >= q) y[idx]=temp-q; - else y[idx] = temp; - idx -= rts; - } - } - } -} - -void lpInvR (hInt_t* y, 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] -= y[idx-rts] ; - idx -= rts; - } - } - } -} - -void lpInvDouble (double* y, 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] -= y[idx-rts] ; - idx -= rts; - } - } - } -} - -void lpInvC (complex_t* y, 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], y[idx-rts]); - idx -= rts; - } - } - } -} - -void ppLRq (void* y, PrimeExponent pe, hDim_t lts, hDim_t rts, hInt_t q) { - hDim_t p = pe.prime; - hShort_t e = pe.exponent; - lpRq ((hInt_t*)y, lts*ipow(p,e-1), rts, p, q); -} - -void ppLR (void* y, PrimeExponent pe, hDim_t lts, hDim_t rts, hInt_t q) { -#ifdef DEBUG_MODE - ASSERT (q==0); -#endif - hDim_t p = pe.prime; - hShort_t e = pe.exponent; - lpR ((hInt_t*)y, lts*ipow(p,e-1), rts, p); -} - -void ppLDouble (void* y, PrimeExponent pe, hDim_t lts, hDim_t rts, hInt_t q) { -#ifdef DEBUG_MODE - ASSERT (q==0); -#endif - hDim_t p = pe.prime; - hShort_t e = pe.exponent; - lpDouble ((double*)y, lts*ipow(p,e-1), rts, p); -} - -void ppLC (void* y, PrimeExponent pe, hDim_t lts, hDim_t rts, hInt_t q) { -#ifdef DEBUG_MODE - ASSERT (q==0); -#endif - hDim_t p = pe.prime; - hShort_t e = pe.exponent; - lpC ((complex_t*)y, lts*ipow(p,e-1), rts, p); -} - - -void ppLInvRq (void* y, PrimeExponent pe, hDim_t lts, hDim_t rts, hInt_t q) { - hDim_t p = pe.prime; - hShort_t e = pe.exponent; - lpInvRq ((hInt_t*)y, lts*ipow(p,e-1), rts, p, q); -} - -void ppLInvR (void* y, PrimeExponent pe, hDim_t lts, hDim_t rts, hInt_t q) { -#ifdef DEBUG_MODE - ASSERT (q==0); -#endif - hDim_t p = pe.prime; - hShort_t e = pe.exponent; - lpInvR ((hInt_t*)y, lts*ipow(p,e-1), rts, p); -} - -void ppLInvDouble (void* y, PrimeExponent pe, hDim_t lts, hDim_t rts, hInt_t q) { -#ifdef DEBUG_MODE - ASSERT (q==0); -#endif - hDim_t p = pe.prime; - hShort_t e = pe.exponent; - lpInvDouble ((double*)y, lts*ipow(p,e-1), rts, p); -} - -void ppLInvC (void* y, PrimeExponent pe, hDim_t lts, hDim_t rts, hInt_t q) { -#ifdef DEBUG_MODE - ASSERT (q==0); -#endif - hDim_t p = pe.prime; - hShort_t e = pe.exponent; - lpInvC ((complex_t*)y, 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 (hInt_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, hInt_t q) { -#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, ppLRq, totm, peArr, sizeOfPE, q); // don't need to shift here -#ifdef DEBUG_MODE - for(i = 0; i < totm; 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 (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, ppLR, totm, peArr, sizeOfPE, 0); -#ifdef STATS - clock_gettime(CLOCK_REALTIME, &t1); - lrTime = tsAdd(lrTime, tsSubtract(t1,s1)); -#endif -} - -void tensorLDouble (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, ppLDouble, totm, peArr, sizeOfPE, 0); -#ifdef STATS - clock_gettime(CLOCK_REALTIME, &t1); - ldTime = tsAdd(ldTime, tsSubtract(t1,s1)); -#endif -} - -void tensorLC (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, ppLC, totm, peArr, sizeOfPE, 0); -#ifdef STATS - clock_gettime(CLOCK_REALTIME, &t1); - lcTime = tsAdd(lcTime, tsSubtract(t1,s1)); -#endif -} - -void tensorLInvRq (hInt_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, hInt_t q) { -#ifdef STATS - lirqCtr++; - struct timespec s1,t1; - clock_gettime(CLOCK_REALTIME, &s1); -#endif - tensorFuser (y, ppLInvRq, totm, peArr, sizeOfPE, q); // don't need to shift here -#ifdef DEBUG_MODE - hDim_t i; - for(i = 0; i < totm; 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 (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, ppLInvR, totm, peArr, sizeOfPE, 0); -#ifdef STATS - clock_gettime(CLOCK_REALTIME, &t1); - lirTime = tsAdd(lirTime, tsSubtract(t1,s1)); -#endif -} - -void tensorLInvDouble (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, ppLInvDouble, totm, peArr, sizeOfPE, 0); -#ifdef STATS - clock_gettime(CLOCK_REALTIME, &t1); - lidTime = tsAdd(lidTime, tsSubtract(t1,s1)); -#endif -} - -void tensorLInvC (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, ppLInvC, totm, peArr, sizeOfPE, 0); -#ifdef STATS - clock_gettime(CLOCK_REALTIME, &t1); - licTime = tsAdd(licTime, tsSubtract(t1,s1)); -#endif -} - diff --git a/src/Crypto/Lol/Cyclotomic/Tensor/CTensor/random.c b/src/Crypto/Lol/Cyclotomic/Tensor/CTensor/random.c deleted file mode 100644 --- a/src/Crypto/Lol/Cyclotomic/Tensor/CTensor/random.c +++ /dev/null @@ -1,72 +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, 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].real * y[tensorOffset+rts*(col-1)]; - } - for(col = (p>>1)+1; col <= p-1; col++) - { - acc += 2 * ruinv[((row*col) % p)*rustride].imag * y[tensorOffset+rts*(col-1)]; - } - tempSpace[row] = acc/sqrt(2); - } - - for(row = 0; row < p-1; row++) - { - y[tensorOffset+rts*row] = tempSpace[row]; - } - } - } - free(tempSpace); -} - -void ppD (void *y, hDim_t lts, hDim_t rts, PrimeExponent pe, void *ruinv, hInt_t q) -{ - hDim_t p = pe.prime; - hDim_t e = pe.exponent; -#ifdef DEBUG_MODE - ASSERT(e != 0); -#endif - hDim_t mprime = ipow(p,e-1); - primeD (y, lts*mprime, rts, p, mprime, (complex_t*)ruinv); -} - -//the contents of y will be destroyed, but should be initialized in Haskell-land to independent Guassians over the reals -void tensorGaussianDec (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, ppD, totm, peArr, sizeOfPE, ruinvs, 0); - - free(ruinvs); -} diff --git a/src/Crypto/Lol/Cyclotomic/Tensor/CTensor/tensorTypes.h b/src/Crypto/Lol/Cyclotomic/Tensor/CTensor/tensorTypes.h deleted file mode 100644 --- a/src/Crypto/Lol/Cyclotomic/Tensor/CTensor/tensorTypes.h +++ /dev/null @@ -1,224 +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 gprqCtr; -extern int gdrCtr; -extern int gdrqCtr; -extern int giprCtr; -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 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 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 gprqTime; -extern struct timespec gdrTime; -extern struct timespec gdrqTime; -extern struct timespec giprTime; -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; - -//complex_t _add (complex_t a, complex_t b); -//complex_t _mul (complex_t a, complex_t b); - -#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; } - - -/* -// check if both vectors are identical -bool eqInt (hInt_t a[], hInt_t b[], size_t n); -// operations on integer vectors point-wise -void addInt (hInt_t result[], hInt_t a[], hInt_t b[], size_t n); -void mulInt (hInt_t result[], hInt_t a[], hInt_t b[], size_t n); -*/ - -// 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 (hInt_t* a, hInt_t* b, hDim_t totm, hInt_t q); -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 (complex_t* a, complex_t* b, hDim_t totm); - -void addR (hInt_t* a, hInt_t* b, hDim_t totm); -void addRq (hInt_t* a, const hInt_t* b, const hDim_t totm, const hInt_t q); -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 (complex_t* a, complex_t* b, hDim_t totm); -void addD (double* a, double* b, hDim_t totm); - -typedef void (*funcPtr) (void* outputVec, PrimeExponent pe, hDim_t lts, hDim_t rts, hInt_t q); -void tensorFuser (void* y, funcPtr f, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, hInt_t q); - -typedef void (*crtFuncPtr) (void* y, hDim_t lts, hDim_t rts, PrimeExponent pe, void* ru, hInt_t q); -void tensorFuserCRT (void* y, crtFuncPtr f, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, void** ru, hInt_t q); - -void tensorGPowR (hInt_t* x, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE); - -void tensorGPowRq (hInt_t* x, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, hInt_t q); - -void tensorGDecR (hInt_t* x, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE); - -void tensorGDecRq (hInt_t* x, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, hInt_t q); - -void tensorGInvPowR (hInt_t* x, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE); - -void tensorGInvPowRq (hInt_t* x, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, hInt_t q); - -void tensorGInvDecR (hInt_t* x, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE); - -void tensorGInvDecRq (hInt_t* x, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, hInt_t q); - -void tensorGCRTRq (hInt_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, hInt_t** gcoeffs, hInt_t q); - -void tensorGInvCRTRq (hInt_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, hInt_t** gcoeffs, hInt_t q); - -void tensorGCRTC (complex_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, complex_t** gcoeffs); - -void tensorGInvCRTC (complex_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, complex_t** gcoeffs); - - - -void tensorLRq (hInt_t* x, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, hInt_t q); - -void tensorLR (hInt_t* x, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE); - -void tensorLDouble (double* x, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE); - -void tensorLC (complex_t* x, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE); - -void tensorLInvRq (hInt_t* x, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, hInt_t q); - -void tensorLInvR (hInt_t* x, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE); - -void tensorLInvDouble (double* x, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE); - -void tensorLInvC (complex_t* x, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE); - - - -void tensorCRTRq (hInt_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, hInt_t** ru, hInt_t q); - -void tensorCRTC (complex_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, complex_t** ru); - -void tensorCRTInvRq (hInt_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, hInt_t** ru, hInt_t minv, hInt_t q); - -void tensorCRTInvC (complex_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, complex_t** ru, double minv); - -void tensorGaussianDec (double* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, complex_t** ru); - - -#endif /* TENSORTYPES_H_ */ - diff --git a/src/Crypto/Lol/Cyclotomic/Tensor/RepaTensor.hs b/src/Crypto/Lol/Cyclotomic/Tensor/RepaTensor.hs deleted file mode 100644 --- a/src/Crypto/Lol/Cyclotomic/Tensor/RepaTensor.hs +++ /dev/null @@ -1,199 +0,0 @@ -{-# LANGUAGE ConstraintKinds, DataKinds, DeriveDataTypeable, - FlexibleContexts, FlexibleInstances, GADTs, InstanceSigs, - MultiParamTypeClasses, NoImplicitPrelude, RebindableSyntax, - RoleAnnotations, ScopedTypeVariables, StandaloneDeriving, - TypeFamilies, TypeOperators, UndecidableInstances #-} - --- | A pure, repa-based implementation of the Tensor interface. - -module Crypto.Lol.Cyclotomic.Tensor.RepaTensor -( RT ) where - -import Crypto.Lol.Cyclotomic.Tensor as T -import Crypto.Lol.Cyclotomic.Tensor.RepaTensor.CRT -import Crypto.Lol.Cyclotomic.Tensor.RepaTensor.Extension -import Crypto.Lol.Cyclotomic.Tensor.RepaTensor.Gauss -import Crypto.Lol.Cyclotomic.Tensor.RepaTensor.GL -import Crypto.Lol.Cyclotomic.Tensor.RepaTensor.RTCommon as RT -import Crypto.Lol.LatticePrelude as LP hiding - ((!!)) -import Crypto.Lol.Types.IZipVector - -import Algebra.Additive as Additive (C) -import Algebra.Ring as Ring (C) -import Algebra.ZeroTestable as ZeroTestable (C) - -import Control.Applicative -import Control.DeepSeq (NFData (rnf)) -import Control.Monad (liftM) -import Control.Monad.Random -import Data.Coerce -import Data.Constraint -import Data.Foldable as F -import Data.Maybe -import Data.Traversable as T -import Data.Typeable -import Data.Vector.Unboxed as U hiding (force) -import Test.QuickCheck - --- | An implementation of 'Tensor' backed by repa. -data RT (m :: Factored) r where - RT :: Unbox r => !(Arr m r) -> RT m r - ZV :: IZipVector m r -> RT m r - deriving (Typeable) - -deriving instance Show r => Show (RT m r) - -instance Eq r => Eq (RT m r) where - (ZV a) == (ZV b) = a == b - (RT a) == (RT b) = a == b - a@(RT _) == b = a == toRT b - a == b@(RT _) = toRT a == b - -zvToArr :: Unbox r => IZipVector m r -> Arr m r -zvToArr v = let vec = convert $ unIZipVector v - in Arr $ fromUnboxed (Z :. U.length vec) vec - --- converts to RT constructor -toRT :: Unbox r => RT m r -> RT m r -toRT v@(RT _) = v -toRT (ZV v) = RT $ zvToArr v - -toZV :: Fact m => RT m r -> RT m r -toZV (RT (Arr v)) = ZV $ fromMaybe (error "toZV: internal error") $ - iZipVector $ convert $ toUnboxed v -toZV v@(ZV _) = v - -wrap :: Unbox r => (Arr l r -> Arr m r) -> RT l r -> RT m r -wrap f (RT v) = RT $ f v -wrap f (ZV v) = RT $ f $ zvToArr v - -wrapM :: (Unbox r, Monad mon) => (Arr l r -> mon (Arr m r)) - -> RT l r -> mon (RT m r) -wrapM f (RT v) = liftM RT $ f v -wrapM f (ZV v) = liftM RT $ f $ zvToArr v - -instance Tensor RT where - - type TElt RT r = (Unbox r, Elt r) - - entailIndexT = tag $ Sub Dict - entailEqT = tag $ Sub Dict - entailZTT = tag $ Sub Dict - entailRingT = tag $ Sub Dict - entailNFDataT = tag $ Sub Dict - entailRandomT = tag $ Sub Dict - - scalarPow = RT . scalarPow' - - l = wrap fL - lInv = wrap fLInv - - mulGPow = wrap fGPow - mulGDec = wrap fGDec - - divGPow = wrapM fGInvPow - divGDec = wrapM fGInvDec - - crtFuncs = (,,,,) <$> - (liftM (RT .) scalarCRT') <*> - (wrap <$> mulGCRT') <*> - (wrap <$> divGCRT') <*> - (wrap <$> fCRT) <*> - (wrap <$> fCRTInv) - - -- instance sigs are the cleanest way to handle many weird types - -- coming up - - tGaussianDec :: forall v rnd m q . - (Fact m, OrdFloat q, Random q, TElt RT q, - ToRational v, MonadRandom rnd) => v -> rnd (RT m q) - tGaussianDec = liftM RT . tGaussianDec' - - twacePowDec = wrap twacePowDec' - - embedPow = wrap embedPow' - embedDec = wrap embedDec' - - crtExtFuncs = (,) <$> (liftM wrap twaceCRT') - <*> (liftM wrap embedCRT') - - coeffs = wrapM coeffs' - - powBasisPow = (RT <$>) <$> powBasisPow' - - crtSetDec = (RT <$>) <$> crtSetDec' - - fmapT f (RT v) = RT $ (coerce $ force . RT.map f) v - fmapT f v@(ZV _) = fmapT f $ toRT v - - -- Repa arrays don't have mapM, so apply to underlying Unboxed - -- vector instead - fmapTM f (RT (Arr arr)) = liftM (RT . Arr . fromUnboxed (extent arr)) $ - U.mapM f $ toUnboxed arr - fmapTM f v@(ZV _) = fmapTM f $ toRT v - ----------- "Container" instances ---------- - -instance Fact m => Functor (RT m) where - -- Functor instance is implied by Applicative - fmap f x = pure f <*> x - -instance Fact m => Applicative (RT m) where - pure = ZV . pure - - -- RT can never hold an a -> b - (ZV f) <*> (ZV a) = ZV (f <*> a) - f@(ZV _) <*> v@(RT _) = f <*> toZV v - -instance Fact m => Foldable (RT m) where - -- Foldable instance is implied by Traversable - foldMap = foldMapDefault - -instance Fact m => Traversable (RT m) where - traverse f r@(RT _) = T.traverse f $ toZV r - traverse f (ZV v) = ZV <$> T.traverse f v - - ----------- Numeric Prelude instances ---------- - --- CJP: should Elt, Unbox be constraints on these instances? It's --- possible to zipWith on IZipVector, so it's not *necessary* to --- convert toRT. - -instance (Fact m, Additive r, Unbox r, Elt r) => Additive.C (RT m r) where - (RT a) + (RT b) = RT $ coerce (\x -> force . RT.zipWith (+) x) a b - a + b = toRT a + toRT b - - negate (RT a) = RT $ (coerce $ force . RT.map negate) a - negate a = negate $ toRT a - - zero = RT $ repl zero - -instance (Fact m, Ring r, Unbox r, Elt r) => Ring.C (RT m r) where - (RT a) * (RT b) = RT $ coerce (\x -> force . RT.zipWith (*) x) a b - a * b = (toRT a) * (toRT b) - - fromInteger = RT . repl . fromInteger - -instance (Fact m, ZeroTestable r, Unbox r, Elt r) => ZeroTestable.C (RT m r) where - -- not using 'zero' to avoid Additive r constraint - isZero (RT (Arr a)) = isZero $ foldAllS (\ x y -> if isZero x then y else x) (a RT.! (Z:.0)) a - isZero (ZV v) = isZero v - ----------- Miscellaneous instances ---------- - --- CJP: shouldn't these instances be defined in RTCommon, where the --- Arr data type is defined? Here they are orphans. - -instance (Unbox r, Random (Arr m r)) => Random (RT m r) where - random = runRand $ liftM RT (liftRand random) - - randomR = error "randomR nonsensical for RT" - -instance (Unbox r, Arbitrary (Arr m r)) => Arbitrary (RT m r) where - arbitrary = RT <$> arbitrary - -instance (NFData r) => NFData (RT m r) where - rnf (RT v) = rnf v - rnf (ZV v) = rnf v diff --git a/src/Crypto/Lol/Cyclotomic/Tensor/RepaTensor/CRT.hs b/src/Crypto/Lol/Cyclotomic/Tensor/RepaTensor/CRT.hs deleted file mode 100644 --- a/src/Crypto/Lol/Cyclotomic/Tensor/RepaTensor/CRT.hs +++ /dev/null @@ -1,185 +0,0 @@ -{-# LANGUAGE ConstraintKinds, FlexibleContexts, GADTs, NoImplicitPrelude, - ScopedTypeVariables #-} - --- | Functions to support the chinese remainder transform on Repa arrays - -module Crypto.Lol.Cyclotomic.Tensor.RepaTensor.CRT -( scalarCRT' -, fCRT, fCRTInv -, mulGCRT', divGCRT' -, gCRT, gInvCRT -) where - -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 Control.Applicative -import Data.Coerce -import Data.Singletons.Prelude -import Data.Type.Natural as N hiding (Z, one, zero) - --- | Embeds a scalar into the CRT-basis when such basis exists -scalarCRT' :: forall m r . (Fact m, CRTrans r, Unbox r) - => Maybe (r -> Arr m r) -scalarCRT' - = let pps = proxy ppsFact (Proxy::Proxy m) - sz = Z :. totientPPs pps - in pure $ Arr . force . fromFunction sz . const - --- | Multiplies an array in the CRT basis by 'g', when the CRT basis exists -mulGCRT' :: forall m r . (Fact m, CRTrans r, Unbox r, Elt r) - => Maybe (Arr m r -> Arr m r) -mulGCRT' = (coerce (\x -> force . RT.zipWith (*) x) `asTypeOf` asTypeOf) <$> gCRT - --- | Divides an array in the CRT basis by 'g', when the CRT basis exists. -divGCRT' :: (Fact m, CRTrans r, IntegralDomain r, ZeroTestable r, - Unbox r, Elt r) => Maybe (Arr m r -> Arr m r) -divGCRT' = (coerce (\x -> force . RT.zipWith (*) x) `asTypeOf` asTypeOf) <$> gInvCRT - --- | The CRT-basis representation of 'g' -gCRT :: (Fact m, CRTrans r, Unbox r, Elt r) - => Maybe (Arr m r) -gCRT = fCRT <*> pure (fGPow $ scalarPow' LP.one) - --- EAC: This was defined using (a safe call to) fromJust - --- | The CRT-basis representation of 'g^{ -1 }' -gInvCRT:: (Fact m, CRTrans r, IntegralDomain r, - ZeroTestable r, Unbox r, Elt r) - => Maybe (Arr m r) -gInvCRT = fCRT <*> fGInvPow (scalarPow' LP.one) - - -fCRT, fCRTInv :: - forall m r . (Fact m, CRTrans r, Unbox r, Elt r) - => Maybe (Arr m r -> Arr m r) --- | The chinese remainder transform on Repa arrays. --- 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 on Repa arrays. --- Exists if and only if crt exists for all prime powers -fCRTInv = do -- in Maybe - (_, mhatInv) :: (CRTInfo r) <- proxyT crtInfoFact (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) - -ppDFT = case (sing :: SPrimePower pp) of - (SPP (STuple2 _ SZ)) -> return $ Id 1 - spp@(SPP (STuple2 sp (SS se1))) -> - tagT $ do - let spp' = SPP (STuple2 sp se1) - pp'dft <- withWitnessT ppDFT spp' - pptwid <- withWitnessT (ppTwid False) spp - pdft <- withWitnessT pDFT sp - return $ (pp'dft @* Id (dim pdft)) .* pptwid .* (Id (dim pp'dft) @* pdft) - -ppDFTInv' = case (sing :: SPrimePower pp) of - (SPP (STuple2 _ SZ)) -> return $ Id 1 - spp@(SPP (STuple2 sp (SS se1))) -> - tagT $ do - let spp' = SPP (STuple2 sp se1) - pp'dftInv' <- withWitnessT ppDFTInv' spp' - pptwidInv <- withWitnessT (ppTwid True) spp - pdftInv' <- withWitnessT pDFTInv' sp - return $ - (Id (dim pp'dftInv') @* pdftInv') .* pptwidInv .* - (pp'dftInv' @* Id (dim pdftInv')) - -ppCRT = case (sing :: SPrimePower pp) of - (SPP (STuple2 _ SZ)) -> return $ Id 1 - spp@(SPP (STuple2 sp (SS se1))) -> - tagT $ do - let spp' = SPP (STuple2 sp se1) - pp'dft <- withWitnessT ppDFT spp' - pptwid <- withWitnessT (ppTwidHat False) spp - pcrt <- withWitnessT pCRT sp - return $ - (pp'dft @* Id (dim pcrt)) .* pptwid .* - -- save some work when p=2 - (if dim pcrt > 1 then Id (dim pp'dft) @* pcrt else Id (dim pp'dft)) - -ppCRTInv' = case (sing :: SPrimePower pp) of - (SPP (STuple2 _ SZ)) -> return $ Id 1 - spp@(SPP (STuple2 sp (SS se1))) -> - tagT $ do - let spp' = SPP (STuple2 sp se1) - pp'dftInv' <- withWitnessT ppDFTInv' spp' - pptwidInv <- withWitnessT (ppTwidHat True) spp - pcrtInv' <- withWitnessT pCRTInv' sp - return $ -- special case for p=2 (necessary for scaling!) - (if dim pcrtInv' > 1 - then Id (dim pp'dftInv') @* pcrtInv' else Id (dim pp'dftInv')) .* - pptwidInv .* (pp'dftInv' @* Id (dim pcrtInv')) - --- DFT_p, CRT_p, (scaled) DFT_p^-1, etc. -pDFT, pDFTInv', pCRT, pCRTInv' :: - forall p r . (NatC p, CRTrans r, Unbox r, Elt r) - => TaggedT p Maybe (Trans r) - -pDFT = let pval = proxy valueNatC (Proxy::Proxy p) - in do (omegaPPow, _) <- crtInfoNatC - return $ trans pval $ mulMat $ force $ - fromFunction (Z :. pval :. pval) - (\(Z:.i:.j) -> omegaPPow (i*j)) - -pDFTInv' = let pval = proxy valueNatC (Proxy::Proxy p) - in do (omegaPPow, _) <- crtInfoNatC - return $ trans pval $ mulMat $ force $ - fromFunction (Z :. pval :. pval) - (\(Z:.i:.j) -> omegaPPow (-i*j)) - -pCRT = let pval = proxy valueNatC (Proxy::Proxy p) - in do (omegaPPow, _) <- crtInfoNatC - return $ trans (pval-1) $ mulMat $ force $ - fromFunction (Z :. pval-1 :. pval-1) - (\(Z:.i:.j) -> omegaPPow ((i+1)*j)) - --- crt_p * this = pI, for all values of p. For p=2 this isn't the --- matrix we "want," but it doesn't matter because we don't use it in --- ppCRTInv' -pCRTInv' = - let pval = proxy valueNatC (Proxy::Proxy p) - in do (omegaPPow, _) <- crtInfoNatC - return $ trans (pval-1) $ mulMat $ force $ - fromFunction (Z :. pval-1 :. pval-1) - (\(Z:.i:.j) -> omegaPPow (negate i*(j+1)) - - omegaPPow (j+1)) - --- 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) - -ppTwid inv = - let pp@(p,e) = proxy ppPPow (Proxy :: Proxy pp) - ppval = valuePP pp - in do - (omegaPPPow, _) <- crtInfoPPow - return $ trans ppval $ mulDiag $ force $ - fromFunction (Z :. ppval) - (\(Z:.i) -> let (iq,ir) = i `divMod` p - pow = (if inv then negate else id) - ir * digitRev (p,e-1) iq - in omegaPPPow pow) - -ppTwidHat inv = - let pp@(p,e) = proxy ppPPow (Proxy :: Proxy pp) - pptot = totientPP pp - in do - (omegaPPPow, _) <- crtInfoPPow - return $ trans pptot $ mulDiag $ force $ - fromFunction (Z :. pptot) - (\(Z:.i) -> let (iq,ir) = i `divMod` (p-1) - pow = (if inv then negate else id) - (ir+1) * digitRev (p,e-1) iq - in omegaPPPow pow) diff --git a/src/Crypto/Lol/Cyclotomic/Tensor/RepaTensor/Extension.hs b/src/Crypto/Lol/Cyclotomic/Tensor/RepaTensor/Extension.hs deleted file mode 100644 --- a/src/Crypto/Lol/Cyclotomic/Tensor/RepaTensor/Extension.hs +++ /dev/null @@ -1,193 +0,0 @@ -{-# LANGUAGE BangPatterns, ConstraintKinds, DataKinds, FlexibleContexts, - FlexibleInstances, MultiParamTypeClasses, NoImplicitPrelude, - ScopedTypeVariables, TemplateHaskell, TypeFamilies, - TypeOperators #-} - --- | RT-specific functions for embedding/twacing in various bases - -module Crypto.Lol.Cyclotomic.Tensor.RepaTensor.Extension -( twacePowDec', twaceCRT', embedPow', embedDec', embedCRT' -, coeffs', powBasisPow', crtSetDec' --, fromCoeffs' -) 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 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 Control.Applicative -import Control.Arrow (first, (***)) - -import Data.Coerce -import Data.Default -import Data.Maybe -import Data.Reflection (reify) -import qualified Data.Vector as V -import qualified Data.Vector.Unboxed as U -import Data.Vector.Unboxed.Deriving - --- Default instances -instance Default Z where def = Z -instance (Default a, Default b) => Default (a:.b) where def = def:.def - --- derived Unbox instances -derivingUnbox "DIM1" - [t| (Z:.Int) -> Int |] - [| \(Z:.i) -> i |] - [| (Z :.) |] - --- | The "tweaked trace" function in either the powerful or decoding --- 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 -twacePowDec' - = let indices = proxy extIndicesPowDec (Proxy::Proxy '(m, m')) - 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 --- @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 - g' :: Arr m' r <- gCRT - gInv <- gInvCRT - embed :: Arr m r -> Arr m' r <- embedCRT' - (_, m'hatinv) <- proxyT crtInfoFact (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 $ - -- take true trace after mul-by-tweak - coerce (\ !arr -> sumS . backpermute (extent indices) (indices !) . RT.zipWith (*) arr) tweak - -embedPow', embedDec' :: forall m m' r . - (m `Divides` m', Unbox r, Additive r) - => Arr m r -> Arr m' r --- | Embeds an array in the powerful basis of the the mth cyclotomic ring --- to an array in the powerful basis of the m'th cyclotomic ring when @m | m'@ -embedPow' - = let indices = proxy baseIndicesPow (Proxy::Proxy '(m, m')) - in coerce $ \ !arr -> force $ fromFunction (extent indices) - (\idx -> let (j0,j1) = (indices ! idx) - in if j0 == 0 then arr ! j1 else zero) --- | Embeds an array in the decoding basis of the the mth cyclotomic ring --- to an array in the decoding basis of the m'th cyclotomic ring when @m | m'@ -embedDec' - = let indices = proxy baseIndicesDec (Proxy::Proxy '(m, m')) - in coerce $ \ !arr -> force $ - fromFunction (extent indices) - (\idx -> maybe zero - (\(sh,b) -> if b then negate (arr ! sh) - else arr ! sh) - (indices ! idx)) - --- | 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 - -- first check existence of CRT transform of index m' - proxyT crtInfoFact (Proxy::Proxy m') :: Maybe (CRTInfo r) - let idxs = proxy baseIndicesCRT (Proxy::Proxy '(m,m')) - return $ coerce $ \ !arr -> (force $ backpermute (extent idxs) (idxs !) arr) - --- | maps an array in the powerful/decoding basis, representing an --- O_m' element, to an array of arrays representing O_m elements in --- the same type of basis -coeffs' :: forall m m' r . (m `Divides` m', Unbox r) - => Arr m' r -> [Arr m r] -coeffs' = - let indices = proxy extIndicesCoeffs (Proxy::Proxy '(m, m')) - in coerce $ \ !arr -> V.toList $ - V.map (\idxs -> force $ backpermute (extent idxs) (idxs !) arr) indices - --- | The powerful extension basis, wrt the powerful basis. --- 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 $ - 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') - (\(Z:.j) -> let (j0,j1) = idxs U.! j - in if j0==k && j1==0 then one else zero)) - [0..phi' `div` phi - 1] - --- | A list of arrays representing the mod-p CRT set of the --- extension O_m'/O_m -crtSetDec' :: forall m m' fp . - (m `Divides` m', PrimeField fp, - Coprime (PToF (CharOf fp)) m', Unbox fp) - => Tagged m [Arr m' fp] -crtSetDec' = return $ - let m'p = Proxy :: Proxy m' - p = proxy value (Proxy::Proxy (CharOf fp)) - phi = proxy totientFact m'p - - d = proxy (order p) m'p - h :: Int = proxy valueHatFact m'p - hinv = recip $ fromIntegral h - in reify d $ \(_::Proxy d) -> - let twCRTs' :: T.Matrix (GF fp d) - = fromMaybe (error "internal error: crtSetDec': twCRTs") $ proxyT T.twCRTs m'p - zmsToIdx = proxy T.zmsToIndexFact m'p - 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) - (\(Z:.j) -> hinv * trace' - (sum $ LP.map (elt j) is))) cosets - - --- convert memoized reindexing Vectors to Arrays, for convenience and speed - -extIndicesPowDec :: forall m m' . (m `Divides` m') - => Tagged '(m, m') (Array U DIM1 DIM1) -extIndicesPowDec = do - idxs <- T.extIndicesPowDec - return $ fromUnboxed (Z :. U.length idxs) $ U.map (Z:.) idxs - -extIndicesCRT :: forall m m' . (m `Divides` m') - => Tagged '(m, m') (Array U DIM2 DIM1) -extIndicesCRT = - let phi = proxy totientFact (Proxy::Proxy m) - phi' = proxy totientFact (Proxy::Proxy m') - in do - idxs <- T.extIndicesCRT - return $ fromUnboxed (Z :. phi :. phi' `div` phi) $ U.map (Z:.) idxs - -baseIndicesPow :: forall m m' . (m `Divides` m') - => Tagged '(m, m') (Array U DIM1 (Int,DIM1)) - -baseIndicesDec :: forall m m' . (m `Divides` m') - => Tagged '(m, m') (Array U DIM1 (Maybe (DIM1, Bool))) - -baseIndicesCRT :: forall m m' . (m `Divides` m') - => Tagged '(m, m') (Array U DIM1 DIM1) - -baseIndicesPow = do - idxs <- T.baseIndicesPow - return $ fromUnboxed (Z :. U.length idxs) $ U.map (id *** (Z:.)) idxs - -baseIndicesDec = do - idxs <- T.baseIndicesDec - return $ fromUnboxed (Z :. U.length idxs) $ U.map (liftA (first (Z:.))) idxs - -baseIndicesCRT = do - idxs <- T.baseIndicesCRT - return $ fromUnboxed (Z :. U.length idxs) $ U.map (Z:.) idxs - -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) $ - U.map (Z:.) arr) <$> T.extIndicesCoeffs diff --git a/src/Crypto/Lol/Cyclotomic/Tensor/RepaTensor/GL.hs b/src/Crypto/Lol/Cyclotomic/Tensor/RepaTensor/GL.hs deleted file mode 100644 --- a/src/Crypto/Lol/Cyclotomic/Tensor/RepaTensor/GL.hs +++ /dev/null @@ -1,112 +0,0 @@ -{-# LANGUAGE BangPatterns, ConstraintKinds, FlexibleContexts, GADTs, - MultiParamTypeClasses, NoImplicitPrelude, RankNTypes, - RebindableSyntax, ScopedTypeVariables #-} - --- | The G and L transforms for Repa arrays - -module Crypto.Lol.Cyclotomic.Tensor.RepaTensor.GL -( fL, fLInv, fGPow, fGDec, fGInvPow, fGInvDec -) where - -import Crypto.Lol.Cyclotomic.Tensor.RepaTensor.RTCommon as RT -import Crypto.Lol.LatticePrelude as LP -import Data.Coerce - -fL, fLInv, fGPow, fGDec :: (Fact m, Additive r, Unbox r, Elt r) - => Arr m r -> Arr m r - -fGInvPow, fGInvDec :: - (Fact m, IntegralDomain r, ZeroTestable r, Unbox r, Elt r) - => Arr m r -> Maybe (Arr m r) --- | Arbitrary-index L transform to convert a dec-basis Repa array to its powerful-basis representation -fL = eval $ fTensor $ ppTensor pL --- | Arbitrary-index L^{ -1 } transform to convert a powerful-basis Repa array to its dec-basis representation -fLInv = eval $ fTensor $ ppTensor pLInv --- | Arbitrary-index multiplication by the ring element g in the powerful basis -fGPow = eval $ fTensor $ ppTensor pGPow --- | Arbitrary-index multiplication by the ring element g in the dec basis -fGDec = eval $ fTensor $ ppTensor pGDec --- | Arbitrary-index division by the ring element g in the powerful basis. May fail if the input is not a multiple of g. -fGInvPow = wrapGInv' pGInvPow' --- | Arbitrary-index multiplication by the ring element g in the dec basis. May fail if the input is not a multiple of g. -fGInvDec = wrapGInv' pGInvDec' - -wrapGInv' :: forall m r . - (Fact m, IntegralDomain r, ZeroTestable r, Unbox r, Elt r) - => (forall p . (NatC p) => Tagged p (Trans r)) - -> Arr m r -> Maybe (Arr m r) -wrapGInv' ginv = - let fGInv = eval $ fTensor $ ppTensor ginv - oddrad = fromIntegral $ proxy oddRadicalFact (Proxy::Proxy m) - in (`divCheck` oddrad) . fGInv - --- | This is not a constant-time algorithm! Depending on its usage, --- it might provide a timing side-channel. -divCheck :: (IntegralDomain r, ZeroTestable r, Unbox r) - => Arr m r -> r -> Maybe (Arr m r) -divCheck = coerce $ \ !arr den -> - let qrs = force $ RT.map (`divMod` den) arr - pass = foldAllS (&&) True $ RT.map (isZero . snd) qrs - out = force $ RT.map fst qrs - in if pass then Just out else Nothing - -pWrap :: forall p r . (NatC p) - => (forall rep . Source rep r => Int -> Array rep DIM2 r -> Array D DIM2 r) - -> Tagged p (Trans r) -pWrap f = let pval = proxy valueNatC (Proxy::Proxy p) - -- special case: return identity function for p=2 - in return $ if pval > 2 - then trans (pval-1) $ f pval - else Id 1 - - -pL, pLInv, pGPow, pGDec :: (NatC p, Additive r, Unbox r, Elt r) - => Tagged p (Trans r) - -pGInvPow', pGInvDec' :: (NatC p, Ring r, Unbox r, Elt r) - => Tagged p (Trans r) - -pL = pWrap (\_ !arr -> - fromFunction (extent arr) $ - \ (i':.i) -> sumAllS $ extract (Z:.0) (Z:.(i+1)) $ slice arr (i':.All)) - -pLInv = pWrap (\_ !arr -> - let f (i' :. 0) = arr! (i' :. 0) - f (i' :. i) = arr! (i' :. i) - arr! (i' :. i-1) - in fromFunction (extent arr) f) - - --- multiplicaton by g_p=1-zeta_p in power basis. --- this is "wrong" for p=2 but we never use that case thanks to pWrap. -pGPow = pWrap (\p !arr -> - let f (i':.0) = arr! (i':.p-2) + arr! (i':.0) - f (i':.i) = arr! (i':.p-2) + arr! (i':.i) - arr! (i':.i-1) - in fromFunction (extent arr) f) - --- multiplication by g_p=1-zeta_p in decoding basis -pGDec = pWrap (\_ !arr -> - let f (i':.0) = arr! (i':.0) + sumAllS (slice arr (i':.All)) - f (i':.i) = arr! (i':.i) - arr! (i':.i-1) - in fromFunction (extent arr) f) - --- CJP: profiling suggests that this does two read passes through the --- array; see if we can rewrite to make it one - --- doesn't do division by (odd) p -pGInvPow' = - pWrap (\p !arr -> - let f (i':.i) = - let col = slice arr (i':.All) - in fromIntegral (p-i-1) * sumAllS (extract (Z:.0) (Z:.i+1) col) + - fromIntegral (-i-1) * sumAllS (extract (Z:.i+1) (Z:.p-i-2) col) - in fromFunction (extent arr) f) - --- doesn't do division by (odd) p -pGInvDec' = - pWrap (\p !arr -> - let f (i':.i) = - let col = slice arr (i':.All) - nats = fromFunction (Z:.p-1) (\(Z:.j) -> fromIntegral j+1) - in (sumAllS $ RT.zipWith (*) col nats) - - fromIntegral p * sumAllS (extract (Z:.i+1) (Z:.p-i-2) col) - in fromFunction (extent arr) f) diff --git a/src/Crypto/Lol/Cyclotomic/Tensor/RepaTensor/Gauss.hs b/src/Crypto/Lol/Cyclotomic/Tensor/RepaTensor/Gauss.hs deleted file mode 100644 --- a/src/Crypto/Lol/Cyclotomic/Tensor/RepaTensor/Gauss.hs +++ /dev/null @@ -1,51 +0,0 @@ -{-# LANGUAGE ConstraintKinds, FlexibleContexts, NoImplicitPrelude, - RebindableSyntax, ScopedTypeVariables #-} - --- | (Continuous) Gaussian sampling for Repa arrays - -module Crypto.Lol.Cyclotomic.Tensor.RepaTensor.Gauss -( tGaussianDec' ) where - -import Crypto.Lol.Cyclotomic.Tensor.RepaTensor.RTCommon -import Crypto.Lol.GaussRandom -import Crypto.Lol.LatticePrelude - -import Control.Monad.Random - --- | A function tagged by the cyclotomic index which, --- given a (scaled) variance, outputs a Gaussian-distributed --- vector in the decoding basis -tGaussianDec' :: forall m v r rnd . - (Fact m, OrdFloat r, Random r, Unbox r, Elt r, - ToRational v, MonadRandom rnd) - => v -> rnd (Arr m r) -tGaussianDec' = - let pm = Proxy::Proxy m - m = proxy valueFact pm - n = proxy totientFact pm - rad = proxy radicalFact pm - in \v -> do -- rnd monad - x <- realGaussians (v * fromIntegral (m `div` rad)) n - let arr = Arr $ fromUnboxed (Z:.n) x - return $ fD arr - --- | The fully tensored D transformation -fD :: (Fact m, Transcendental r, Unbox r, Elt r) => Arr m r -> Arr m r -fD = eval $ fTensor $ ppTensor pD - --- | The D transformation for a prime -pD :: forall p r . (NatC p, Transcendental r, Unbox r, Elt r) - => Tagged p (Trans r) -pD = let pval = proxy valueNatC (Proxy::Proxy p) - in tag $ - if pval==2 - then Id 1 - else trans (pval-1) $ mulMat $ force $ - fromFunction (Z :. pval-1 :. pval-1) - (\(Z:.i:.j) -> - -- mtx is sqrt(2)*[ cos(2pi*i*(j+1)/p) | sin(same) ] - -- (signs of columns doesn't matter for our purposes.) - let theta = 2 * pi * fromIntegral (i*(j+1)) / - fromIntegral pval - in sqrt 2 * if j < pval `div` 2 - then cos theta else sin theta) diff --git a/src/Crypto/Lol/Cyclotomic/Tensor/RepaTensor/RTCommon.hs b/src/Crypto/Lol/Cyclotomic/Tensor/RepaTensor/RTCommon.hs deleted file mode 100644 --- a/src/Crypto/Lol/Cyclotomic/Tensor/RepaTensor/RTCommon.hs +++ /dev/null @@ -1,233 +0,0 @@ -{-# LANGUAGE BangPatterns, ConstraintKinds, DataKinds, FlexibleContexts, - FlexibleInstances, GADTs, GeneralizedNewtypeDeriving, - KindSignatures, MultiParamTypeClasses, NoImplicitPrelude, - RankNTypes, RebindableSyntax, RoleAnnotations, - ScopedTypeVariables, TypeOperators #-} - --- | A simple DSL for tensoring Repa arrays and other common functionality --- on Repa arrays - -module Crypto.Lol.Cyclotomic.Tensor.RepaTensor.RTCommon -( module R -, module Data.Array.Repa.Eval -, module Data.Array.Repa.Repr.Unboxed -, Arr(..), repl, replM, eval, evalM, fTensor, ppTensor -, Trans(Id), trans, dim, (.*), (@*), force -, mulMat, mulDiag -, scalarPow' -, sumS, sumAllS -) where - -import Crypto.Lol.LatticePrelude as LP hiding ((!!)) - -import Control.DeepSeq (NFData (..)) -import Control.Monad.Identity -import Control.Monad.Random -import Data.Array.Repa as R hiding (sumAllP, sumAllS, sumP, - sumS, (*^), (+^), (-^), (/^)) -import Data.Array.Repa.Eval hiding (one, zero) -import Data.Array.Repa.Repr.Unboxed -import Data.Coerce -import Data.Singletons -import Data.Singletons.Prelude hiding ((:.)) -import Data.Type.Natural hiding (Z) -import Data.Typeable -import qualified Data.Vector.Unboxed as U -import Test.QuickCheck - --- always unboxed (manifest); intermediate calculations can use --- delayed arrays - --- | Indexed newtype for 1-dimensional Unbox repa arrays -newtype Arr (m :: Factored) r = Arr (Array U DIM1 r) - deriving (Eq, Show, Typeable, NFData) - --- the first argument, though phantom, affects representation --- CJP: why must the second arg be nominal? --- EAC: From https://ghc.haskell.org/trac/ghc/wiki/Roles#Thesolution: --- "The exception to the above algorithm is for classes: all parameters for a class default to a nominal role." --- Arr is a synonym for Array, which is an associated data type to the class Source. The parameter `r` above --- corresponds to the parameter `e` in the definition of class Source, so it's role must be nominal. -type role Arr nominal nominal - --- | An 'Arr' filled with the argument. -repl :: forall m r . (Fact m, Unbox r) => r -> Arr m r -repl = let n = proxy totientFact (Proxy::Proxy m) - in Arr . fromUnboxed (Z:.n) . U.replicate n - --- | Monadic version of 'repl'. -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 - -instance (Unbox r) => NFData (Array U DIM1 r) where - -- EAC: Repa doesn't define any NFData instances, - -- I'm hoping deepSeqArray is a reasonable approx - rnf x = deepSeqArray x () - -instance (Unbox r, Random r, Fact m) => Random (Arr m r) where - random = runRand $ replM (liftRand random) - - randomR = error "randomR nonsensical for Arr" - -instance (Arbitrary r, Unbox r, Fact m) => Arbitrary (Arr m r) where - arbitrary = replM arbitrary - shrink = shrinkNothing - --- | For a factored index, tensors up any function defined for (and --- tagged by) any prime power -fTensor :: forall m r mon . (Fact m, Monad mon, Unbox r) - => (forall pp . (PPow pp) => TaggedT pp mon (Trans r)) - -> TaggedT m mon (Trans r) - -fTensor func = tagT $ go $ sUnF (sing :: SFactored m) - where - go :: Sing (pplist :: [PrimePower]) -> mon (Trans r) - go spps = case spps of - SNil -> return $ Id 1 - (SCons spp rest) -> do - rest' <- go rest - func' <- withWitnessT func spp - return $ rest' @* func' - --- | For a prime power pp > 1, tensors up any function f defined for --- (and tagged by) a prime to (I_(pp/p) \otimes f) -ppTensor :: forall pp r mon . (PPow pp, Monad mon) - => (forall p . (NatC p) => TaggedT p mon (Trans r)) - -> TaggedT pp mon (Trans r) - -ppTensor func = tagT $ case (sing :: SPrimePower pp) of - -- intentionally no match for zero exponents, because that is - -- ill-formed and indicates an internal error - (SPP (STuple2 sp (SS se1))) -> do - func' <- withWitnessT func sp - let lts = withWitness valuePPow (SPP (STuple2 sp se1)) - return $ Id lts @* func' - - --- deeply embedded DSL for transformations and their various --- compositions - --- (dim(f), f) where f operates on innermost dimension of array -data Tensorable r = Tensorable - Int (forall rep . Source rep r => Array rep DIM2 r -> Array D DIM2 r) - --- transform component: a Tensorable with particular I_l, I_r -type TransC r = (Tensorable r, Int, Int) - --- full transform: sequence of zero or more components --- | a DSL for tensor transforms on Repa arrays -data Trans r = Id Int -- ^| identity sentinel - | TSnoc (Trans r) (TransC r) -- ^| (function) composition of transforms - -dimC :: TransC r -> Int -dimC (Tensorable d _, l, r) = l*d*r - --- | Returns the (linear) dimension of a transform -dim :: Trans r -> Int -dim (Id n) = n -dim (TSnoc _ f) = dimC f -- just use dimension of head - --- | smart constructor from a Tensorable -trans :: Int -> (forall rep . Source rep r => Array rep DIM2 r -> Array D DIM2 r) -> Trans r -trans d f = TSnoc (Id d) (Tensorable d f, 1, 1) - --- | compose transforms -(.*) :: Trans r -> Trans r -> Trans r -f .* g | dim f == dim g = f ..* g - | otherwise = error $ "(.*): transform dimensions don't match " - LP.++ show (dim f) LP.++ ", " LP.++ show (dim g) - where - f' ..* (Id _) = f' -- drop sentinel - f' ..* (TSnoc rest g') = TSnoc (f' ..* rest) g' - --- | tensor/Kronecker product (otimes) -(@*) :: Trans r -> Trans r -> Trans r --- merge identity transforms -(Id n) @* (Id m) = Id (n*m) --- Id on left or right -i@(Id n) @* (TSnoc g' (g, l, r)) = TSnoc (i @* g') (g, n*l, r) -(TSnoc f' (f, l, r)) @* i@(Id n) = TSnoc (f' @* i) (f, l, r*n) --- no Ids: compose -f @* g = (f @* Id (dim g)) .* (Id (dim f) @* g) - -evalC :: (Unbox r) => TransC r -> Array U DIM1 r -> Array U DIM1 r -evalC (Tensorable d f, _, r) arr = - arr `deepSeqArray` force $ unexpose r $ f $ expose d r arr - --- | Creates an evaluatable Haskell function from a tensored transform -eval :: (Unbox r) => Tagged m (Trans r) -> Arr m r -> Arr m r -eval x = coerce $ eval' $ untag x - where eval' (Id _) = id - eval' (TSnoc rest f) = eval' rest . evalC f - --- | 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 - - --- | maps the innermost dimension to a 2-dim array with innermost dim d, --- for performing a I_l \otimes f_d \otimes I_r transformation -expose !d !r !arr = - let (sh :. sz) = extent arr - f (s :. i :. j) = let imodr = i `mod` r - idx = (i-imodr)*d + j*r + imodr - in arr ! (s :. idx) - in fromFunction (sh :. sz `div` d :. d) f - --- | inverse of expose -unexpose !r !arr = - let (sh:.sz:.d) = extent arr - f (s :. i) = let (idivr,imodr) = i `divMod` r - (idivrd,j) = idivr `divMod` d - in arr ! (s :. r*idivrd + imodr :. j) - in fromFunction (sh :. sz*d) f - --- | general matrix multiplication along innermost dim of v -mulMat :: (Source r1 r, Source r2 r, Ring r, Unbox r, Elt r) - => Array r1 DIM2 r -> Array r2 DIM2 r -> Array D DIM2 r -mulMat !m !v - = let (Z :. mrows :. mcols) = extent m - (sh :. vrows) = extent v - f (sh' :. i) = sumAllS $ R.zipWith (*) (slice m (Z:.i:.All)) $ slice v (sh':.All) - in if mcols == vrows then fromFunction (sh :. mrows) f - else error "mulMatVec: mcols != vdim" - --- | 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 -mulDiag !diag !arr = fromFunction (extent arr) f - where f idx@(_ :. i) = arr! idx * diag! (Z:.i) - --- misc Tensor functions - --- | 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)) - where go n !r = let fct (Z:.0) = r - fct _ = LP.zero - in force $ fromFunction (Z:.n) fct - --- | Forces a delayed array to a manifest array. -force :: (Shape sh, Unbox r) => Array D sh r -> Array U sh r --- CJP: computeS just until we figure out how to avoid nested parallel --- computation! ---force = computeS -force = runIdentity . computeP - --- copied implementations of functions we need that normally require --- Num - --- | Sum the inner-most dimension of an array sequentially -sumS :: (Source r a, Elt a, Unbox a, Additive a, Shape sh) - => Array r (sh :. Int) a - -> Array U sh a -sumS = foldS (+) LP.zero - --- | Sum all array indices to a scalar sequentially -sumAllS :: (Shape sh, Source r a, Elt a, Unbox a, Additive a) - => Array r sh a - -> a -sumAllS = foldAllS (+) LP.zero diff --git a/src/Crypto/Lol/Cyclotomic/UCyc.hs b/src/Crypto/Lol/Cyclotomic/UCyc.hs deleted file mode 100644 --- a/src/Crypto/Lol/Cyclotomic/UCyc.hs +++ /dev/null @@ -1,700 +0,0 @@ -{-# LANGUAGE ConstraintKinds, DataKinds, DeriveDataTypeable, - FlexibleContexts, FlexibleInstances, GADTs, InstanceSigs, - MultiParamTypeClasses, NoImplicitPrelude, PolyKinds, - RankNTypes, RebindableSyntax, ScopedTypeVariables, - TypeFamilies, TypeOperators, UndecidableInstances #-} - --- | An implementation of cyclotomic rings. WARNING: this module --- provides an experts-only, "unsafe" interface that may result in --- runtime errors if not used correctly! --- 'Crypto.Lol.Cyclotomic.Cyc.Cyc' provides a safe interface, and --- should be used in applications whenever possible. --- --- 'UCyc' transparently handles all necessary conversions between --- internal representations to support fast ring operations, and --- efficiently stores and operates upon elements that are known to --- reside in subrings. --- --- The 'Functor', 'Applicative', 'Foldable', and 'Traversable' --- instances of 'UCyc', as well as the 'fmapC' and 'fmapCM' functions, --- work over the element's /current/ @r@-basis representation (or --- 'pure' scalar representation as a special case, to satisfy the --- 'Applicative' laws), and the output remains in that representation. --- If the input's representation is not one of these, the behavior is --- a runtime error. To ensure a valid representation when using the --- methods from these classes, first call 'forceBasis' or one of its --- specializations ('forcePow', 'forceDec', 'forceAny'). - -module Crypto.Lol.Cyclotomic.UCyc -( --- * Data type - UCyc, CElt, RElt --- * Basic operations -, mulG, divG -, scalarCyc, liftCyc -, adviseCRT --- * Error sampling -, tGaussian, errorRounded, errorCoset --- * Sub/extension rings -, embed, twace, coeffsCyc, powBasis, crtSet --- * Representations -, forceBasis, forcePow, forceDec, forceAny --- * Specialized maps -, fmapC, fmapCM -, U.Basis(..), U.RescaleCyc -) where - -import Crypto.Lol.CRTrans -import Crypto.Lol.Cyclotomic.Tensor as T -import qualified Crypto.Lol.Cyclotomic.Utility as U -import Crypto.Lol.Gadget -import Crypto.Lol.LatticePrelude as LP hiding ((*>)) -import Crypto.Lol.Types.FiniteField -import Crypto.Lol.Types.ZPP - -import Algebra.Additive as Additive (C) -import Algebra.Ring as Ring (C) -import Algebra.ZeroTestable as ZeroTestable (C) - -import Control.Applicative -import Control.DeepSeq -import Control.Monad.Identity -import Control.Monad.Random -import Data.Coerce -import Data.Foldable as F -import Data.Maybe -import Data.Traversable -import Data.Typeable -import Test.QuickCheck - ---import qualified Debug.Trace as DT - --- | A data type for representing cyclotomic rings such as @Z[zeta]@, --- @Zq[zeta]@, and @Q(zeta)@: @t@ is the 'Tensor' type for storing --- coefficients; @m@ is the cyclotomic index; @r@ is the base ring of --- the coefficients (e.g., @Z@, @Zq@). -data UCyc t (m :: Factored) r where - Pow :: !(t m r) -> UCyc t m r -- representation wrt powerful basis - Dec :: !(t m r) -> UCyc t m r -- decoding basis - - -- Invariant: use CRTr iff crtFuncs exists for (t m r); - -- otherwise use CRTe (because crtFuncs is guaranteed to exist for - -- (t m (CRTExt r)) - CRTr :: !(t m r) -> UCyc t m r -- wrt CRT basis over r, if it exists - CRTe :: !(t m (CRTExt r)) -> UCyc t m r -- wrt CRT basis over r-extension - - -- super-optimized storage of scalars - Scalar :: !r -> UCyc t m r - - -- optimized storage of subring elements - Sub :: (l `Divides` m) => !(UCyc t l r) -> UCyc t m r - - - --EAC: Consider this representation for product rings, but beware of combinatorial explosion of cases. - --Product :: !(UCyc t m a) -> !(UCyc t m b) -> UCyc t m (a,b) - deriving (Typeable) - --- | Shorthand for frequently reused constraints that are needed for --- change of basis. -type UCCtx t r = (Tensor t, RElt t r, RElt t (CRTExt r), CRTEmbed r) - --- | Collection of constraints need to work on most functions over a --- particular base ring @r@. -type RElt t r = (TElt t r, CRTrans r, IntegralDomain r, ZeroTestable r, NFData r) - --- | Shorthand for frequently reused constraints that are needed for --- most functions involving 'UCyc' and --- 'Crypto.Lol.Cyclotomic.Cyc.Cyc'. -type CElt t r = (Tensor t, RElt t r, RElt t (CRTExt r), - CRTEmbed r, Eq r, Random r) - --- | Same as 'Crypto.Lol.Cyclotomic.Cyc.scalarCyc', but for 'UCyc'. -scalarCyc :: (Fact m, CElt t a) => a -> UCyc t m a -scalarCyc = Scalar - --- Eq instance -instance (UCCtx t r, Fact m, Eq r) => Eq (UCyc t m r) where - -- handle same bases when fidelity allows (i.e., *not* CRTe basis) - (Scalar v1) == (Scalar v2) = v1 == v2 - (Pow v1) == (Pow v2) = v1 == v2 \\ witness entailEqT v1 - (Dec v1) == (Dec v2) = v1 == v2 \\ witness entailEqT v1 - (CRTr v1) == (CRTr v2) = v1 == v2 \\ witness entailEqT v1 - - -- compare in compositum - (Sub (c1 :: UCyc t l1 r)) == (Sub (c2 :: UCyc t l2 r)) = - (embed' c1 :: UCyc t (FLCM l1 l2) r) == embed' c2 - \\ lcmDivides (Proxy::Proxy l1) (Proxy::Proxy l2) - - -- otherwise compare in power basis for fidelity, which involves - -- the most efficient transforms in all cases - p1 == p2 = toPow' p1 == toPow' p2 - ----------- Numeric Prelude instances ---------- - --- ZeroTestable instance -instance (UCCtx t r, Fact m) => ZeroTestable.C (UCyc t m r) where - isZero (Scalar v) = isZero v - isZero (Pow v) = isZero v \\ witness entailZTT v - isZero (Dec v) = isZero v \\ witness entailZTT v - isZero (CRTr v) = isZero v \\ witness entailZTT v - isZero x@(CRTe _) = isZero $ toPow' x - isZero (Sub c) = isZero c - --- Additive instance -instance (UCCtx t r, Fact m) => Additive.C (UCyc t m r) where - - zero = Scalar zero - - -- optimized addition of zero - (Scalar c1) + v2 | isZero c1 = v2 - v1 + (Scalar c2) | isZero c2 = v1 - - -- SAME CONSTRUCTORS - (Scalar c1) + (Scalar c2) = Scalar (c1+c2) - (Pow v1) + (Pow v2) = Pow $ v1 + v2 \\ witness entailRingT v1 - (Dec v1) + (Dec v2) = Dec $ v1 + v2 \\ witness entailRingT v1 - (CRTr v1) + (CRTr v2) = CRTr $ v1 + v2 \\ witness entailRingT v1 - (CRTe v1) + (CRTe v2) = CRTe $ v1 + v2 \\ witness entailRingT v1 - -- Sub plus Sub: work in compositum - (Sub (c1 :: UCyc t m1 r)) + (Sub (c2 :: UCyc t m2 r)) = - (Sub $ (embed' c1 :: UCyc t (FLCM m1 m2) r) + embed' c2) - \\ lcm2Divides (Proxy::Proxy m1) (Proxy::Proxy m2) (Proxy::Proxy m) - - -- SCALAR PLUS SOMETHING ELSE - - p1@(Scalar _) + p2@(Pow _) = toPow' p1 + p2 - p1@(Scalar _) + p2@(Dec _) = toDec' p1 + p2 - p1@(Scalar _) + p2@(CRTr _) = toCRT' p1 + p2 - p1@(Scalar _) + p2@(CRTe _) = toCRT' p1 + p2 - (Scalar c1) + (Sub c2) = Sub $ Scalar c1 + c2 -- must re-wrap Scalar! - - p1@(Pow _) + p2@(Scalar _) = p1 + toPow' p2 - p1@(Dec _) + p2@(Scalar _) = p1 + toDec' p2 - p1@(CRTr _) + p2@(Scalar _) = p1 + toCRT' p2 - p1@(CRTe _) + p2@(Scalar _) = p1 + toCRT' p2 - (Sub c1) + (Scalar c2) = Sub $ c1 + Scalar c2 - - -- SUB PLUS NON-SUB, NON-SCALAR: work in full ring - (Sub c1) + c2 = embed' c1 + c2 - c1 + (Sub c2) = c1 + embed' c2 - - -- mixed Dec and Pow: use linear time conversions - p1@(Dec _) + p2@(Pow _) = toPow' p1 + p2 - p1@(Pow _) + p2@(Dec _) = p1 + toPow' p2 - - -- one CRTr: convert other to CRTr - p1@(CRTr _) + p2 = p1 + toCRT' p2 - p1 + p2@(CRTr _) = toCRT' p1 + p2 - - -- else, one is CRTe: convert both to Pow for fidelity and best - -- efficiency - p1 + p2 = toPow' p1 + toPow' p2 - - negate (Scalar c) = Scalar (negate c) - negate (Pow v) = Pow $ fmapT negate v - negate (Dec v) = Dec $ fmapT negate v - negate (CRTr v) = CRTr $ fmapT negate v - negate (CRTe v) = CRTe $ fmapT negate v - negate (Sub c) = Sub $ negate c - --- Ring instance -instance (UCCtx t r, Fact m) => Ring.C (UCyc t m r) where - - one = Scalar one - - -- optimized mul-by-zero - v1@(Scalar c1) * _ | isZero c1 = v1 - _ * v2@(Scalar c2) | isZero c2 = v2 - - -- BOTH IN A CRT BASIS - (CRTr v1) * (CRTr v2) = CRTr $ v1 * v2 \\ witness entailRingT v1 - (CRTe v1) * (CRTe v2) = toPow' $ CRTe $ v1 * v2 \\ witness entailRingT v1 - - -- CRTr/CRTe mixture - (CRTr _) * (CRTe _) = error "UCyc.(*): mixed CRTr/CRTe" - (CRTe _) * (CRTr _) = error "UCyc.(*): mixed CRTr/CRTe" - - -- AT LEAST ONE SCALAR - (Scalar c1) * (Scalar c2) = Scalar $ c1 * c2 - - (Scalar c) * (Pow v) = Pow $ fmapT (*c) v - (Scalar c) * (Dec v) = Dec $ fmapT (*c) v - (Scalar c) * (CRTr v) = CRTr $ fmapT (*c) v - (Scalar c) * (CRTe v) = CRTe $ fmapT (* toExt c) v - (Scalar c1) * (Sub c2) = Sub $ Scalar c1 * c2 - - (Pow v) * (Scalar c) = Pow $ fmapT (*c) v - (Dec v) * (Scalar c) = Dec $ fmapT (*c) v - (CRTr v) * (Scalar c) = CRTr $ fmapT (*c) v - (CRTe v) * (Scalar c) = CRTe $ fmapT (* toExt c) v - (Sub c1) * (Scalar c2) = Sub $ c1 * Scalar c2 - - -- TWO SUBS: work in a CRT rep for compositum - (Sub (c1 :: UCyc t m1 r)) * (Sub (c2 :: UCyc t m2 r)) = - -- re-wrap c1, c2 as Subs of the composition, and force them to CRT - (Sub $ (toCRT' $ Sub c1 :: UCyc t (FLCM m1 m2) r) * toCRT' (Sub c2)) - \\ lcm2Divides (Proxy::Proxy m1) (Proxy::Proxy m2) (Proxy::Proxy m) - - -- ELSE: work in appropriate CRT rep - p1 * p2 = toCRT' p1 * toCRT' p2 - - fromInteger = Scalar . fromInteger - --- reduces in any basis -instance (Reduce a b, Fact m, CElt t a, CElt t b) - => Reduce (UCyc t m a) (UCyc t m b) where - - -- optimized for subring constructors - reduce (Scalar c) = Scalar $ reduce c - reduce (Sub (c :: UCyc t l a)) = Sub (reduce c :: UCyc t l b) - reduce x = fmapC reduce $ forceAny x - --- promote Gadget from base ring -instance (Gadget gad zq, Fact m, CElt t zq) => Gadget gad (UCyc t m zq) where - gadget = (scalarCyc <$>) <$> gadget - -- specialization of 'encode', done efficiently (via 'adviseCRT'). - encode s = ((* adviseCRT s) <$>) <$> gadget - --- promote Decompose, using the powerful basis -instance (Decompose gad zq, Fact m, - -- these imply (superclass) Reduce on UCyc; needed for Sub case - CElt t zq, CElt t (DecompOf zq), Reduce (DecompOf zq) zq) - => Decompose gad (UCyc t m zq) where - - type DecompOf (UCyc t m zq) = UCyc t m (DecompOf zq) - - -- faster implementations: decompose directly in subring, which is - -- correct because we decompose in powerful basis - decompose (Scalar c) = pasteT $ Scalar <$> peelT (decompose c) - decompose (Sub c) = pasteT $ Sub <$> peelT (decompose c) - - -- traverse: Traversable (c m) and Applicative (Tagged gad ZL) - decompose x = fromZL $ traverse (toZL . decompose) $ forcePow x - where toZL :: Tagged s [a] -> TaggedT s ZipList a - toZL = coerce - fromZL :: TaggedT s ZipList a -> Tagged s [a] - fromZL = coerce - --- promote Correct, using the decoding basis -instance (Correct gad zq, Fact m, CElt t zq) - => Correct gad (UCyc t m zq) where - -- sequenceA: Applicative (c m) and Traversable (TaggedT []) - correct bs = (correct . pasteT) <$> sequenceA (forceDec <$> peelT bs) - --- generic RescaleCyc instance - -instance {-# OVERLAPS #-} (Rescale a b, CElt t a, CElt t b) - => U.RescaleCyc (UCyc t) a b where - - -- Optimized for subring constructors, for powerful basis. - -- Analogs for decoding basis are not quite correct, because (* -1) - -- doesn't commute with 'rescale' due to tiebreakers! - rescaleCyc U.Pow (Scalar c) = Scalar $ rescale c - rescaleCyc U.Pow (Sub (c :: UCyc t l a)) = - Sub (U.rescaleCyc U.Pow c :: UCyc t l b) - - rescaleCyc b x = fmapC rescale $ forceBasis (Just b) x - --- specialized instance for product rings: ~2x faster algorithm -instance (Mod a, Field b, Lift a (ModRep a), Reduce (LiftOf a) b, - CElt t a, CElt t b, CElt t (a,b), CElt t (LiftOf a)) - => U.RescaleCyc (UCyc t) (a,b) b where - - -- optimized for subrings and powerful basis (see comments in other - -- instance for why this doesn't work for decoding basis) - rescaleCyc U.Pow (Scalar c) = Scalar $ rescale c - rescaleCyc U.Pow (Sub (c :: UCyc t l (a,b))) = - Sub (U.rescaleCyc U.Pow c :: UCyc t l b) - - rescaleCyc bas x = - let aval = proxy modulus (Proxy::Proxy a) - -- CJP: could use unzipC here to get (a,b) in one pass, but it - -- requires adding that method, and unzipT to Tensor and all its - -- instances. Probably not worth it. - y = forceAny x - a = fmapC fst y - b = fmapC snd y - z = liftCyc bas a - in Scalar (recip (reduce aval)) * (b - reduce z) - --- | Same as 'Crypto.Lol.Cyclotomic.Cyc.liftCyc', but for 'UCyc'. -liftCyc :: (Lift b a, Fact m, CElt t a, CElt t b) - => U.Basis -> UCyc t m b -> UCyc t m a --- optimized for subrings and powerful basis (see comments in --- RescaleCyc instances for why this doesn't work for decoding) -liftCyc U.Pow (Scalar c) = Scalar $ lift c -liftCyc U.Pow (Sub c) = Sub $ liftCyc U.Pow c - -liftCyc U.Pow x = fmapC lift $ forceBasis (Just U.Pow) x -liftCyc U.Dec x = fmapC lift $ forceBasis (Just U.Dec) x - --- | Same as 'Crypto.Lol.Cyclotomic.Cyc.adviseCRT', but for 'UCyc'. -adviseCRT :: (Fact m, CElt t r) => UCyc t m r -> UCyc t m r -adviseCRT x@(Scalar _) = x -adviseCRT (Sub c) = Sub $ adviseCRT c -adviseCRT x = toCRT' x - --- | Same as 'Crypto.Lol.Cyclotomic.Cyc.mulG', but for 'UCyc'. -mulG :: (Fact m, CElt t r) => UCyc t m r -> UCyc t m r -mulG (Scalar c) = Pow $ mulGPow $ scalarPow c -- must go to full ring -mulG (Sub c) = mulG $ embed' c -- must go to full ring -mulG (Pow v) = Pow $ mulGPow v -mulG (Dec v) = Dec $ mulGDec v --- fromMaybe 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 - --- | Same as 'Crypto.Lol.Cyclotomic.Cyc.divG', but for 'UCyc'. -divG :: (Fact m, CElt t r) => UCyc t m r -> Maybe (UCyc t m r) -divG (Scalar c) = liftM Pow (divGPow $ scalarPow c) -- full ring -divG (Sub c) = divG $ embed' c -- full ring -divG (Pow v) = Pow <$> divGPow v -divG (Dec v) = Dec <$> divGDec v --- fromMaybe is safe 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 - --- | Same as 'Crypto.Lol.Cyclotomic.Cyc.tGaussian', but for 'UCyc'. -tGaussian :: (Fact m, OrdFloat q, Random q, CElt t q, - ToRational v, MonadRandom rnd) - => v -> rnd (UCyc t m q) -tGaussian = liftM Dec . tGaussianDec - --- | Same as 'Crypto.Lol.Cyclotomic.Cyc.errorRounded', but for 'UCyc'. -errorRounded :: forall v rnd t m z . - (ToInteger z, Fact m, CElt t z, ToRational v, MonadRandom rnd) - => v -> rnd (UCyc t m z) -errorRounded svar = - fmapC (roundMult one) <$> (tGaussian svar :: rnd (UCyc t m Double)) - --- | Same as 'Crypto.Lol.Cyclotomic.Cyc.errorCoset', but for 'UCyc'. -errorCoset :: forall t m zp z v rnd . - (Mod zp, z ~ ModRep zp, Lift zp z, Fact m, - CElt t zp, CElt t z, ToRational v, MonadRandom rnd) - => v -> UCyc t m zp -> rnd (UCyc t m z) -errorCoset = - let pval = fromIntegral $ proxy modulus (Proxy::Proxy zp) - -- we don't force* here because tGaussian is always in Dec - in \ svar c -> - roundCosetDec c <$> (tGaussian (svar * pval * pval) :: rnd (UCyc t m Double)) - --- | Deterministically round to the given coset @c+pR@, using the --- decoding basis. -roundCosetDec :: - (Mod zp, z ~ ModRep zp, Lift zp z, RealField q, - Fact m, CElt t q, CElt t zp, CElt t z) - => UCyc t m zp -> UCyc t m q -> UCyc t m z -roundCosetDec c x = roundCoset <$> forceDec c <*> forceDec x - --- | Same as 'Crypto.Lol.Cyclotomic.Cyc.embed', but for 'UCyc'. -embed :: forall t r m m' . (m `Divides` m') => UCyc t m r -> UCyc t m' r -embed (Scalar c) = Scalar c -embed (Sub (c :: UCyc t l r)) = Sub c - \\ transDivides (Proxy::Proxy l) (Proxy::Proxy m) (Proxy::Proxy m') -embed c = Sub c - --- | Same as 'Crypto.Lol.Cyclotomic.Cyc.twace', but for 'UCyc'. -twace :: forall t r m m' . (UCCtx t r, m `Divides` m') - => UCyc t m' r -> UCyc t m r -twace (Scalar c) = Scalar c --- twace on Sub goes to the largest common subring of O_l and O_m -twace (Sub (c :: UCyc t l r)) = - Sub (twace c :: UCyc t (FGCD l m) r) - \\ gcdDivides (Proxy::Proxy l) (Proxy::Proxy m) -twace (Pow v) = Pow $ twacePowDec v -twace (Dec v) = Dec $ twacePowDec v --- stay in CRTr only iff it's valid for target, else go to Pow -twace x@(CRTr v) = - fromMaybe (twace $ toPow' x) (CRTr <$> (twaceCRT <*> pure v)) --- stay in CRTe iff CRTr is invalid for target, else go to Pow -twace x@(CRTe v) = - fromMaybe (CRTe $ fromJust' "UCyc.twace CRTe" twaceCRT v) - (proxy (pasteT hasCRTFuncs) (Proxy::Proxy (t m r)) *> - pure (twace $ toPow' x)) - --- | Same as 'Crypto.Lol.Cyclotomic.Cyc.coeffsCyc', but for 'UCyc'. -coeffsCyc :: (m `Divides` m', CElt t r) - => U.Basis -> UCyc t m' r -> [UCyc t m r] -coeffsCyc U.Pow (Pow v) = LP.map Pow $ coeffs v -coeffsCyc U.Dec (Dec v) = LP.map Dec $ coeffs v -coeffsCyc U.Pow x = coeffsCyc U.Pow $ toPow' x -coeffsCyc U.Dec x = coeffsCyc U.Dec $ toDec' x - --- | Same as 'Crypto.Lol.Cyclotomic.Cyc.powBasis', but for 'UCyc'. -powBasis :: (m `Divides` m', CElt t r) => Tagged m [UCyc t m' r] -powBasis = map Pow <$> powBasisPow - --- | Same as 'Crypto.Lol.Cyclotomic.Cyc.crtSet', but for 'UCyc'. -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', - CElt t r, CElt t (ZPOf r)) - => Tagged m [UCyc t m' r] -crtSet = - -- CJP: consider using traceEvent or traceMarker - --DT.trace ("UCyc.fcCrtSet: m = " ++ - -- show (proxy valueFact (Proxy::Proxy m)) ++ ", m'= " ++ - -- show (proxy valueFact (Proxy::Proxy m'))) $ - let (p,e) = proxy modulusZPP (Proxy::Proxy r) - pp = Proxy::Proxy p - pm = Proxy::Proxy m - pm' = Proxy::Proxy m' - in retag (fmap (embed . (^(p^(e-1))) . Dec . fmapT liftZp) <$> - (crtSetDec :: Tagged mbar [t m'bar (ZPOf r)])) - \\ pFreeDivides pp pm pm' - \\ pSplitTheorems pp pm \\ pSplitTheorems pp pm' - ------ "Unsafe" functions that expose or rely upon internal representation - --- | Yield an equivalent element whose internal representation /must/ --- be in the indicated basis: powerful or decoding (for 'Just' 'Pow' --- and 'Just' 'Dec' arguments, respectively), or any @r@-basis of the --- implementation's choice (for 'Nothing' argument). (See also the --- convenient specializations 'forcePow', 'forceDec', 'forceAny'.) -forceBasis :: (Fact m, CElt t r) => Maybe U.Basis -> UCyc t m r -> UCyc t m r -forceBasis (Just U.Pow) x = toPow' x -forceBasis (Just U.Dec) x = toDec' x -forceBasis Nothing x@(Scalar _) = toPow' x --- force as outermost op to ensure we get an r-basis -forceBasis Nothing (Sub c) = forceBasis Nothing $ embed' c -forceBasis Nothing x@(CRTe _) = toPow' x -forceBasis Nothing x = x - -forcePow, forceDec, forceAny :: (Fact m, CElt t r) => UCyc t m r -> UCyc t m r --- | Force a cyclotomic element into the powerful basis. -forcePow = forceBasis (Just U.Pow) --- | Force a cyclotomic element into the decoding basis. -forceDec = forceBasis (Just U.Dec) --- | Force a cyclotomic into any @r@-basis of the implementation's --- choice. -forceAny = forceBasis Nothing - --- | A more specialized version of 'fmap': apply a function --- coordinate-wise in the current representation. The caller must --- ensure that the current representation is an @r@-basis (one of --- powerful, decoding, or CRT, if it exists), usually by using --- 'forceBasis' or its specializations ('forcePow', 'forceDec', --- 'forceAny'). Otherwise, behavior is undefined. -fmapC :: (Fact m, CElt t a, CElt t b) => (a -> b) -> UCyc t m a -> UCyc t m b - --- must be in an r-basis for correct semantics, e.g., f 0 = 1 -fmapC _ (Scalar _) = error "can't fmapC on Scalar. Must forceBasis first!" -fmapC _ (Sub _) = error "can't fmapC on Sub. Must forceBasis first!" -fmapC _ (CRTe _) = error "can't fmapC on CRTe. Must forceBasis first!" - -fmapC f (Pow v) = Pow $ fmapT f v -fmapC f (Dec v) = Dec $ fmapT f v -fmapC f (CRTr v) = CRTr $ fmapT f v - --- | Monadic version of 'fmapC'. -fmapCM :: (Fact m, CElt t a, CElt t b, Monad mon) - => (a -> mon b) -> UCyc t m a -> mon (UCyc t m b) - --- must embed into full ring -fmapCM _ (Scalar _) = error "can't fmapCM on Scalar. Must forceBasis first!" -fmapCM _ (Sub _) = error "can't fmapCM on Sub. Must forceBasis first!" -fmapCM _ (CRTe _) = error "can't fmapCM on CRTe. Must forceBasis first!" - -fmapCM f (Pow v) = liftM Pow $ fmapTM f v -fmapCM f (Dec v) = liftM Dec $ fmapTM f v -fmapCM f (CRTr v) = liftM CRTr $ fmapTM f v - - - - ----------- HELPER FUNCTIONS (NOT FOR EXPORT) ---------- - --- | Force embed, to a non-'Sub' constructor. Preserves Scalar, Pow, --- Dec constructors, and CRTr/CRTe constructor if valid in both source --- and target ring (we rely on this in toCRT'). -embed' :: forall t r l m . - (UCCtx t r, l `Divides` m) => UCyc t l r -> UCyc t m r -embed' (Scalar x) = Scalar x -- must re-wrap! -embed' (Pow v) = Pow $ embedPow v -embed' (Dec v) = Dec $ embedDec v --- stay in CRTr only if it's possible, otherwise go to Pow -embed' x@(CRTr v) = - fromMaybe (embed' $ toPow' x) (CRTr <$> (embedCRT <*> pure v)) -embed' x@(CRTe v) = -- go to CRTe iff CRTr is invalid for target index - fromMaybe (CRTe $ fromJust' "UCyc.embed' CRTe" embedCRT v) - (proxy (pasteT hasCRTFuncs) (Proxy::Proxy (t m r)) *> - pure (embed' $ toPow' x)) -embed' (Sub (c :: UCyc t k r)) = embed' c - \\ transDivides (Proxy::Proxy k) (Proxy::Proxy l) (Proxy::Proxy m) - - ---------- Basis conversion methods ------------------ - -toPow', toDec' :: (UCCtx t r, Fact m) => UCyc t m r -> UCyc t m r --- forces the argument into the powerful basis -toPow' (Scalar c) = Pow $ scalarPow c -toPow' (Sub c) = embed' $ toPow' c -- OK: embed' preserves Pow -toPow' x@(Pow _) = x -toPow' (Dec v) = Pow $ l v -toPow' (CRTr v) = Pow $ fromJust' "UCyc.toPow'" crtInv v -toPow' (CRTe v) = - Pow $ fmapT fromExt $ fromJust' "UCyc.toPow' CRTe" crtInv v - --- | Force the argument into the decoding basis. -toDec' x@(Scalar _) = toDec' $ toPow' x -- TODO: use scalarDec instead -toDec' (Sub c) = embed' $ toDec' c -- OK: embed' preserves Dec -toDec' (Pow v) = Dec $ lInv v -toDec' x@(Dec _) = x -toDec' x@(CRTr _) = toDec' $ toPow' x -toDec' x@(CRTe _) = toDec' $ toPow' x - --- | Force the argument into the "valid" CRT basis for our invariant. -toCRT' :: forall t m r . (UCCtx t r, Fact m) => UCyc t m r -> UCyc t m r -toCRT' x@(CRTr _) = x -toCRT' x@(CRTe _) = x -toCRT' (Sub (c :: UCyc t l r)) = - case (proxyT hasCRTFuncs (Proxy::Proxy (t l r)), - proxyT hasCRTFuncs (Proxy::Proxy (t m r))) of - (Just _, Just _) -> embed' $ toCRT' c -- fastest; embed' preserves CRTr - (_, Nothing) -> embed' $ toCRTe c -- faster; temp violate CRTr/e invariant - _ -> toCRT' $ embed' c -- fallback -toCRT' x = fromMaybe (toCRTe x) (toCRTr <*> pure x) - -toCRTr :: forall t m r . (UCCtx t r, Fact m) => Maybe (UCyc t m r -> UCyc t m r) -toCRTr = do -- Maybe monad - crt' <- crt - scalarCRT' <- scalarCRT - return $ \x -> case x of - (Scalar c) -> CRTr $ scalarCRT' c - (Pow v) -> CRTr $ crt' v - (Dec v) -> CRTr $ crt' $ l v - c@(CRTr _) -> c - c@(CRTe _) -> fromJust' "UCyc.toCRTr CRTe" toCRTr $ toPow' c - (Sub _) -> error "UCyc.toCRTr: Sub" - -toCRTe :: forall t m r . (UCCtx t r, Fact m) => UCyc t m r -> UCyc t m r -toCRTe = let m = proxy valueFact (Proxy::Proxy m) - crt' = fromJust' ("UCyc.toCRTe: no crt': " ++ show m) crt - :: t m (CRTExt r) -> t m (CRTExt r) -- must exist - scalarCRT' = fromJust' "UCyc.toCRTe: no scalarCRT" scalarCRT - :: CRTExt r -> t m (CRTExt r) - in \x -> case x of - (Scalar c) -> CRTe $ scalarCRT' $ toExt c - (Pow v) -> CRTe $ crt' $ fmapT toExt v - (Dec v) -> CRTe $ crt' $ fmapT toExt $ l v - c@(CRTr _) -> toCRTe $ toPow' c - c@(CRTe _) -> c - (Sub _) -> error "UCyc.toCRTe: Sub" - ----------- "Container" instances ---------- - -instance (Tensor t, Fact m) => Functor (UCyc t m) where - -- Functor instance is implied by Applicative laws - fmap f x = pure f <*> x - -errApp :: String -> a -errApp name = error $ "UCyc.Applicative: can't/won't handle " ++ name ++ - "; call forcePow|Dec|Any first" - -instance (Tensor t, Fact m) => Applicative (UCyc t m) where - - -- This implementation is restricted to the Scalar, Pow, Dec, or - -- CRTr constructors, in order to force the client to choose a - -- concrete @r@-basis and avoid unanticipated non-failure behavior. - -- Encountering a CRTe, or Sub constructor almost certainly means - -- that the client expressed something it did not intend (since it - -- cannot force such constructors to be used), so we want to raise - -- an exception early instead of doing unintended work. - - -- This implementation has one corner case that may - -- yield unexpected non-failure behavior: consider - -- fmap f (pure a) = (pure f) <*> (pure a) = (pure $ f a) - -- which is required by the Applicative homomorphism law. - - -- If the (pure a) is intended as an element of the base ring (which - -- is the custom), then its Pow coeffs are *not* all a's, so the - -- (likely intended) expression - -- fmap f $ forcePow (pure a) - -- may be a different result. If the client forgets the force, we - -- can't recognize it here and throw an error. (This is certainly the - -- client's fault; if it's not specifying a basis before fmap'ing - -- then it shouldn't expect the results to make sense. We just - -- can't catch the error here.) - - -- A solution is to introduce an explicit Pure constructor that's - -- only ever applied in 'pure', and throw an error if we encounter a - -- Scalar here. Arithmetically we'd treat Pures as Scalars, but in - -- a one-way fashion (outputs of arith ops are never Pure). - - pure = Scalar - - -- homomorphism (of pure) - (Scalar f) <*> (Scalar a) = Scalar $ f a - - -- constructors must match - (Pow v1) <*> (Pow v2) = Pow $ v1 <*> v2 \\ witness entailIndexT v1 - (Dec v1) <*> (Dec v2) = Dec $ v1 <*> v2 \\ witness entailIndexT v1 - (CRTr v1) <*> (CRTr v2) = CRTr $ v1 <*> v2 \\ witness entailIndexT v1 - - -- ... but we can also match Scalar with (almost) anything - (Scalar f) <*> (Pow v) = Pow $ pure f <*> v \\ witness entailIndexT v - (Scalar f) <*> (Dec v) = Dec $ pure f <*> v \\ witness entailIndexT v - (Scalar f) <*> (CRTr v) = CRTr $ pure f <*> v \\ witness entailIndexT v - - (Pow v) <*> (Scalar a) = Pow $ v <*> pure a \\ witness entailIndexT v - (Dec v) <*> (Scalar a) = Dec $ v <*> pure a \\ witness entailIndexT v - (CRTr v) <*> (Scalar a) = CRTr $ v <*> pure a \\ witness entailIndexT v - - -- cases we can't/won't handle - (Sub _) <*> _ = errApp "Sub" - _ <*> (Sub _) = errApp "Sub" - (CRTe _) <*> _ = errApp "CRTe" - _ <*> (CRTe _) = errApp "CRTe" - _ <*> _ = errApp "mismatched Pow/Dec/CRTr bases" - -instance (Tensor t, Fact m) => Foldable (UCyc t m) where - foldr f b (Scalar r) = f r b - foldr f b (Sub c) = F.foldr f b c - foldr f b (Pow v) = F.foldr f b v \\ witness entailIndexT v - foldr f b (Dec v) = F.foldr f b v \\ witness entailIndexT v - foldr f b (CRTr v) = F.foldr f b v \\ witness entailIndexT v - foldr _ _ (CRTe _) = error "UCyc.Foldable: can't handle CRTe" - -instance (Tensor t, Fact m) => Traversable (UCyc t m) where - traverse f (Scalar r) = Scalar <$> f r - traverse f (Sub c) = Sub <$> traverse f c - traverse f (Pow v) = Pow <$> traverse f v \\ witness entailIndexT v - traverse f (Dec v) = Dec <$> traverse f v \\ witness entailIndexT v - traverse f (CRTr v) = CRTr <$> traverse f v \\ witness entailIndexT v - traverse _ (CRTe _) = error "UCyc.Traversable: can't handle CRTe" - ----------- Utility instances ---------- - -instance (Tensor t, Fact m, TElt t r, CRTrans r, Random r, ZeroTestable r, IntegralDomain r) => Random (UCyc t m r) where - - -- create in CRTr basis if legal, otherwise in powerful - random = let cons = fromMaybe Pow - (proxyT hasCRTFuncs (Proxy::Proxy (t m r)) >> Just CRTr) - in \g -> let (v,g') = random g - \\ proxy entailRandomT (Proxy::Proxy (t m r)) - in (cons v, g') - - randomR _ = error "randomR non-sensical for cyclotomic rings" - -instance (Show r, Show (t m r), Show (t m (CRTExt r))) - => Show (UCyc t m r) where - - show (Scalar c) = "scalar " ++ show c - show (Sub _) = "subring (not showing due to missing constraints)" - show (Pow v) = "powerful basis coeffs " ++ show v - show (Dec v) = "decoding basis coeffs " ++ show v - show (CRTr v) = "CRTr basis coeffs " ++ show v - show (CRTe v) = "CRTe basis coeffs " ++ show v - -instance (Arbitrary (t m r)) => Arbitrary (UCyc t m r) where - arbitrary = liftM Pow arbitrary - shrink = shrinkNothing - -instance (Tensor t, Fact m, TElt t r, TElt t (CRTExt r), NFData r, NFData (CRTExt r)) - => NFData (UCyc t m 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 (Scalar x) = rnf x - rnf (Sub x) = rnf x diff --git a/src/Crypto/Lol/Cyclotomic/Utility.hs b/src/Crypto/Lol/Cyclotomic/Utility.hs deleted file mode 100644 --- a/src/Crypto/Lol/Cyclotomic/Utility.hs +++ /dev/null @@ -1,22 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} - -module Crypto.Lol.Cyclotomic.Utility where - -import Crypto.Lol.Factored - -import Control.DeepSeq - --- | Represents the powerful or decoding basis. -data Basis = Pow | Dec - -instance NFData Basis where - rnf Pow = () - rnf 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/src/Crypto/Lol/Factored.hs b/src/Crypto/Lol/Factored.hs deleted file mode 100644 --- a/src/Crypto/Lol/Factored.hs +++ /dev/null @@ -1,481 +0,0 @@ -{-# LANGUAGE ConstraintKinds, DataKinds, - GADTs, KindSignatures, PolyKinds, - ScopedTypeVariables, TemplateHaskell, TypeFamilies, - TypeOperators, UndecidableInstances #-} - --- | This file defines types and operations for type-level --- representation and manipulation of factored integers. It relies on --- TH, so the documentation will be difficult to read. See comments --- for better documentation. - -module Crypto.Lol.Factored -( --- * Factored natural numbers - Factored(..), SFactored, Fact --- * Prime powers -, PrimePower(..), SPrimePower, PPow, Sing (SPP) --- * Naturals -, Nat, NatC, PrimeNat, Prime --- * Constructors -, toPP, sToPP, ToPP, ppToF, sPpToF, PpToF, PToF --- * Unwrappers -, unF, sUnF, UnF, unPP, sUnPP, UnPP, primePP, PrimePP, exponentPP, ExponentPP --- * Arithmetic operations -, fPPMul, FPPMul, fMul, FMul, type (*) -, fDivides, FDivides, Divides, fDiv, FDiv, type (/) -, fGCD, FGCD, fLCM, FLCM, Coprime -, fOddRadical, FOddRadical -, pFree, PFree --- * Reflections -, ppsFact, valueFact, totientFact, valueHatFact, radicalFact, oddRadicalFact -, ppPPow, primePPow, exponentPPow, valuePPow, totientPPow -, valueNatC --- * Number-theoretic laws -, transDivides, gcdDivides, lcmDivides, lcm2Divides -, pSplitTheorems, pFreeDivides -, (\\) -- re-export from Data.Constraint for convenience --- * Utility operations (on prime powers) -, valueHat -, PP, ppToPP, valuePP, totientPP, radicalPP, oddRadicalPP -, valuePPs, totientPPs, radicalPPs, oddRadicalPPs --- * Type synonyms (not type families) -, F1, F2, F3, F4, F5, F6, F7, F8, F9, F10 -, F11, F12, F13, F14, F15, F16, F17, F18, F19, F20 -, F21, F22, F24, F25, F26, F27, F28, F30 -, F32, F33, F34, F35, F36, F38, F39 -, F40, F42, F44, F45, F48, F49 -, F50, F51, F52, F54, F55, F56, F57 -, F60, F63, F64, F65, F66, F68 -, F70, F72, F75, F76, F77, F78, F80, F81, F84, F85, F88 -, F90, F91, F95, F96, F98, F99 -, F128, F256, F512, F1024, F2048 -) where - -import Data.Constraint hiding ((***)) -import Data.Functor.Trans.Tagged -import Data.Singletons.Prelude hiding (sMin, sMax, MinSym0, MaxSym0, (:-)) -import Data.Singletons.TH -import Data.Type.Natural as N hiding ((:-)) -import Data.Typeable - -import Control.Arrow ((***)) -import Unsafe.Coerce - --- | Copied from Data.Type.Natural because the data-level version --- is not exported there. -(<<=) :: Nat -> Nat -> Bool -Z <<= _ = True -S _ <<= Z = False -S n <<= S m = n <<= m - -singletons [d| - - -- Invariant: first component is prime, second component - -- (the exponent) is positive (nonzero) - newtype PrimePower = PP (Nat,Nat) deriving (Eq,Show,Typeable) - - -- List invariant: primes appear in strictly increasing - -- order (no duplicates) - newtype Factored = F [PrimePower] deriving (Eq,Show,Typeable) - - -- unwrap 'Factored' - unF :: Factored -> [PrimePower] - unF (F pps) = pps - - -- unwrap 'PrimePower' - unPP :: PrimePower -> (Nat,Nat) - unPP (PP pp) = pp - - -- grab individual components of a 'PrimePower' - primePP, exponentPP :: PrimePower -> Nat - primePP = fst . unPP - exponentPP = snd . unPP - - |] - --- SMART CONSTRUCTORS -singletons [d| - - fPPMul :: PrimePower -> Factored -> Factored - fMul :: Factored -> Factored -> Factored - - -- constructor implementations - -- multiply a new 'PrimePower' into a 'Factored' number - fPPMul (PP(_,Z)) y = y -- throw away trivial prime power - fPPMul pp@(PP(_,S _)) (F pps) = F (ppMul pp pps) - - -- multiply two 'Factored' numbers - fMul (F pps1) (F pps2) = F (ppsMul pps1 pps2) - - -- helper functions (not for export) - - -- keeps primes in sorted order; merges duplicates - - -- EAC: Singletons(?) doesn't play well with pattern synonyms (e.g. x@(PP(p,e))) - -- when compiling with -O2 - -- reported as #10924 - -- singletons-2.0 doesn't work well with guards: https://github.com/goldfirere/singletons/issues/131 - ppMul :: PrimePower -> [PrimePower] -> [PrimePower] - ppMul x [] = [x] - ppMul (PP(p,e)) (PP (p',e'):pps') = - if p == p' then PP(p,e + e'):pps' - else if p <<= p' then (PP(p,e)):(PP (p',e'):pps') - else (PP(p',e')):ppMul (PP(p,e)) pps' - - ppsMul :: [PrimePower] -> [PrimePower] -> [PrimePower] - ppsMul [] ys = ys - ppsMul (pp:pps) ys = ppsMul pps (ppMul pp ys) - - |] - --- ARITHMETIC OPERATIONS -singletons [d| - -- Smart constructor that checks that the first arg is - -- prime (< 20) and the second arg is positive - toPP :: Nat -> Nat -> PrimePower - toPP p e | primeNat p && (n1 <<= e) = PP (p,e) - - -- EAC: isn't there a singletons promotion for 'F' - -- that could replace this function? - ppToF :: PrimePower -> Factored - ppToF pp = F [pp] - - primeToF :: Nat -> Factored - primeToF p | primeNat p = ppToF $ PP (p, n1) - - fGCD, fLCM :: Factored -> Factored -> Factored - fDivides :: Factored -> Factored -> Bool - fDiv :: Factored -> Factored -> Factored - fOddRadical :: Factored -> Factored - - -- can't pattern-match on n*, but can test equality - primeNat n - | n==n2 = True - | n==n3 = True - | n==n5 = True - | n==n7 = True - | n==n11 = True - | n==n13 = True - | n==n17 = True - | n==n19 = True - fGCD (F pps1) (F pps2) = F (ppsGCD pps1 pps2) - fLCM (F pps1) (F pps2) = F (ppsLCM pps1 pps2) - - fDivides (F pps1) (F pps2) = ppsDivides pps1 pps2 - fDiv (F pps1) (F pps2) = F (ppsDiv pps1 pps2) - fOddRadical (F pps) = F (ppsOddRad pps) - - -- Helper functions (not for export) on PrimePowers and - -- lists. Can assume that input lists obey the invariant - -- of Factored lists, and need to ensure that output lists - -- also obey the invariant. - ppsGCD :: [PrimePower] -> [PrimePower] -> [PrimePower] - ppsGCD [] [] = [] - ppsGCD [] (_:_) = [] - ppsGCD (_:_) [] = [] - ppsGCD (PP (p,e) : xs') (PP (p',e') : ys') = - if p == p' then PP (p,N.min e e') : ppsGCD xs' ys' - else if p <<= p' then ppsGCD xs' (PP (p',e') : ys') - else ppsGCD (PP (p,e) : xs') ys' - - ppsLCM :: [PrimePower] -> [PrimePower] -> [PrimePower] - ppsLCM [] [] = [] - ppsLCM [] ys@(_:_) = ys - ppsLCM xs@(_:_) [] = xs - ppsLCM ((PP (p,e)) : xs') ((PP (p',e')) : ys') = - if p == p' then PP (p,N.max e e') : ppsLCM xs' ys' - else if p <<= p' then (PP (p,e)) : ppsLCM xs' ((PP (p',e')) : ys') - else (PP (p',e')) : ppsLCM ((PP (p,e)) : xs') ys' - - ppsDivides :: [PrimePower] -> [PrimePower] -> Bool - ppsDivides [] _ = True - ppsDivides (_:_) [] = False - ppsDivides (PP (p,e) : xs') (PP (p',e') : ys') = - if p == p' then (e <<= e') && ppsDivides xs' ys' - else not (p <<= p') && ppsDivides (PP (p,e) : xs') ys' - - ppsDiv :: [PrimePower] -> [PrimePower] -> [PrimePower] - ppsDiv xs [] = xs - ppsDiv ((PP (p,e)) : xs') (PP (p',e') : ys') = - if p == p' && e' == e then ppsDiv xs' ys' - else if p == p' && e' <<= e then PP (p,e-e') : ppsDiv xs' ys' - else if p <<= p' then (PP (p,e)) : ppsDiv xs' (PP (p',e') : ys') - else error "type error in ppsDiv" -- if p' <<= p then it's an error - - ppsOddRad :: [PrimePower] -> [PrimePower] - ppsOddRad [] = [] - ppsOddRad (PP ((S (S Z)),_) : xs') = ppsOddRad xs' - -- need to expand to avoid overlapping with previous case - ppsOddRad (PP (p@(S (S (S _))),_) : xs') = PP (p,n1) : ppsOddRad xs' - - |] - -singletons [d| - -- removes all @p@-factors from a 'Factored' - pFree :: Nat -> Factored -> Factored - pFree n (F pps) = F (go pps) - where go [] = [] - go (pp@(PP (p,_)) : ps) = - if n == p then ps - else pp : (go ps) - |] - -singletons [d| - - f1 = F [] - f2 = primeToF n2 - f3 = primeToF n3 - f4 = f2 `fMul` f2 - f5 = primeToF n5 - f6 = f2 `fMul` f3 - f7 = primeToF n7 - f8 = f2 `fMul` f4 - f9 = f3 `fMul` f3 - f10 = f2 `fMul` f5 - f11 = primeToF n11 - f12 = f4 `fMul` f3 - f13 = primeToF n13 - f14 = f2 `fMul` f7 - f15 = f3 `fMul` f5 - f16 = f2 `fMul` f8 - f17 = primeToF n17 - f18 = f2 `fMul` f9 - f19 = primeToF n19 - f20 = f2 `fMul` f10 - f21 = f3 `fMul` f7 - f22 = f2 `fMul` f11 - f24 = f2 `fMul` f12 - f25 = f5 `fMul` f5 - f26 = f2 `fMul` f13 - f27 = f3 `fMul` f9 - f28 = f2 `fMul` f14 - f30 = f2 `fMul` f15 - f32 = f2 `fMul` f16 - f33 = f3 `fMul` f11 - f34 = f2 `fMul` f17 - f35 = f5 `fMul` f7 - f36 = f2 `fMul` f18 - f38 = f2 `fMul` f19 - f39 = f3 `fMul` f13 - f40 = f2 `fMul` f20 - f42 = f2 `fMul` f21 - f44 = f2 `fMul` f22 - f45 = f3 `fMul` f15 - f48 = f2 `fMul` f24 - f49 = f7 `fMul` f7 - f50 = f2 `fMul` f25 - f51 = f3 `fMul` f17 - f52 = f2 `fMul` f26 - f54 = f2 `fMul` f27 - f55 = f5 `fMul` f11 - f56 = f2 `fMul` f28 - f57 = f3 `fMul` f19 - f60 = f2 `fMul` f30 - f63 = f3 `fMul` f21 - f64 = f2 `fMul` f32 - f65 = f5 `fMul` f13 - f66 = f2 `fMul` f33 - f68 = f2 `fMul` f34 - f70 = f2 `fMul` f35 - f72 = f2 `fMul` f36 - f75 = f3 `fMul` f25 - f76 = f2 `fMul` f38 - f77 = f7 `fMul` f11 - f78 = f2 `fMul` f39 - f80 = f2 `fMul` f40 - f81 = f3 `fMul` f27 - f84 = f2 `fMul` f42 - f85 = f5 `fMul` f17 - f88 = f2 `fMul` f44 - f90 = f2 `fMul` f45 - f91 = f7 `fMul` f13 - f95 = f5 `fMul` f19 - f96 = f2 `fMul` f48 - f98 = f2 `fMul` f49 - f99 = f9 `fMul` f11 - f128 = f2 `fMul` f64 - f256 = f2 `fMul` f128 - f512 = f2 `fMul` f256 - f1024 = f2 `fMul` f512 - f2048 = f2 `fMul` f1024 - |] - --- | Type (family) synonym for division of 'Factored' types -type a / b = FDiv a b - --- | Type (family) synonym for multiplication of 'Factored' types -type a * b = FMul a b - --- | Type (family) synonym to create a Factored from a prime Nat -type PToF p = PpToF (ToPP p N1) - --- convenience aliases: enforce kind, hide SingI - --- | Kind-restricted synonym for 'SingI'. Use this in constraints --- for types requiring a 'Factored' type. -type Fact (m :: Factored) = SingI m - --- | Kind-restricted synonym for 'SingI'. Use this in constraints --- for types requiring a 'PrimePower' type. -type PPow (pp :: PrimePower) = SingI pp - --- | Kind-restricted synonym for 'SingI'. Use this in constraints --- for types requiring a 'Nat' type. -type NatC (p :: Nat) = SingI p - -type Prime p = (NatC p, PrimeNat p ~ 'True) - --- | Constraint synonym for divisibility of 'Factored' types -type Divides m m' = (Fact m, Fact m', FDivides m m' ~ 'True) - --- | Constraint synonym for coprimality of 'Factored' types -type Coprime m m' = (FGCD m m' ~ F1) - --- coercions: using proxy arguments here due to compiler bugs in usage - --- coerce any divisibility relationship we want -coerceFDivs :: p m -> p' m' -> (() :- (FDivides m m' ~ True)) -coerceFDivs _ _ = Sub $ unsafeCoerce (Dict :: Dict ()) - --- coerce any GCD we want -coerceGCD :: p a -> p' a' -> p'' a'' -> (() :- (FGCD a a' ~ a'')) -coerceGCD _ _ _ = Sub $ unsafeCoerce (Dict :: Dict ()) - --- | Entails constraint for transitivity of division, i.e. --- if @k|l@ and @l|m@, then @k|m@. -transDivides :: forall k l m . Proxy k -> Proxy l -> Proxy m -> - ((k `Divides` l, l `Divides` m) :- (k `Divides` m)) -transDivides k _ m = Sub Dict \\ coerceFDivs k m - --- | Entails constraint for divisibility by GCD, i.e. --- if @g=GCD(m1,m2)@, then @g|m1@ and @g|m2@. -gcdDivides :: forall m1 m2 g . Proxy m1 -> Proxy m2 -> - ((Fact m1, Fact m2, g ~ FGCD m1 m2) :- - (g `Divides` m1, g `Divides` m2)) -gcdDivides m1 m2 = - Sub $ withSingI (sFGCD (sing :: SFactored m1) (sing :: SFactored m2)) - Dict \\ coerceFDivs (Proxy::Proxy g) m1 - \\ coerceFDivs (Proxy::Proxy g) m2 - --- | Entails constraint for LCM divisibility, i.e. --- if @l=LCM(m1,m2)@, then @m1|l@ and @m2|l@. -lcmDivides :: forall m1 m2 l . Proxy m1 -> Proxy m2 -> - ((Fact m1, Fact m2, l ~ FLCM m1 m2) :- - (m1 `Divides` l, m2 `Divides` l)) -lcmDivides m1 m2 = - Sub $ withSingI (sFLCM (sing :: SFactored m1) (sing :: SFactored m2)) - Dict \\ coerceFDivs m1 (Proxy::Proxy l) - \\ coerceFDivs m2 (Proxy::Proxy l) - --- | Entails constraint for LCM divisibility, i.e. --- the LCM of two divisors of @m@ also divides @m@. -lcm2Divides :: forall m1 m2 l m . Proxy m1 -> Proxy m2 -> Proxy m -> - ((m1 `Divides` m, m2 `Divides` m, l ~ FLCM m1 m2) :- - (m1 `Divides` l, m2 `Divides` l, (FLCM m1 m2) `Divides` m)) -lcm2Divides m1 m2 m = - Sub $ withSingI (sFLCM (sing :: SFactored m1) (sing :: SFactored m2)) - Dict \\ coerceFDivs (Proxy::Proxy (FLCM m1 m2)) m \\ lcmDivides m1 m2 - --- | Entails basic facts for @p@-free division, i.e. --- 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 -> - ((NatC p, Fact m, f ~ PFree p m) :- - (f `Divides` m, Coprime (PToF p) f)) -pSplitTheorems _ m = - Sub $ withSingI (sPFree (sing :: SNat p) (sing :: SFactored m)) - Dict \\ coerceFDivs (Proxy::Proxy f) m - \\ coerceGCD (Proxy::Proxy (PToF p)) (Proxy::Proxy f) (Proxy::Proxy F1) - --- | Entails basic facts for @p@-free division, i.e., --- if @m|m'@, then @p-free(m) | p-free(m')@ -pFreeDivides :: forall p m m' . Proxy p -> Proxy m -> Proxy m' -> - ((NatC p, m `Divides` m') :- - ((PFree p m) `Divides` (PFree p m'))) -pFreeDivides _ _ _ = - Sub $ withSingI (sPFree (sing :: SNat p) (sing :: SFactored m)) $ - withSingI (sPFree (sing :: SNat p) (sing :: SFactored m')) $ - Dict \\ coerceFDivs (Proxy::Proxy (PFree p m)) (Proxy::Proxy (PFree p m')) - --- | Type synonym for @(prime :: Int, exponent :: Int)@ pair -type PP = (Int, Int) - --- | Value-level prime-power factorization tagged by a 'Factored' type. -ppsFact :: forall m . (Fact m) => Tagged m [PP] -ppsFact = tag $ map ppToPP $ unF $ fromSing (sing :: SFactored m) - -valueFact, totientFact, valueHatFact, radicalFact, oddRadicalFact :: - (Fact m) => Tagged m Int - --- | @Int@ representing the value of a 'Factored' type -valueFact = valuePPs <$> ppsFact - --- | @Int@ representing the totient of a 'Factored' type's value -totientFact = totientPPs <$> ppsFact - --- | @Int@ representing the "hat" of a 'Factored' type's value @m@: --- @m@, if @m@ is odd, or @m/2@ otherwise. -valueHatFact = valueHat <$> valueFact - --- | @Int@ representing the radical (product of prime divisors) --- of a 'Factored' type -radicalFact = radicalPPs <$> ppsFact - --- | @Int@ representing the odd radical (product of odd prime divisors) --- of a 'Factored' type -oddRadicalFact = oddRadicalPPs <$> ppsFact - --- | Reflects a 'PrimePower' type to a 'PP' value -ppPPow :: forall pp . (PPow pp) => Tagged pp PP -ppPPow = tag $ ppToPP $ fromSing (sing :: SPrimePower pp) - -primePPow, exponentPPow, valuePPow, totientPPow :: (PPow pp) => Tagged pp Int --- | Reflects the prime component of a 'PrimePower' type -primePPow = fst <$> ppPPow --- | Reflects the exponent component of a 'PrimePower' type -exponentPPow = snd <$> ppPPow --- | @Int@ representing the value of a 'PrimePower' type -valuePPow = valuePP <$> ppPPow --- | @Int@ representing the totient of a 'PrimePower' type's value -totientPPow = totientPP <$> ppPPow - --- | @Int@ representing the value of a 'Nat' -valueNatC :: forall p . (NatC p) => Tagged p Int -valueNatC = tag $ sNatToInt (sing :: SNat p) - --- | Returns @m@, if @m@ is odd, or @m/2@ otherwise -valueHat :: (Integral i) => i -> i -valueHat m = if m `mod` 2 == 0 then m `div` 2 else m - --- | Converts a 'Nat' prime-power pair to an @Int@ prime-power pair -ppToPP :: PrimePower -> PP -ppToPP = (natToInt *** natToInt) . unPP - -valuePP, totientPP, radicalPP, oddRadicalPP :: PP -> Int --- | Evaluates a prime-power pair @(p,e)@ to @p^e@ -valuePP (p,e) = p^e - --- | Euler's totient function of a prime-power pair -totientPP (_,0) = 1 -totientPP (p,e) = (p-1)*(p^(e-1)) - --- | The prime component of a prime-power pair -radicalPP (_,0) = 1 -radicalPP (p,_) = p - --- | The odd radical of a prime-power pair (p,_): --- p if p is odd, --- 1 if p==2 -oddRadicalPP (_,0) = 1 -oddRadicalPP (2,_) = 1 -oddRadicalPP (p,_) = p - -valuePPs, totientPPs, radicalPPs, oddRadicalPPs :: [PP] -> Int --- | Product of values of individual 'PP's -valuePPs = product . map valuePP --- | Product of totients of individual 'PP's -totientPPs = product . map totientPP --- | Product of radicals of individual 'PP's -radicalPPs = product . map radicalPP --- | Product of odd radicals of individual 'PP's -oddRadicalPPs = product . map oddRadicalPP diff --git a/src/Crypto/Lol/Gadget.hs b/src/Crypto/Lol/Gadget.hs deleted file mode 100644 --- a/src/Crypto/Lol/Gadget.hs +++ /dev/null @@ -1,93 +0,0 @@ -{-# LANGUAGE ConstraintKinds, DataKinds, DeriveDataTypeable, - FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, - NoImplicitPrelude, PolyKinds, ScopedTypeVariables, - TupleSections, TypeFamilies, UndecidableInstances #-} - --- | Interfaces for "gadgets," decomposition, and error correction. - -module Crypto.Lol.Gadget -( Gadget(..), Decompose(..), Correct(..) -, TrivGad, BaseBGad -) where - -import Crypto.Lol.LatticePrelude - -import Control.Applicative -import Data.Typeable - --- | Dummy type representing the gadget @[1]@. -data TrivGad deriving (Typeable) --- | Dummy type representing the gadget @[1,b,b^2,...]@. -data BaseBGad b deriving (Typeable) - --- | "Gadget" vectors, parameterized by an index type. - -class Ring u => Gadget gad u where - -- | The gadget vector over @u@. - gadget :: Tagged gad [u] - - -- | Yield an error-tolerant encoding of an element with respect to - -- the gadget. (Mathematically, this should just be the product of - -- the input with the gadget, but it is a class method to allow for - -- optimized implementations.) - encode :: u -> Tagged gad [u] - encode s = ((* s) <$>) <$> gadget - --- | Decomposition relative to a gadget. - -class (Gadget gad u, Reduce (DecompOf u) u) => Decompose gad u where - -- | The ring that @u@ decomposes over. - type DecompOf u - - -- | Yield a short vector @x@ such that @\ = u@. - decompose :: u -> Tagged gad [DecompOf u] - --- | Error correction relative to a gadget. - -class Gadget gad u => Correct gad u where - - -- | Correct a "noisy" encoding of an element (see 'encode'). - correct :: Tagged gad [u] -> u - - - --- instances for products - -instance (Gadget gad a, Gadget gad b) => Gadget gad (a,b) where - - gadget = (++) <$> (map (,zero) <$> gadget) <*> (map (zero,) <$> gadget) - -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 - - --- TODO: need some extra constraints on a,b, like Mod and maybe Rescale. --- instance (Correct gad a, Correct gad b) => Correct gad (a,b) where - - - -{- CJP: strawman class for the more general view of LWE secrets as -"module characters," i.e., module homomorphisms into a particular -range. This is probably wrong, though. - -class Character u where -- Module superclass(es)? - type CharRange u - data Char u -- need data for injectivity - - evalChar :: Char u -> u -> CharRange u - -class (Gadget gad u, Character u) => Correct gad u where - - -- | Correct a "noisy" encoding of an LWE secret (i.e., a - -- 'ModuleHomom' on 'u'). - correct :: Tagged gad [CharRange u] -> Char u - -encode :: (Correct gad u) => Char u -> Tagged gad [CharRange u] -encode s = pasteT $ evalMH s <$> peelT gadget - --} - diff --git a/src/Crypto/Lol/GaussRandom.hs b/src/Crypto/Lol/GaussRandom.hs deleted file mode 100644 --- a/src/Crypto/Lol/GaussRandom.hs +++ /dev/null @@ -1,90 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude, RebindableSyntax, ScopedTypeVariables #-} - --- | Functions for sampling from a continuous Gaussian distribution - -module Crypto.Lol.GaussRandom -( realGaussian, realGaussians ) where - -import Crypto.Lol.LatticePrelude - -import qualified Data.Vector.Generic as V - -import Control.Monad -import Control.Monad.Random - --- | Using polar form of Box-Muller transform, returns a pair of --- centered, Gaussian-distributed real numbers with scaled variance --- @svar = true variance * (2*pi)@. See --- for details. - -realGaussian :: forall v q m . - (ToRational v, OrdFloat q, Random q, MonadRandom m) - => v -> m (q,q) -realGaussian svar = - let var = realToField svar / pi :: q -- twice true variance - in do (u,v) <- iterateWhile uvGuard getUV - let t = u*u+v*v - com = sqrt (-var * log t / t) - -- we can either sample u,v from [-1,1] - -- or generate sign bits for the outputs - s1 <- getRandom - s2 <- getRandom - let u' = if s1 then u else -u - v' = if s2 then v else -v - return (u'*com,v'*com) - where getUV = do u <- getRandomR (zero,one) - v <- getRandomR (zero,one) - return (u,v) - uvGuard (u,v) = (u*u+v*v >= one) || (u*u+v*v == zero) - --- | Generate @n@ real, independent gaussians of scaled variance @svar --- = true variance * (2*pi)@. -realGaussians :: - (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) $ - replicateM (n `div` 2) (realGaussian var) - - - - - - --- Taken from monad-loops-0.4.3 - --- | Execute an action repeatedly until its result fails to satisfy a predicate, --- and return that result (discarding all others). -iterateWhile :: (Monad m) => (a -> Bool) -> m a -> m a -iterateWhile p x = x >>= iterateUntilM (not . p) (const x) - --- | 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 - | p v = return v - | otherwise = f v >>= iterateUntilM p f - -{- --- | Returns a Gaussian-distributed sample over 'pZ' with given --- (scaled) variance parameter @v=var/(2*pi)@ and center, using --- rejection sampling - -gaussRound :: (RealTranscendental v, Random v, - RealRing c, ToRational c, - Ring i, ToInteger i, Random i, MonadRandom m) - => v -> c -> m i -gaussRound svar c = - let dev = ceiling $ 6 * sqrt svar -- 6 gives stat dist < 2^-163 - lower = floor c - dev - upper = ceiling c + dev - sampler = do - z <- getRandomR (lower, upper) - u <- getRandomR (zero, one) - let dist = fromIntegral z - realToField c - let prob = exp (-pi * (dist*dist / svar)) - if u <= prob then return z else sampler - in sampler --} diff --git a/src/Crypto/Lol/LatticePrelude.hs b/src/Crypto/Lol/LatticePrelude.hs deleted file mode 100644 --- a/src/Crypto/Lol/LatticePrelude.hs +++ /dev/null @@ -1,248 +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 - Enumerable(..) -, Mod(..) -, Reduce(..), Lift, Lift'(..), Rescale(..), Encode(..), msdToLSD --- * 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 - --- | 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) - --- | Fun-dep version of Lift. -class (Reduce (LiftOf b) b) => Lift' b where - type LiftOf b - 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 - --- | 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 -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 -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 ---------- - -instance (Mod a, Mod b, Lift' a, Lift' b, Reduce Integer (a,b), - ToInteger (LiftOf a), ToInteger (LiftOf b)) - => Lift' (a,b) where - - type LiftOf (a,b) = Integer - - 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) - -instance (Field f1, Field f2) => Field.C (f1, f2) where - (x1, x2) / (y1, y2) = (x1 / y1, x2 / y2) - recip = recip *** 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)) - -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)) - -instance (Reduce a b1, Reduce a b2) => Reduce a (b1, b2) where - reduce x = (reduce x, reduce x) - --- 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)) - -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)) - --- 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 - -instance (Rescale ((a,b),c) (a,b), Rescale (a,b) a) - => Rescale ((a,b),c) a where - rescale = (rescale :: (a,b) -> a) . 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) - -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) - --- Instance of 'Encode' for product ring. -instance (Encode s t1, Encode s t2, Field (t1, t2)) => Encode s (t1, t2) where - - 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 - random g = let (a,g') = random g - (b, g'') = random g' - in ((a,b), g'') - - 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) - --- | Monadic version of 'withWitness'. -withWitnessT :: forall n mon r . (Monad mon) => - (SingI n => TaggedT n mon r) -> Sing n -> mon r -withWitnessT t wit = withSingI wit $ proxyT t (Proxy::Proxy n) diff --git a/src/Crypto/Lol/Reflects.hs b/src/Crypto/Lol/Reflects.hs deleted file mode 100644 --- a/src/Crypto/Lol/Reflects.hs +++ /dev/null @@ -1,39 +0,0 @@ -{-# LANGUAGE DataKinds, FlexibleContexts, FlexibleInstances, - KindSignatures, MultiParamTypeClasses, PolyKinds, - ScopedTypeVariables, UndecidableInstances #-} - --- | Generic interface for reflecting types to values. - -module Crypto.Lol.Reflects -( Reflects(..) -) where - -import Crypto.Lol.Factored - -import Data.Functor.Trans.Tagged -import Data.Proxy -import Data.Reflection -import GHC.TypeLits as TL - --- | Reflection without fundep, and with tagged value. Intended only --- for low-level code; build specialized wrappers around it for --- specific functionality. - -class Reflects a i where - -- | Reflect the value assiated with the type @a@. - value :: Tagged a i - -instance (KnownNat a, Integral i) => Reflects (a :: TL.Nat) i where - value = return $ fromIntegral $ natVal (Proxy::Proxy a) - -instance (NatC a, Integral i) => Reflects a i where - value = fmap fromIntegral valueNatC - -instance (PPow pp, Integral i) => Reflects pp i where - value = fmap fromIntegral valuePPow - -instance (Fact m, Integral i) => Reflects m i where - value = fmap fromIntegral valueFact - -instance {-# OVERLAPS #-} (Reifies rei a) => Reflects (rei :: *) a where - value = tag $ reflect (Proxy::Proxy rei) diff --git a/src/Crypto/Lol/Types/Complex.hs b/src/Crypto/Lol/Types/Complex.hs deleted file mode 100644 --- a/src/Crypto/Lol/Types/Complex.hs +++ /dev/null @@ -1,89 +0,0 @@ -{-# LANGUAGE DataKinds, DeriveDataTypeable, FlexibleContexts, - FlexibleInstances, GeneralizedNewtypeDeriving, - MultiParamTypeClasses, NoImplicitPrelude, RebindableSyntax, - ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, - TypeFamilies, UndecidableInstances #-} - --- | Data type, functions, and instances for complex numbers. - -module Crypto.Lol.Types.Complex ( - Complex -, roundComplex -, cis, real, imag, fromReal -) where - -import Algebra.Additive as Additive (C) -import Algebra.Field as Field (C) -import Algebra.IntegralDomain as IntegralDomain -import Algebra.Ring as Ring (C) -import Algebra.ZeroTestable as ZeroTestable (C) -import qualified Number.Complex as C hiding (exp, signum) - -import Crypto.Lol.Types.Numeric as LP - -import Control.DeepSeq -import Data.Array.Repa.Eval as R -import Data.Vector.Storable (Storable) -import Data.Vector.Unboxed (Unbox) -import Data.Vector.Unboxed.Deriving -import System.Random -import Test.QuickCheck - --- | 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) - -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. -instance (Field a) => IntegralDomain.C (Complex a) where - (Complex a) `divMod` (Complex b) = (Complex $ a / b, LP.zero) - --- we can't use Generics for NFData because NP doesn't export the --- (deep) constructor for Complex.T -instance (NFData a) => NFData (Complex a) where - rnf (Complex x) = let r = C.real x - i = C.imag x - in rnf r `seq` rnf i `seq` () - -instance (Random a) => Random (Complex a) where - random g = let (a,g') = random g - (b,g'') = random g' - in (Complex $ a C.+: b, g'') - - randomR = error "randomR not defined for (Complex t)" - -instance (R.Elt a) => R.Elt (Complex a) where - touch (Complex c) = do - touch $ C.real c - touch $ C.imag c - zero = Complex $ R.zero C.+: R.zero - one = Complex $ R.one C.+: R.zero - --- | Rounds the real and imaginary components to the nearest integer. -roundComplex :: (RealRing a, ToInteger b) => Complex a -> (b,b) -roundComplex (Complex x) = (round $ C.real x, round $ C.imag x) - --- | 'cis' @t@ is a complex value with magnitude 1 and phase t (modulo @2*Pi@). -cis :: Transcendental a => a -> Complex a -cis = Complex . C.cis - --- | Real component of a complex number. -real :: Complex a -> a -real (Complex a) = C.real a - --- | Imaginary component of a complex number. -imag :: Complex a -> a -imag (Complex a) = C.imag a - --- | Embeds a scalar as the real component of a complex number. -fromReal :: Additive a => a -> Complex a -fromReal = Complex . C.fromReal diff --git a/src/Crypto/Lol/Types/FiniteField.hs b/src/Crypto/Lol/Types/FiniteField.hs deleted file mode 100644 --- a/src/Crypto/Lol/Types/FiniteField.hs +++ /dev/null @@ -1,122 +0,0 @@ -{-# LANGUAGE ConstraintKinds, FlexibleContexts, - GeneralizedNewtypeDeriving, - NoImplicitPrelude, PolyKinds, - RebindableSyntax, RoleAnnotations, ScopedTypeVariables #-} - --- CJP: need PolyKinds to allow deg to have non-* kind - --- | Basic (unoptimized) finite field arithmetic. - -module Crypto.Lol.Types.FiniteField -( PrimeField, CharOf, GF -- export type but not constructor -, trace -, size -) where - -import Crypto.Lol.CRTrans -import Crypto.Lol.Factored -import Crypto.Lol.LatticePrelude -import Crypto.Lol.Reflects -import Crypto.Lol.Types.PrimeField hiding ((^)) -import qualified Crypto.Lol.Types.PrimeField as PF - -import Algebra.Additive as Additive (C) -import Algebra.Field as Field (C) -import Algebra.Ring as Ring (C) -import Algebra.ZeroTestable as ZeroTestable (C) -import MathObj.Polynomial - -import Math.NumberTheory.Primes.Factorisation - -import Control.Applicative -import Control.DeepSeq -import Control.Monad -import qualified Data.Vector as V - ---import qualified Debug.Trace as DT - --- | A finite field of given degree over @F_p@. -newtype GF fp deg = GF (Polynomial fp) - deriving (Eq, Show, Additive.C, ZeroTestable.C, NFData) - --- the second argument, though phantom, affects representation -type role GF representational representational - -type GFCtx fp deg = (PrimeField fp, Reflects deg Int) - -instance (GFCtx fp deg) => Enumerable (GF fp deg) where - values = GF <$> fromCoeffs <$> - -- d-fold cartesian product of Fp values - replicateM (proxy value (Proxy::Proxy deg)) values - -instance (GFCtx fp deg) => Ring.C (GF fp deg) where - - one = GF one - - (*) = let poly = proxy irreduciblePoly (Proxy :: Proxy deg) - in \(GF f) (GF g) -> GF $ (f*g) `mod` poly - - fromInteger = GF . fromInteger - -instance (GFCtx fp deg) => Field.C (GF fp deg) where - - recip = let g = proxy irreduciblePoly (Proxy :: Proxy deg) - in \(GF f) -> let (_,(a,_)) = extendedGCD f g - in GF a - -instance (GFCtx fp deg) => CRTrans (GF fp deg) where - - crtInfo m = (,) <$> omegaPow <*> scalarInv - where - omegaPow = - let size' = proxy size (Proxy :: Proxy (GF fp deg)) - (q,r) = (size'-1) `quotRem` m - gen = head $ filter isPrimitive values - omega = gen^q - omegaPows = V.iterateN m (*omega) one - in if r == 0 - then Just $ (omegaPows V.!) . (`mod` m) - else Nothing - scalarInv = Just $ recip $ fromIntegral $ valueHat m - -sizePP :: forall fp deg . (GFCtx fp deg) => Tagged (GF fp deg) PP -sizePP = tag (proxy value (Proxy::Proxy (CharOf fp)), - proxy value (Proxy::Proxy deg)) - --- | The order of the field: @size (GF fp deg) = p^deg@ -size :: (GFCtx fp deg) => Tagged (GF fp deg) Int -size = uncurry (^) <$> sizePP - -isPrimitive :: forall fp deg . (GFCtx fp deg) => GF fp deg -> Bool -isPrimitive = let q = proxy size (Proxy :: Proxy (GF fp deg)) - ps = map (fromIntegral . fst) $ factorise $ - fromIntegral $ q-1 - exps = map ((q-1) `div`) ps - in \g -> not (isZero g) && all (\e -> g^e /= 1) exps - -dotp :: (Ring a) => [a] -> [a] -> a -dotp a b = sum $ zipWith (*) a b - --- | Trace into the prime subfield. -trace :: forall fp deg . (GFCtx fp deg) => GF fp deg -> fp -trace = let ts = proxy powTraces (Proxy::Proxy (GF fp deg)) - in \(GF f) -> dotp ts (coeffs f) - --- | Traces of the power basis elements 1, x, x^2, ..., x^(deg-1). -powTraces :: forall fp deg . (GFCtx fp deg) => Tagged (GF fp deg) [fp] -powTraces = - --DT.trace ("FiniteField.powTraces: p = " ++ - -- show (proxy value (Proxy::Proxy (CharOf fp)) :: Int) ++ - -- ", d = " ++ show (proxy value (Proxy::Proxy deg) :: Int)) $ - let d = proxy value (Proxy :: Proxy deg) - in tag $ map trace' $ take d $ - iterate (* (GF (X PF.^ 1))) (one :: GF fp deg) - --- helper that computes trace via brute force: sum frobenius --- automorphisms -trace' :: (GFCtx fp deg) => GF fp deg -> fp -trace' e = let (p,d) = witness sizePP e - (GF t) = sum $ take d $ iterate (^p) e - -- t is a constant polynomial - in head $ coeffs t - diff --git a/src/Crypto/Lol/Types/IZipVector.hs b/src/Crypto/Lol/Types/IZipVector.hs deleted file mode 100644 --- a/src/Crypto/Lol/Types/IZipVector.hs +++ /dev/null @@ -1,58 +0,0 @@ -{-# LANGUAGE ConstraintKinds, DataKinds, DeriveDataTypeable, - DeriveTraversable, FlexibleContexts, - GeneralizedNewtypeDeriving, KindSignatures, - MultiParamTypeClasses, RoleAnnotations, ScopedTypeVariables, - TypeFamilies, UndecidableInstances #-} - --- | Provides applicative-like functions for indexed vectors - -module Crypto.Lol.Types.IZipVector -( IZipVector, iZipVector, unIZipVector -) where - -import Crypto.Lol.Factored - -import Algebra.ZeroTestable as ZeroTestable - -import Control.DeepSeq -import Data.Data -import Data.Functor.Trans.Tagged -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 --- proper lengths (and is necessary to implement 'pure'). - -newtype IZipVector (m :: Factored) a = - IZipVector { -- | Deconstructor for IZipVector - unIZipVector :: Vector a} - -- not deriving Read, Monoid, Alternative, Monad[Plus], IsList - -- because of different semantics and/or length restriction - deriving (Show, Eq, Data, NFData, Typeable, Functor, - Foldable, Traversable, ZeroTestable.C) - --- the first argument, though phantom, affects representation -type role IZipVector representational representational - --- | Smart constructor that checks whether length of input is right --- (should be totient of @m@). -iZipVector :: forall m a . (Fact m) => Vector a -> Maybe (IZipVector m a) -iZipVector = let n = proxy totientFact (Proxy::Proxy m) - in \vec -> if n == V.length vec - then Just $ IZipVector vec - else Nothing - --- don't export -repl :: forall m a . (Fact m) => a -> IZipVector m a -repl = let n = proxy totientFact (Proxy::Proxy m) - in IZipVector . V.replicate n - --- Zip-py 'Applicative' instance. -instance (Fact m) => Applicative (IZipVector m) where - pure = repl - (IZipVector f) <*> (IZipVector a) = IZipVector $ V.zipWith ($) f a - --- no ZeroTestable instance for Vectors, so define here -instance (ZeroTestable.C a) => ZeroTestable.C (Vector a) where - isZero = V.all isZero diff --git a/src/Crypto/Lol/Types/IrreducibleChar2.hs b/src/Crypto/Lol/Types/IrreducibleChar2.hs deleted file mode 100644 --- a/src/Crypto/Lol/Types/IrreducibleChar2.hs +++ /dev/null @@ -1,60 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude, RebindableSyntax, ScopedTypeVariables, - FlexibleInstances, TypeFamilies, UndecidableInstances, PolyKinds #-} - --- | (Orphan) instance of 'IrreduciblePoly' for characteristic 2 fields. - -module Crypto.Lol.Types.IrreducibleChar2 () where - -import Crypto.Lol.LatticePrelude hiding ((^)) -import Crypto.Lol.Reflects -import Crypto.Lol.Types.PrimeField - -import Data.Type.Natural (N2) - --- 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 ~ N2, Ring 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 - otherwise -> - error $ "The ConwayPoly 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 ConwayPoly and do " ++ - "not import Crypto.Lol." diff --git a/src/Crypto/Lol/Types/Numeric.hs b/src/Crypto/Lol/Types/Numeric.hs deleted file mode 100644 --- a/src/Crypto/Lol/Types/Numeric.hs +++ /dev/null @@ -1,213 +0,0 @@ -{-# LANGUAGE ConstraintKinds, DataKinds, FlexibleInstances, GADTs, - MultiParamTypeClasses, NoImplicitPrelude, RebindableSyntax, - ScopedTypeVariables, TypeOperators #-} - --- we have some orphan instances here for instances of --- package classes with Prelude data types -{-# OPTIONS_GHC -fno-warn-orphans #-} - --- | This module imports NumericPrelude and defines constraint --- synonyms for NumericPrelude classes to help with code readability, --- and defines saner versions of some NumericPrelude functions - -module Crypto.Lol.Types.Numeric -( module Crypto.Lol.Types.Numeric -- everything we define here -, module NumericPrelude -- re-export -, Int64 -- commonly used -) where - -import Control.DeepSeq -import Control.Monad.Random - -import Algebra.IntegralDomain (divUp) --- NumericPrelude has silly types for these functions -import NumericPrelude hiding (abs, max, min, (^)) -import qualified NumericPrelude.Numeric (abs) -import qualified Prelude (max, min) - -import qualified Algebra.Absolute (C) -import qualified Algebra.Additive (C) -import qualified Algebra.Algebraic (C) -import qualified Algebra.Field (C) -import qualified Algebra.IntegralDomain (C) -import qualified Algebra.Module (C) -import qualified Algebra.PrincipalIdealDomain (C) -import qualified Algebra.RealField (C) -import qualified Algebra.RealIntegral (C) -import qualified Algebra.RealRing (C) -import qualified Algebra.RealTranscendental (C) -import qualified Algebra.Ring (C) -import qualified Algebra.ToInteger (C) -import qualified Algebra.ToRational (C, realToField) -import qualified Algebra.Transcendental (C) -import qualified Algebra.ZeroTestable (C) -import MathObj.Polynomial - -import Data.Int (Int64) - --- | The Prelude definition of 'max'. -max :: Ord a => a -> a -> a -max = Prelude.max - --- | The Prelude definition of 'min'. -min :: Ord a => a -> a -> a -min = Prelude.min - --- | The sane definition of 'abs' from --- 'NumericPrelude.Numeric' --- rather than the default from 'NumericPrelude'. -abs :: Absolute a => a -> a -abs = NumericPrelude.Numeric.abs - --- | The hidden NP function from 'Algebra.ToRational'. -realToField :: (Field b, ToRational a) => a -> b -realToField = Algebra.ToRational.realToField - --- use this if you need: -{- isZero -} --- | Sane synonym for 'Algebra.ZeroTestable.C'. -type ZeroTestable a = (Algebra.ZeroTestable.C a) - -{- - + negate -} --- | Sane synonym for 'Algebra.Additive.C'. -type Additive a = (Algebra.Additive.C a) - -{- Additive, plus: * fromIntegral -} --- | Sane synonym for 'Algebra.Ring.C'. -type Ring a = (Algebra.Ring.C a) - -{- Ring and Additive, plus: *> -} --- | Sane synonym for 'Algebra.Module.C'. -type Module a v = (Algebra.Module.C a v) - -{- Ring, plus: div, mod, divmod -} --- | Sane synonym for 'Algebra.IntegralDomain.C'. -type IntegralDomain a = (Algebra.IntegralDomain.C a) - -{- Ring, plus: abs signum toRational' -} --- | Sane synonym for 'Algebra.ToRational.C'. -type ToRational a = (Algebra.ToRational.C a) - -{- Ring, plus: / recip fromRational -} --- | Sane synonym for 'Algebra.Field.C'. -type Field a = (Algebra.Field.C a) - -{- Ring, plus: abs and rounding functions -} --- | Sane synonym for 'Algebra.RealRing.C'. -type RealRing a = (Algebra.RealRing.C a) - -{- Field, plus: abs signum round floor ceiling -} --- | Sane synonym for 'Algebra.RealField.C'. -type RealField a = (Algebra.RealField.C a) - -{- Field, plus: sqrt root ^/ -} --- | Sane synonym for 'Algebra.Algebraic.C'. -type Algebraic a = (Algebra.Algebraic.C a) - -{- Algebraic, plus: pi exp log sin atan -} --- | Sane synonym for 'Algebra.Transcendental.C'. -type Transcendental a = (Algebra.Transcendental.C a) - -{- Transcendental and RealField, plus atan2 -} --- | Sane synonym for 'Algebra.RealTranscendental.C'. -type RealTranscendental a = (Algebra.RealTranscendental.C a) - -{- Transcendental, plus: == <= >= < > -} --- | Convenient synonym for @(Ord a, Transcendental a)@ -type OrdFloat a = (Ord a, Transcendental a) - -{- ToRational and Ring, plus: toInteger div mod divmod quot rem quotrem -} --- | Sane synonym for 'Algebra.ToInteger.C'. -type ToInteger a = (Algebra.ToInteger.C a) - --- | Sane synonym for 'Algebra.Absolute.C'. -type Absolute a = (Algebra.Absolute.C a) - --- | Sane synonym for 'Algebra.RealIntegral.C'. -type RealIntegral a = (Algebra.RealIntegral.C a) - --- | Sane synonym for 'Algebra.PrincipalIdealDomain.C'. -type PID a = (Algebra.PrincipalIdealDomain.C a) - --- | Sane synonym for 'MathObj.Polynomial.T'. -type Polynomial a = MathObj.Polynomial.T a - --- | IntegralDomain instance for Double -instance Algebra.IntegralDomain.C Double where - _ `div` 0 = error "cannot divide Double by 0\n" - a `div` b = a / b - _ `mod` _ = 0 - --- NFData instance for Polynomial, missing from NP -instance (NFData r) => NFData (Polynomial r) where - rnf = rnf . coeffs - --- | Our custom exponentiation, overriding NP's version that --- requires 'Integer' exponent. --- Copied from http://hackage.haskell.org/package/base-4.7.0.0/docs/src/GHC-Real.html#%5E -{-# SPECIALISE [1] (^) :: - Integer -> Integer -> Integer, - Integer -> Int -> Integer, - Int -> Int -> Int, - Int64 -> Int64 -> Int64 - #-} -(^) :: forall a i . (Ring a, ToInteger i) => a -> i -> a -x0 ^ y0 | y0 < 0 = error "Negative exponent" - | y0 == 0 = 1 - | otherwise = f x0 y0 - where -- f : x0 ^ y0 = x ^ y - f :: a -> i -> a -- a polymorphic local binding needs a sig - f x y | even y = f (x * x) (y `quot` 2) - | y == 1 = x - | otherwise = g (x * x) ((y - 1) `quot` 2) x - -- g : x0 ^ y0 = (x ^ y) * z - g :: a -> i -> a -> a - g x y z | even y = g (x * x) (y `quot` 2) z - | y == 1 = x * z - | otherwise = g (x * x) ((y - 1) `quot` 2) (x * z) - --- | Inverse of @a@ modulo @q@, in range @0..q-1@. (Argument order is --- infix-friendly.) -modinv :: (PID i, Eq i) => i -> i -> Maybe i -modinv a q = let (d, (_, inv)) = extendedGCD q a - in if d == one - then Just $ inv `mod` q - else Nothing - --- | Decompose an element into a list of "centered" digits with respect --- to relative radices. -decomp :: (IntegralDomain z, Ord z) => [z] -> z -> [z] -decomp [] v = [v] -decomp (b:bs) v = let (q,r) = v `divModCent` b - in r : decomp bs q - --- | Yield @ceil (log_b(x))@. -logCeil :: (ToInteger i) => i -> i -> Int -logCeil _ 1 = 0 -logCeil b x = 1 + logCeil b (x `divUp` b) - --- | Deterministically round to the nearest multiple of @i@. -roundMult :: (RealField r, ToInteger i) => i -> r -> i -roundMult 1 r = round r -roundMult i r = let r' = r / fromIntegral i in i * round r' - --- | Randomly round to the nearest larger or smaller multiple of @i@, --- where the round-off term has expectation zero. -roundScalarCentered :: (RealField r, Random r, ToInteger i, - MonadRandom mon) - => i -> r -> mon i -roundScalarCentered p x = - let x' = x / fromIntegral p - mod1 = x' - floor x' - in do prob <- getRandomR (zero, one) - return $ p * if prob < mod1 - then ceiling x' - else floor x' - --- | Variant of 'Algebra.IntegralDomain.divMod' in which the remainder --- is in the range @[-b\/2,b\/2)@. -divModCent :: (IntegralDomain i, Ord i) => i -> i -> (i,i) -divModCent a b = let (q,r) = a `divMod` b - in if 2*r < b -- divMod returns non-neg remainder - then (q,r) - else (q+1,r-b) diff --git a/src/Crypto/Lol/Types/PrimeField.hs b/src/Crypto/Lol/Types/PrimeField.hs deleted file mode 100644 --- a/src/Crypto/Lol/Types/PrimeField.hs +++ /dev/null @@ -1,36 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude, RebindableSyntax, PolyKinds, TypeFamilies, - DataKinds, FlexibleContexts, ConstraintKinds #-} - --- | Prime-order fields. - -module Crypto.Lol.Types.PrimeField where - -import Crypto.Lol.LatticePrelude as LP -import Crypto.Lol.Reflects - -import MathObj.Polynomial - --- | Constraint synonym for prime-order fields. -type PrimeField fp = (Enumerable fp, Eq fp, ZeroTestable fp, Field fp, - IrreduciblePoly fp) - --- | The characteristic of a field, represented as a type. -type family CharOf (fp :: k) :: Nat - --- | Represents prime-order fields over which we can get irreducible --- polynomials of desired degree. (An instance of this class is --- defined in 'Crypto.Lol.Types.IrreducibleChar2' and exported from --- 'Crypto.Lol'.) -class (Ring fp, Prime (CharOf fp)) => IrreduciblePoly fp where - irreduciblePoly :: (Reflects deg Int) => Tagged deg (Polynomial fp) - --- | Convenience function for writing 'IrreduciblePoly' instances. -taggedProxy :: Tagged s (Proxy s) -taggedProxy = tag Proxy - --- | Convenience data type for writing 'IrreduciblePoly' instances. -data X = X - --- | Convenience function for writing 'IrreduciblePoly' instances. -(^) :: (Ring a) => X -> Int -> Polynomial a -X ^ i | i >= 0 = fromCoeffs $ (replicate i 0) ++ [1] diff --git a/src/Crypto/Lol/Types/ZPP.hs b/src/Crypto/Lol/Types/ZPP.hs deleted file mode 100644 --- a/src/Crypto/Lol/Types/ZPP.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE FlexibleContexts, TypeFamilies #-} - --- | A class for integers mod a prime power. - -module Crypto.Lol.Types.ZPP -( ZPP(..) -) where - -import Crypto.Lol.LatticePrelude -import Crypto.Lol.Types.FiniteField - --- | Represents integers modulo a prime power. -class (PrimeField (ZPOf zq), Ring zq, Ring (ZPOf zq)) => ZPP zq where - - -- | An implementation of the integers modulo the prime base. - type ZPOf zq - - -- | The prime and exponent of the modulus. - modulusZPP :: Tagged zq PP - - -- | Lift from @Z_p@ to a representative. - liftZp :: ZPOf zq -> zq - diff --git a/src/Crypto/Lol/Types/ZmStar.hs b/src/Crypto/Lol/Types/ZmStar.hs deleted file mode 100644 --- a/src/Crypto/Lol/Types/ZmStar.hs +++ /dev/null @@ -1,69 +0,0 @@ -{-# LANGUAGE ConstraintKinds, DataKinds, FlexibleContexts, - NoImplicitPrelude, PolyKinds, RebindableSyntax, - ScopedTypeVariables, TypeFamilies, TypeOperators, - UndecidableInstances #-} - --- | A collection of helper functions for working with @Z_m^*@ - -module Crypto.Lol.Types.ZmStar -( order, partitionCosets -) where - -import Crypto.Lol.Factored -import Crypto.Lol.LatticePrelude as LP hiding (null) -import Crypto.Lol.Reflects -import Crypto.Lol.Types.ZqBasic - -import Data.List as L (foldl', transpose) -import Data.Map (Map, elems, empty, insertWith') -import Data.Set as S (Set, difference, findMin, fromList, map, null) - - --- | The multiplicative order of @p@ (the argument) modulo @m@. --- Requires @gcd(p,m)=1@. -order :: forall m . (Reflects m Int) => Int -> Tagged m Int -order p = tag $ - 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)) - --- given p, returns the cosets of Z_m^* /

-cosets :: forall zm . (Mod zm, ModRep zm ~ Int, Ord zm, Ring zm) - => Int -> [Set zm] -cosets p = - let mval = proxy modulus (Proxy::Proxy zm) - in if gcd p mval /= 1 - then error "p and m not coprime" - else let zmstar = fromList $ LP.map fromIntegral $ filter ((==) 1 . gcd mval) [1..mval] - zp = fromIntegral p - -- generates the coset containing x - coset x = fromList $ x : takeWhile (/=x) (iterate (*zp) $ zp*x) - -- repeatedly removes a (new) coset from the remaining elements - genCosets s | null s = [] - genCosets s = let c = coset (findMin s) - in c : genCosets (difference s c) - in genCosets zmstar - --- CJP: could tag this by '(p,m,m') for safety/memoization. - --- | Given @p@, returns a partition of the cosets of @Z_{m\'}^* \/ \

@ --- (specified by representatives), where the cosets in each component --- are in bijective correspondence with the cosets of @Z_m^* \/ \

@ under --- the natural (@mod m@) homomorphism. -partitionCosets :: forall m m' . (m `Divides` m') - => Int -> Tagged '(m, m') [[Int]] -partitionCosets p = - let m'cosets = cosets p - -- a map from cosets of Z_m^* /

to their preimages under the - -- natural homomorphism - partition = - L.foldl' (\cmap x -> insertWith' (++) (S.map (reduce . lift) x) [x] cmap) - (empty :: Map (Set (ZqBasic m Int)) [Set (ZqBasic m' Int)]) - m'cosets - -- transpose the map to get a list of list of sets, where for each - -- inner list, there is exactly one m'-(co)set lying above each m-coset - part' = transpose $ elems partition - -- concat the inner sets to get a list of "CRT cosets" (indexed in Z_m'^*) - in return $ LP.map (LP.map (lift . findMin)) part' diff --git a/src/Crypto/Lol/Types/ZqBasic.hs b/src/Crypto/Lol/Types/ZqBasic.hs deleted file mode 100644 --- a/src/Crypto/Lol/Types/ZqBasic.hs +++ /dev/null @@ -1,256 +0,0 @@ -{-# LANGUAGE ConstraintKinds, DataKinds, DeriveDataTypeable, - FlexibleContexts, FlexibleInstances, - GeneralizedNewtypeDeriving, MultiParamTypeClasses, - NoImplicitPrelude, PolyKinds, RebindableSyntax, - RoleAnnotations, ScopedTypeVariables, - StandaloneDeriving, TypeFamilies, UndecidableInstances #-} - --- | An implementation of modular arithmetic, i.e., the ring Zq. - -module Crypto.Lol.Types.ZqBasic -( ZqBasic -- export the type, but not the constructor (for safety) -) where - -import Crypto.Lol.LatticePrelude as LP -import Crypto.Lol.Reflects -import Crypto.Lol.CRTrans -import Crypto.Lol.Types.FiniteField -import Crypto.Lol.Types.ZPP -import Crypto.Lol.Gadget - -import Control.Applicative -import Control.DeepSeq (NFData) -import Control.Monad (liftM) -import Data.Coerce -import Data.Maybe -import Data.Typeable -import NumericPrelude.Numeric as NP (round) -import System.Random -import Test.QuickCheck - --- for the Unbox instances -import qualified Data.Vector.Generic as V -import qualified Data.Vector.Generic.Mutable as M -import qualified Data.Vector.Unboxed as U - -import Foreign.Storable - --- for the Elt instance -import qualified Data.Array.Repa.Eval as E - -import qualified Algebra.Additive as Additive (C) -import qualified Algebra.Field as Field (C) -import qualified Algebra.IntegralDomain as IntegralDomain (C) -import qualified Algebra.Ring as Ring (C) -import qualified Algebra.ZeroTestable as ZeroTestable (C) - --- | 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) - --- the q argument, though phantom, matters for safety -type role ZqBasic nominal representational - ---deriving instance (U.Unbox i) => V.Vector U.Vector (ZqBasic q i) ---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) - -reduce' :: forall q z . (ReflectsTI q z) => z -> ZqBasic q z -reduce' = coerce . (`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' = let qval = proxy value (Proxy::Proxy q) - in \(ZqB x) -> if 2 * x < qval - then x - else x - qval - -instance (ReflectsTI q 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 - type ModRep (ZqBasic q z) = z - - modulus = retag (value :: Tagged q z) - -type instance CharOf (ZqBasic p z) = p - -instance (PPow pp, zq ~ ZqBasic pp z, - PrimeField (ZPOf zq), Ring zq, Ring (ZPOf zq)) - => ZPP (ZqBasic (pp :: PrimePower) z) where - - type ZPOf (ZqBasic pp z) = ZqBasic (PrimePP pp) z - - modulusZPP = retag (ppPPow :: Tagged pp PP) - - liftZp = coerce - -instance (ReflectsTI q z) => Reduce z (ZqBasic q z) where - reduce = reduce' - -instance (Reflects q z, Ring (ZqBasic q z)) => Reduce Integer (ZqBasic q z) where - reduce = fromInteger - -instance (ReflectsTI q z) => Lift' (ZqBasic q z) where - type LiftOf (ZqBasic q z) = z - lift = decode' - -instance (ReflectsTI q z, ReflectsTI q' z, Ring z) - => Rescale (ZqBasic q z) (ZqBasic q' z) where - - rescale = rescaleMod - -instance (Reflects p z, ReflectsTI q z, - Field (ZqBasic p z), Field (ZqBasic q 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) - --- instance of CRTrans -instance (Reflects q z, PID z, r ~ (ZqBasic q z), Mod r, Enumerable r, - Show z) -- for DT.trace - => CRTrans (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 -> (,) <$> omegaPowMod m <*> - -- CJP: using coerce depends on modinv returning in [0..q-1] - (coerce $ fromIntegral (valueHat m) `modinv` qval) - --- instance of CRTEmbed -instance (ReflectsTI q 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 - -- CJP: "LHS too complicated to desugar"; might be fixed in 7.10: - -- https://ghc.haskell.org/trac/ghc/ticket/8848 - {-# SPECIALIZE instance ReflectsTI q Int => Additive.C (ZqBasic q Int) #-} - {-# SPECIALIZE instance ReflectsTI q Int64 => Additive.C (ZqBasic q Int64) #-} - - zero = ZqB zero - - (+) = let qval = proxy value (Proxy::Proxy q) - in \ (ZqB x) (ZqB y) -> - let z = x + y - in ZqB (if z >= qval then z - qval else z) - - negate (ZqB x) = reduce' $ negate x - --- instance of Ring -instance (ReflectsTI q z, Ring z) => Ring.C (ZqBasic q z) where - (ZqB x) * (ZqB y) = reduce' $ x * y - - fromInteger x = - let qval = toInteger (proxy value (Proxy::Proxy q) :: z) - -- this is safe as long as type z can hold the value of q - in ZqB $ fromInteger $ x `mod` qval - --- instance of Field -instance (ReflectsTI q z, PID z, Show z) => Field.C (ZqBasic q z) where - - recip = let qval = proxy value (Proxy::Proxy q) - -- safe because modinv returns in range 0..qval-1 - in \(ZqB x) -> ZqB $ - fromMaybe (error $ "ZqB.recip fail: " ++ - show x ++ "\t" ++ show qval) $ modinv x qval - --- (canonical) instance of IntegralDomain, needed for FastCyc -instance (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 - - gadget = tag [one] - -instance (ReflectsTI q 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 - correct a = case untag a of - [b] -> b - _ -> error "Correct TrivGad: wrong length" - -instance (ReflectsTI q z, Additive 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) - k = logCeil bval qval - in tag $ map reduce' (take k (iterate (*bval) one)) - -instance (ReflectsTI q z, Ring 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) - bval = proxy value (Proxy :: Proxy b) - k = logCeil bval qval - radices = replicate (k-1) bval - in tag . decomp radices . lift - --- TODO: implement Correct for BaseBGad b - --- instance of Random -instance (ReflectsTI q 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') - - randomR _ = error "randomR non-sensical for Zq types" - --- instance of Arbitrary -instance (ReflectsTI q z, Random z) => Arbitrary (ZqBasic q z) where - arbitrary = - let qval :: z = proxy value (Proxy::Proxy q) - in fromIntegral <$> choose (0, qval-1) - - shrink = shrinkNothing - --- CJP: restored manual Unbox instances, until we have a better way --- (NewtypeDeriving or TH) - -newtype instance U.MVector s (ZqBasic q z) = MV_ZqBasic (U.MVector s z) -newtype instance U.Vector (ZqBasic q z) = V_ZqBasic (U.Vector z) - --- Unbox, when underlying representation is -instance (U.Unbox z) => U.Unbox (ZqBasic q z) - -{- purloined and tweaked from code in `vector` package that defines -types as unboxed -} -instance (U.Unbox z) => M.MVector U.MVector (ZqBasic q z) where - basicLength (MV_ZqBasic v) = M.basicLength v - basicUnsafeSlice z n (MV_ZqBasic v) = MV_ZqBasic $ M.basicUnsafeSlice z n v - basicOverlaps (MV_ZqBasic v1) (MV_ZqBasic v2) = M.basicOverlaps v1 v2 - basicInitialize (MV_ZqBasic v) = M.basicInitialize v - basicUnsafeNew n = MV_ZqBasic `liftM` M.basicUnsafeNew n - basicUnsafeReplicate n (ZqB x) = MV_ZqBasic `liftM` M.basicUnsafeReplicate n x - basicUnsafeRead (MV_ZqBasic v) z = ZqB `liftM` M.basicUnsafeRead v z - basicUnsafeWrite (MV_ZqBasic v) z (ZqB x) = M.basicUnsafeWrite v z x - basicClear (MV_ZqBasic v) = M.basicClear v - basicSet (MV_ZqBasic v) (ZqB x) = M.basicSet v x - basicUnsafeCopy (MV_ZqBasic v1) (MV_ZqBasic v2) = M.basicUnsafeCopy v1 v2 - basicUnsafeMove (MV_ZqBasic v1) (MV_ZqBasic v2) = M.basicUnsafeMove v1 v2 - basicUnsafeGrow (MV_ZqBasic v) n = MV_ZqBasic `liftM` M.basicUnsafeGrow v n - -instance (U.Unbox z) => V.Vector U.Vector (ZqBasic q z) where - basicUnsafeFreeze (MV_ZqBasic v) = V_ZqBasic `liftM` V.basicUnsafeFreeze v - basicUnsafeThaw (V_ZqBasic v) = MV_ZqBasic `liftM` V.basicUnsafeThaw v - basicLength (V_ZqBasic v) = V.basicLength v - basicUnsafeSlice z n (V_ZqBasic v) = V_ZqBasic $ V.basicUnsafeSlice z n v - basicUnsafeIndexM (V_ZqBasic v) z = ZqB `liftM` V.basicUnsafeIndexM v z - basicUnsafeCopy (MV_ZqBasic mv) (V_ZqBasic v) = V.basicUnsafeCopy mv v - elemseq _ = seq diff --git a/test-suite/CycTests.hs b/test-suite/CycTests.hs deleted file mode 100644 --- a/test-suite/CycTests.hs +++ /dev/null @@ -1,105 +0,0 @@ -{-# LANGUAGE RankNTypes, ScopedTypeVariables, NoImplicitPrelude, RebindableSyntax, - TypeOperators, FlexibleContexts, ConstraintKinds, TypeFamilies, - DataKinds #-} -module CycTests (cycTests) where - -import TestTypes - -import Crypto.Lol.CRTrans -import Crypto.Lol.Cyclotomic.Cyc -import Crypto.Lol.LatticePrelude -import Crypto.Lol.Cyclotomic.Tensor.CTensor -import Crypto.Lol.Cyclotomic.Tensor.RepaTensor -import Crypto.Lol.Types.FiniteField -import Crypto.Lol.Types.IrreducibleChar2 -import Crypto.Lol.Types.ZPP - -import Control.Monad (join, liftM2) - -import Data.Array.Repa.Eval (Elt) -import Data.Type.Natural hiding (zero) -import Data.Vector.Unboxed (Vector, Unbox) -import Data.Vector.Storable (Storable) - -import Test.Framework (testGroup, Test, defaultMain) -import Test.Framework.Providers.QuickCheck2 (testProperty) -import Test.QuickCheck (Property, property, Arbitrary) - -cycTests = [testGroup "coeffsPow" $ groupC $ wrapCmm'rToBool prop_coeffsBasis, - testGroup "crtSet" $ groupC $ wrapProxyCmm'rToBool prop_crtSet_pairs] - - - - - -type BasisCtx t m m' r = - (m `Divides` m', ZPP r, CElt t r, CElt t (ZPOf r)) - -prop_coeffsBasis :: forall t m m' r . (BasisCtx t m m' r) - => Proxy m -> Cyc t m' r -> Bool -prop_coeffsBasis _ x = - let xs = map embed (coeffsCyc Pow x :: [Cyc t m r]) - bs = proxy powBasis (Proxy::Proxy m) - in (sum $ zipWith (*) xs bs) == x - --- verifies that CRT set elements satisfy c_i * c_j = delta_ij * c_i --- necessary (not sufficient?) condition -prop_crtSet_pairs :: forall t m m' r . (BasisCtx t m m' r) - => Proxy m -> Proxy (Cyc t m' r) -> Bool -prop_crtSet_pairs pm _ = - let crtset = proxy crtSet pm :: [Cyc t m' r] - pairs = join (liftM2 (,)) crtset - in and $ map (\(a,b) -> if a == b then a*b == a else a*b == zero) pairs - -type BasisWrapCtx t m m' r = - (BasisCtx t m m' r, Show (Cyc t m' r), Arbitrary (t m' r)) - -wrapCmm'rToBool :: (BasisWrapCtx t m m' r) - => (Proxy m -> Cyc t m' r -> Bool) - -> Proxy (Cyc t) -> Proxy '(m,m',r) -> Property -wrapCmm'rToBool f _ _ = property $ f Proxy - -wrapProxyCmm'rToBool :: (BasisWrapCtx t m m' r) - => (Proxy m -> Proxy (Cyc t m' r) -> Bool) - -> Proxy (Cyc t) -> Proxy '(m,m',r) -> Property -wrapProxyCmm'rToBool f _ _ = property $ f Proxy Proxy - -groupC :: - (forall t m m' r . - (BasisWrapCtx t m m' r) - => Proxy (Cyc t) - -> Proxy '(m,m',r) - -> Property) - -> [Test] --- since we don't have any Tensor-level tests for coeffs/basis functions, --- we need to test all Tensors here. -groupC f = - [testGroup "FC CT" $ groupMM'R (f (Proxy::Proxy (Cyc CT))), - testGroup "FC RT" $ groupMM'R (f (Proxy::Proxy (Cyc RT)))] - -type BasisWrapCCtx m m' r = - (BasisWrapCtx RT m m' r, - BasisWrapCtx CT m m' r) - -groupMM'R :: - (forall m m' r . (BasisWrapCCtx m m' r) => Proxy '(m, m', r) -> Property) - -> [Test] -groupMM'R f = [testProperty "F1/F7/PP8" $ f (Proxy::Proxy '(F1, F7, Zq (PP2 N3))), - testProperty "F1/F7/PP2" $ f (Proxy::Proxy '(F1, F7, Zq (PP2 N1)))] -- add some more test cases - - - - --- for crtSet, take all pairwise products --- if elts are equal, id --- if not, zero - --- also do a cardinality check - --- checks cardinality of the CRT set -{- -prop_crtSet_card pm _ - let inferLen = length $ (proxy crtSetDec pm :: [t m' r]) - expectLen = - in --} diff --git a/test-suite/Main.hs b/test-suite/Main.hs deleted file mode 100644 --- a/test-suite/Main.hs +++ /dev/null @@ -1,19 +0,0 @@ - - ---module Tests where - -import SHETests -import TensorTests -import CycTests -import ZqTests - -import Test.Framework - -main :: IO () -main = do - flip defaultMainWithArgs ["--threads=1","--maximum-generated-tests=1000"] - [ testGroup "Tensor Tests" tensorTests - , testGroup "Cyc Tests" cycTests - , testGroup "SHE Tests" sheTests - , testGroup "Zq Tests" zqTests - ] diff --git a/test-suite/SHETests.hs b/test-suite/SHETests.hs deleted file mode 100644 --- a/test-suite/SHETests.hs +++ /dev/null @@ -1,442 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables, NoImplicitPrelude, RebindableSyntax, - DataKinds, TypeOperators, NoMonomorphismRestriction, NoMonoLocalBinds, - ConstraintKinds, TypeFamilies, FlexibleContexts, PartialTypeSignatures, - RankNTypes, MultiParamTypeClasses, FlexibleInstances, UndecidableInstances, - RebindableSyntax, GADTs, PolyKinds, KindSignatures #-} - -module SHETests (sheTests) where - -import TestTypes - -import Control.Applicative hiding ((<$$>)) -import Control.Monad -import Control.Monad.Random - -import Crypto.Lol.LatticePrelude hiding (lift) -import Crypto.Lol.Cyclotomic.Cyc -import Crypto.Lol.Applications.SymmSHE -import Crypto.Lol.CRTrans -import Crypto.Lol.Gadget -import Crypto.Lol.Cyclotomic.Linear - -import Crypto.Lol.Cyclotomic.Tensor.RepaTensor -import qualified Crypto.Lol.Cyclotomic.Tensor.CTensor as CT -import Crypto.Lol.Cyclotomic.Tensor.CTensor hiding (CT) -import Crypto.Lol.Types.ZqBasic - -import Data.Array.Repa.Eval (Elt) -import Data.Type.Natural hiding (zero,one) -import Data.Typeable -import Data.Vector.Unboxed (Unbox) -import Data.Vector.Storable (Storable) - -import Test.Framework -import Test.Framework.Providers.QuickCheck2 -import Test.QuickCheck hiding (generate,output) -import Test.QuickCheck.Monadic (monadicIO, assert) - -v = 1 :: Double - -sheTests = - [testGroup "Tunnel" $ tunnelTests, - testGroup "Dec . Enc (Unrestricted)" $ groupCEnc $ wrapEnc prop_encDec, - testGroup "Dec . Enc (MSD)" $ groupCEnc $ wrapEnc prop_encDec_MSD, - testGroup "AddPub" $ groupCEnc $ wrapEnc prop_addPub, - testGroup "MulPub" $ groupCEnc $ wrapEnc prop_mulPub, - testGroup "ScalarPub" $ groupCEnc $ wrapScalar prop_addScalar, - testGroup "CTAdd" $ groupCEnc $ wrapMath prop_ctadd, - testGroup "CTMul" $ groupCEnc $ wrapMath prop_ctmul, - testGroup "CT zero" $ groupCEnc $ wrapConst prop_ctzero, - testGroup "CT one" $ groupCEnc $ wrapConst prop_ctone, - testGroup "ModSwPT" modSwPTTests, - testGroup "KSLin" $ groupCKS $ wrapKSLin prop_ksLin, - testGroup "KSQuad" $ groupCKS $ wrapKSQuad prop_ksQuad, - testGroup "Embed" $ groupCTwEm $ wrapEm prop_ctembed, - testGroup "Twace" $ groupCTwEm $ wrapTw prop_cttwace - ] - -type EncDecCtx c m m' zp zq = - (GenSKCtx c m (LiftOf zp) Double, - EncryptCtx c m m' (LiftOf zp) zp zq, - -- constraints from decryptUnrestricted - ToSDCtx c m' zp zq, Lift' zq, Reduce (LiftOf zq) zp) - -prop_encDec :: forall m zp c m' zq . - (EncDecCtx c m m' zp zq) - => Proxy '(m', zq) -> Cyc c m zp -> Property -prop_encDec _ x = monadicIO $ do - sk :: SK (Cyc c m' (LiftOf zp)) <- genSK v - y :: CT m zp (Cyc c m' zq) <- encrypt sk x - let x' = decryptUnrestricted sk $ y - assert $ x == x' - -prop_encDec_MSD :: forall m zp c m' zq . - (EncDecCtx c m m' zp zq) - => Proxy '(m', zq) -> Cyc c m zp -> Property -prop_encDec_MSD _ x = monadicIO $ do - sk :: SK (Cyc c m' (LiftOf zp)) <- genSK v - y :: CT m zp (Cyc c m' zq) <- encrypt sk x - let x' = decryptUnrestricted sk $ toMSD y - assert $ x == x' - -prop_addPub :: forall m zp c m' zq . - (EncDecCtx c m m' zp zq) - => Proxy '(m', zq) -> Cyc c m zp -> Property -prop_addPub _ x = monadicIO $ do - sk :: SK (Cyc c m' (LiftOf zp)) <- genSK v - y :: CT m zp (Cyc c m' zq) <- encrypt sk x - let y' = addPublic x y - x' = decryptUnrestricted sk y' - assert $ x' == (x+x) - -prop_mulPub :: forall m zp c m' zq . - (EncDecCtx c m m' zp zq) - => Proxy '(m', zq) -> Cyc c m zp -> Property -prop_mulPub _ x = monadicIO $ do - sk :: SK (Cyc c m' (LiftOf zp)) <- genSK v - y :: CT m zp (Cyc c m' zq) <- encrypt sk x - let y' = mulPublic x y - x' = decryptUnrestricted sk y' - assert $ x' == (x*x) - -prop_addScalar :: forall m zp c m' zq . - (EncDecCtx c m m' zp zq) - => Proxy '(m', zq) -> zp -> Cyc c m zp -> Property -prop_addScalar _ s x = monadicIO $ do - sk :: SK (Cyc c m' (LiftOf zp)) <- genSK v - y :: CT m zp (Cyc c m' zq) <- encrypt sk x - let y' = addScalar s y - x' = decryptUnrestricted sk y' - assert $ x' == ((scalarCyc s)+x) - -prop_ctadd :: forall m zp c m' zq . - (EncDecCtx c m m' zp zq) - => Proxy '(m', zq) -> Cyc c m zp -> Cyc c m zp -> Property -prop_ctadd _ x1 x2 = monadicIO $ do - sk :: SK (Cyc c m' (LiftOf zp)) <- genSK v - y1 :: CT m zp (Cyc c m' zq) <- encrypt sk x1 - y2 :: CT m zp (Cyc c m' zq) <- encrypt sk x2 - let y' = y1+y2 - x' = decryptUnrestricted sk y' - assert $ x1+x2 == x' - -prop_ctmul :: forall m zp c m' zq . - (EncDecCtx c m m' zp zq) - => Proxy '(m', zq) -> Cyc c m zp -> Cyc c m zp -> Property -prop_ctmul _ x1 x2 = monadicIO $ do - sk :: SK (Cyc c m' (LiftOf zp)) <- genSK v - y1 :: CT m zp (Cyc c m' zq) <- encrypt sk x1 - y2 :: CT m zp (Cyc c m' zq) <- encrypt sk x2 - let y' = y1*y2 - x' = decryptUnrestricted sk y' - assert $ x1*x2 == x' - -prop_ctzero :: forall m zp c m' zq . - (EncDecCtx c m m' zp zq) - => Proxy '(m', zq) -> Proxy (Cyc c m zp) -> Property -prop_ctzero _ _ = monadicIO $ do - sk :: SK (Cyc c m' (LiftOf zp)) <- genSK v - let z = decryptUnrestricted sk (zero :: CT m zp (Cyc c m' zq)) - assert $ zero == z - -prop_ctone :: forall m zp c m' zq . - (EncDecCtx c m m' zp zq) - => Proxy '(m', zq) -> Proxy (Cyc c m zp) -> Property -prop_ctone _ _ = monadicIO $ do - sk :: SK (Cyc c m' (LiftOf zp)) <- genSK v - let z = decryptUnrestricted sk (one :: CT m zp (Cyc c m' zq)) - assert $ one == z - -type EncDecWrapCtx c m m' zp zq = - (EncDecCtx c m m' zp zq, Show (Cyc c m zp), Arbitrary (c m zp), Show zp, Arbitrary zp) - -wrapEnc :: (EncDecWrapCtx c m m' zp zq) - => (Proxy '(m', zq) -> Cyc c m zp -> Property) - -> Proxy (Cyc c) -> Proxy '(m, m', zp, zq) -> Property -wrapEnc f _ _ = property $ f Proxy - -wrapScalar :: (EncDecWrapCtx c m m' zp zq) - => (Proxy '(m', zq) -> zp -> Cyc c m zp -> Property) - -> Proxy (Cyc c) -> Proxy '(m, m', zp, zq) -> Property -wrapScalar f _ _ = property $ f Proxy - -wrapMath :: (EncDecWrapCtx c m m' zp zq) - => (Proxy '(m', zq) -> Cyc c m zp -> Cyc c m zp -> Property) - -> Proxy (Cyc c) -> Proxy '(m, m', zp, zq) -> Property -wrapMath f _ _ = property $ f Proxy - -wrapConst :: (EncDecWrapCtx c m m' zp zq) - => (Proxy '(m', zq) -> Proxy (Cyc c m zp) -> Property) - -> Proxy (Cyc c) -> Proxy '(m, m', zp, zq) -> Property -wrapConst f _ _ = property $ f Proxy Proxy - -groupCEnc :: - (forall c m m' zp zq . (EncDecWrapCtx c m m' zp zq) - => Proxy (Cyc c) - -> Proxy '(m, m', zp, zq) - -> Property) - -> [Test] -groupCEnc f = - [testGroup "CT" $ groupTypesEnc (f (Proxy::Proxy (Cyc CT.CT))), - testGroup "RT" $ groupTypesEnc (f (Proxy::Proxy (Cyc RT)))] - -type EncDecWrapCCtx m m' zp zq = - (EncDecWrapCtx RT m m' zp zq, - EncDecWrapCtx CT.CT m m' zp zq) - -groupTypesEnc :: - (forall m m' zp zq . (EncDecWrapCCtx m m' zp zq) - => Proxy '(m, m', zp, zq) - -> Property) - -> [Test] -groupTypesEnc f = [testProperty "F7/F7 /ZP2/ZQ2" $ f (Proxy::Proxy '(F7, F7, ZP2, ZQ2)), - testProperty "F7/F21/ZP2/ZQ2" $ f (Proxy::Proxy '(F7, F21, ZP2, ZQ2)), - testProperty "F2/F8 /ZP2/Q536871001" $ f (Proxy::Proxy '(F2,F8,ZP2,Zq Q536871001)), - testProperty "F1/F8 /ZP2/Q536871001" $ f (Proxy::Proxy '(F1,F8,ZP2,Zq Q536871001)), - testProperty "F4/F12/ZP2/SmoothZQ1" $ f (Proxy::Proxy '(F4,F12,ZP2,SmoothZQ1)), - testProperty "F4/F8/ZP3/SmoothQ1" $ f (Proxy::Proxy '(F4,F8,ZP3, Zq SmoothQ1)), - testProperty "F7/F7 /ZP4/ZQ2" $ f (Proxy::Proxy '(F7, F7, ZP4, ZQ2)), - testProperty "F7/F21/ZP4/ZQ2" $ f (Proxy::Proxy '(F7, F21, ZP4, ZQ2)), - testProperty "F1/F4/ZP4/ZQ1" $ f (Proxy::Proxy '(F1,F4,ZP4,ZQ1)), - testProperty "F4/F4/ZP4/ZQ1" $ f (Proxy::Proxy '(F4,F4,ZP4,ZQ1)), - testProperty "F14/F14/ZP4/ZQ1" $ f (Proxy::Proxy '(F14,F14,ZP4,ZQ1)), - testProperty "F28/F28/ZP4/ZQ1" $ f (Proxy::Proxy '(F28,F28,ZP4,ZQ1)), - testProperty "F28/F28/ZP4/Q80221" $ f (Proxy::Proxy '(F28,F28,ZP4,Zq Q80221)), - testProperty "F1/F8 /ZP4/Q536871001" $ f (Proxy::Proxy '(F1,F8,ZP4,Zq Q536871001)), - testProperty "F2/F8 /ZP4/Q536871001" $ f (Proxy::Proxy '(F2,F8,ZP4,Zq Q536871001)), - testProperty "F4/F12/ZP8/SmoothZQ1" $ f (Proxy::Proxy '(F4,F12,ZP8,SmoothZQ1)) - ] - --- one-off tests, no wrapper - -prop_modSwPT :: forall m zp c m' zq z v zp' . - (EncryptCtx c m m' z zp zq, - GenSKCtx c m z v, - DecryptCtx c m m' z zp' zq, - ModSwitchPTCtx c m' zp zp' zq, - RescaleCyc (Cyc c) zp zp', Mod zp', - CElt c Int64, CElt c zq, - z ~ LiftOf zp', v ~ Double, ModRep zp' ~ ModRep zp) - => Proxy '(m', zq, zp') -> Cyc c m zp -> Property -prop_modSwPT _ x = monadicIO $ do - let p = proxy modulus (Proxy::Proxy zp) - p' = proxy modulus (Proxy::Proxy zp') - x' = (fromIntegral $ p `div` p') * x - sk :: SK (Cyc c m' z) <- genSK v - y :: CT m zp (Cyc c m' zq) <- encrypt sk x' - let y' = modSwitchPT y :: CT m zp' (Cyc c m' zq) - x'' = decrypt sk y' - assert $ x'' == rescaleCyc Dec x' - -modSwPTTests = - [testProperty "RT/F7/F21/ZQ1/ZP4/ZP8" (prop_modSwPT (Proxy::Proxy '(F21, ZQ1, ZP4)) :: Cyc RT F7 ZP8 -> Property), - testProperty "RT/F7/F42/ZQ1/ZP2/ZP4" (prop_modSwPT (Proxy::Proxy '(F42, ZQ1, ZP2)) :: Cyc RT F7 ZP4 -> Property), - testProperty "CT/F7/F21/ZQ1/ZP4/ZP8" (prop_modSwPT (Proxy::Proxy '(F21, ZQ1, ZP4)) :: Cyc CT.CT F7 ZP8 -> Property), - testProperty "CT/F7/F42/ZQ1/ZP2/ZP4" (prop_modSwPT (Proxy::Proxy '(F42, ZQ1, ZP2)) :: Cyc CT.CT F7 ZP4 -> Property)] - - -tunnelTests = - [testProperty "RT/F7/F21/ZQ1/ZP4/ZP8" - (prop_ringTunnel (Proxy::Proxy '(F40,ZQ1,F20,F60,TrivGad,ZQ2)) :: Cyc RT F8 ZP4 -> Property)] - -prop_ringTunnel :: forall c e r s e' r' s' z zp zq zq' gad . - (TunnelCtx c e r s e' r' s' z zp zq zq' gad, - EncryptCtx c r r' z zp zq, - GenSKCtx c r' z Double, - GenSKCtx c s' z Double, - DecryptCtx c s s' z zp zq, - Random (Cyc c s zp), - e ~ FGCD r s, Fact e) - => Proxy '(r', zq, s, s', gad, zq') -> Cyc c r zp -> Property -prop_ringTunnel _ x = monadicIO $ do - let totr = proxy totientFact (Proxy::Proxy r) - tote = proxy totientFact (Proxy::Proxy e) - basisSize = totr `div` tote - -- choose a random linear function of the appropriate size - bs :: [Cyc c s zp] <- replicateM basisSize getRandom - let f = (linearDec bs) \\ (gcdDivides (Proxy::Proxy r) (Proxy::Proxy s)) :: Linear c zp e r s - expected = evalLin f x \\ (gcdDivides (Proxy::Proxy r) (Proxy::Proxy s)) - skin :: SK (Cyc c r' (LiftOf zp)) <- genSK v - skout :: SK (Cyc c s' (LiftOf zp)) <- genSK v - y :: CT r zp (Cyc c r' zq) <- encrypt skin x - tunn <- proxyT (tunnelCT f skout skin) (Proxy::Proxy (gad,zq')) - let y' = tunn y - actual = decrypt skout y' :: Cyc c s zp - assert $ expected == actual - - - - - - - - - - - - -type KsCtx m zp z c m' zq gad zq' deczq = - (GenSKCtx c m' z Double, - z ~ LiftOf zp, - EncryptCtx c m m' z zp zq, - KeySwitchCtx gad c m' zp zq zq', - KSHintCtx gad c m' z zq', - RescaleCyc (Cyc c) zq deczq, - DecryptCtx c m m' z zp deczq) - -prop_ksLin :: forall m zp z c m' zq gad zq' deczq . (KsCtx m zp z c m' zq gad zq' deczq) - => Proxy '(m', zq, gad, zq', deczq) -> Cyc c m zp -> Property -prop_ksLin (_ :: Proxy '(m', zq, gad, zq', deczq)) x = monadicIO $ do - sk1 :: SK (Cyc c m' (LiftOf zp)) <- genSK v - sk2 :: SK (Cyc c m' (LiftOf zp)) <- genSK v - y :: CT m zp (Cyc c m' zq) <- encrypt sk1 x - ks <- proxyT (keySwitchLinear sk2 sk1) (Proxy::Proxy (gad,zq')) - let y' :: CT m zp (Cyc c m' zq) = ks y - x' = decrypt sk2 (rescaleLinearCT y' :: CT m zp (Cyc c m' deczq)) - assert $ x == x' - -prop_ksQuad :: forall m zp z c m' zq gad zq' deczq . (KsCtx m zp z c m' zq gad zq' deczq) - => Proxy '(m', zq, gad, zq', deczq) -> Cyc c m zp -> Cyc c m zp -> Property -prop_ksQuad (_ :: Proxy '(m', zq, gad, zq', deczq)) x1 x2 = monadicIO $ do - sk :: SK (Cyc c m' (LiftOf zp)) <- genSK v - y1 :: CT m zp (Cyc c m' zq) <- encrypt sk x1 - y2 :: CT m zp (Cyc c m' zq) <- encrypt sk x2 - ks <- proxyT (keySwitchQuadCirc sk) (Proxy::Proxy (gad,zq')) - let y' = ks (y1*y2) - x' = decrypt sk (rescaleLinearCT y' :: CT m zp (Cyc c m' deczq)) - assert $ x1*x2 == x' - -type KsWrapCtx m zp z c m' zq gad zq' deczq = - (KsCtx m zp z c m' zq gad zq' deczq, Show (Cyc c m zp), Arbitrary (c m zp)) - -wrapKSLin :: forall m zp z c m' zq gad zq' deczq . (KsWrapCtx m zp z c m' zq gad zq' deczq) - => (Proxy '(m', zq, gad, zq', deczq) -> Cyc c m zp -> Property) - -> Proxy (Cyc c) -> Proxy gad -> Proxy '(m, m', zp, zq, zq', deczq) -> Property -wrapKSLin f _ _ _ = property $ f Proxy - -wrapKSQuad :: forall m zp z c m' zq gad zq' deczq . (KsWrapCtx m zp z c m' zq gad zq' deczq) - => (Proxy '(m', zq, gad, zq',deczq) -> Cyc c m zp -> Cyc c m zp -> Property) - -> Proxy (Cyc c) -> Proxy gad -> Proxy '(m, m', zp, zq, zq', deczq) -> Property -wrapKSQuad f _ _ _ = property $ f Proxy - -groupCKS :: - (forall c m m' zp z zq zq' gad deczq . (KsWrapCtx m zp z c m' zq gad zq' deczq) - => Proxy (Cyc c) - -> Proxy gad - -> Proxy '(m, m', zp, zq, zq', deczq) - -> Property) - -> [Test] -groupCKS f = - [testGroup "CT" $ groupGadKS $ f (Proxy::Proxy (Cyc CT.CT)), - testGroup "RT" $ groupGadKS $ f (Proxy::Proxy (Cyc RT))] - -type KsWrapCCtx m zp z m' zq gad zq' deczq = - (KsWrapCtx m zp z RT m' zq gad zq' deczq, - KsWrapCtx m zp z CT.CT m' zq gad zq' deczq) - -groupGadKS :: - (forall m m' zp z zq zq' gad deczq . (KsWrapCCtx m zp z m' zq gad zq' deczq) - => Proxy gad - -> Proxy '(m, m', zp, zq, zq', deczq) - -> Property) - -> [Test] -groupGadKS f = - [testGroup "TrivGad" $ groupTypesKS (f (Proxy::Proxy TrivGad))] - --testGroup "Base16" $ groupTypesKS (f (Proxy::Proxy (BaseBGad N16)))] - -type KsWrapCGadCtx m zp z m' zq zq' deczq = - (KsWrapCCtx m zp z m' zq TrivGad zq' deczq) - -groupTypesKS :: - (forall m m' zp z zq zq' deczq . (KsWrapCGadCtx m zp z m' zq zq' deczq) - => Proxy '(m, m', zp, zq, zq', deczq) - -> Property) - -> [Test] -groupTypesKS f = - [testProperty "F1/F7/ZP2/ZQ1/ZQ2" $ f (Proxy::Proxy '(F1, F7, ZP2, ZQ1, ZQ2, ZQ1)), - testProperty "F2/F4/ZP2/SmoothZQ1/SmoothZQ2" $ f (Proxy::Proxy '(F2, F4, ZP8, SmoothZQ1, SmoothZQ2, SmoothZQ1)), - testProperty "F4/F12/ZP2/SmoothZQ1/SmoothZQ2" $ f (Proxy::Proxy '(F4, F12, ZP2, SmoothZQ1, SmoothZQ2, SmoothZQ1)), - testProperty "F8/F64/ZP2/SmoothZQ1/SmoothZQ2" $ f (Proxy::Proxy '(F8, F64, ZP2, SmoothZQ1, SmoothZQ2, SmoothZQ1)), - testProperty "F3/F27/ZP2/SmoothZQ1/SmoothZQ2" $ f (Proxy::Proxy '(F3, F27, ZP2, SmoothZQ1, SmoothZQ2, SmoothZQ1)), - testProperty "F2/F4/ZP2/SmoothZQ1/SmoothZQ2" $ f (Proxy::Proxy '(F2, F4, ZP8, SmoothZQ2, SmoothZQ3, SmoothZQ1)), - testProperty "F4/F12/ZP2/SmoothZQ1/SmoothZQ2" $ f (Proxy::Proxy '(F4, F12, ZP2, SmoothZQ2, SmoothZQ3, SmoothZQ1)), - testProperty "F8/F64/ZP2/SmoothZQ1/SmoothZQ2" $ f (Proxy::Proxy '(F8, F64, ZP2, SmoothZQ2, SmoothZQ3, SmoothZQ1)), - testProperty "F3/F27/ZP2/SmoothZQ1/SmoothZQ2" $ f (Proxy::Proxy '(F3, F27, ZP2, SmoothZQ2, SmoothZQ3, SmoothZQ1))] - - - - - - - - - - - - - - - - - - -type TwEmCtx c m m' t t' zp zq = - (EncryptCtx c m m' (LiftOf zp) zp zq, - GenSKCtx c m (LiftOf zp) Double, - DecryptCtx c m m' (LiftOf zp) zp zq, - t `Divides` t', m `Divides` t, m' `Divides` t', m ~ FGCD m' t) - -prop_ctembed :: forall c m m' t t' zp zq . - (TwEmCtx c m m' t t' zp zq) - => Proxy '(m', zq, t, t') -> Cyc c m zp -> Property -prop_ctembed _ x = monadicIO $ do - sk :: SK (Cyc c m' (LiftOf zp)) <- genSK v - y :: CT m zp (Cyc c m' zq) <- encrypt sk x - let y' = embedCT y :: CT t zp (Cyc c t' zq) - x' = decrypt (embedSK sk) y' - assert $ (embed x :: Cyc c t zp) == x' - -prop_cttwace :: forall c m m' t t' zp zq . - (TwEmCtx c t t' m m' zp zq) - => Proxy '(m', zq, t, t') -> Cyc c m zp -> Property -prop_cttwace _ x = monadicIO $ do - sk :: SK (Cyc c t' (LiftOf zp)) <- genSK v - y :: CT m zp (Cyc c m' zq) <- encrypt (embedSK sk) x - let y' = twaceCT y :: CT t zp (Cyc c t' zq) - x' = decrypt sk y' - assert $ (twace x :: Cyc c t zp) == x' - -type TwEmWrapCtx c m m' t t' zp zq = - (TwEmCtx c m m' t t' zp zq, Show (Cyc c m zp), Show (Cyc c t zp), Arbitrary (c m zp), Arbitrary (c t zp)) - -wrapEm :: (TwEmWrapCtx c m m' t t' zp zq) - => (Proxy '(m', zq, t, t') -> Cyc c m zp -> Property) - -> Proxy (Cyc c) -> Proxy '(m, m', t, t', zp, zq) -> Property -wrapEm f _ _ = property $ f Proxy - -wrapTw :: (TwEmWrapCtx c t t' m m' zp zq) - => (Proxy '(m', zq, t, t') -> Cyc c m zp -> Property) - -> Proxy (Cyc c) -> Proxy '(t, t', m, m', zp, zq) -> Property -wrapTw f _ _ = property $ f Proxy - -groupCTwEm :: - (forall c m m' t t' zp zq . (TwEmWrapCtx c m m' t t' zp zq) - => Proxy (Cyc c) - -> Proxy '(m, m', t, t', zp, zq) - -> Property) - -> [Test] -groupCTwEm f = - [testGroup "CT" $ groupTypesTwEm (f (Proxy::Proxy (Cyc CT.CT))), - testGroup "RT" $ groupTypesTwEm (f (Proxy::Proxy (Cyc RT)))] - -type TwEmWrapCCtx m m' t t' zp zq = - (TwEmWrapCtx RT m m' t t' zp zq, - TwEmWrapCtx CT.CT m m' t t' zp zq) - -groupTypesTwEm :: - (forall m m' t t' zp zq . (TwEmWrapCCtx m m' t t' zp zq) - => Proxy '(m, m', t, t', zp, zq) - -> Property) - -> [Test] -groupTypesTwEm f = - [testProperty "F1/F7/F3/F21/ZP2/ZQ1" $ f (Proxy::Proxy '(F1, F7, F3, F21, ZP2, ZQ1))] diff --git a/test-suite/TensorTests.hs b/test-suite/TensorTests.hs deleted file mode 100644 --- a/test-suite/TensorTests.hs +++ /dev/null @@ -1,368 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude, RebindableSyntax, ScopedTypeVariables, - DataKinds, TypeOperators, KindSignatures, RankNTypes, GADTs, - MultiParamTypeClasses, ConstraintKinds, FlexibleInstances, RebindableSyntax, - FlexibleContexts, UndecidableInstances, TypeFamilies, DeriveDataTypeable #-} - -module TensorTests (tensorTests) where - - -import TestTypes - -import Crypto.Lol.CRTrans -import Crypto.Lol.LatticePrelude as LP hiding (round) -import Crypto.Lol.Cyclotomic.Tensor -import Crypto.Lol.Cyclotomic.Tensor.CTensor -import Crypto.Lol.Cyclotomic.Tensor.RepaTensor - -import Control.Applicative -import Control.Monad.Random - -import Data.Array.Repa.Eval (Elt) -import Data.Constraint -import Data.Maybe -import Data.Vector.Unboxed as U -import Data.Vector.Storable (Storable) - -import Test.Framework -import Test.Framework.Providers.QuickCheck2 -import Test.QuickCheck hiding (generate,output) - -tensorTests = - [testGroup "fmap comparison" $ groupTMR $ wrapTmrToBool prop_fmap, - testGroup "fmap comparison 2" $ groupTMR $ wrapTmrToBool prop_fmap2, - testGroup "Extension Mult" $ groupExtTests $ wrap2TmrToBool prop_mul_ext, - - -- inverse property - tremTests, - gInvGTests, - testGroup "CRTInv.CRT" $ groupTMR $ wrapTmrToBool prop_crt_inv, - testGroup "LInv.L" $ groupTMR $ wrapTmrToBool prop_l_inv, - - -- commutative property - gCommuteTests, - embedCommuteTests, - twaceCommuteTests, - testGroup "Scalar" $ groupTMR $ wrapRToBool prop_scalar_crt, - twaceInvarTests - ] - - -type TMRCtx t m r = (Tensor t, Fact m, m `Divides` m, CRTrans r, TElt t r, CRTEmbed r, - TElt t (CRTExt r), Eq r, ZeroTestable r, IntegralDomain r) - -prop_fmap :: (TMRCtx t m r) => t m r -> Bool -prop_fmap x = fmapT id x == x \\ witness entailEqT x \\ witness entailIndexT x - -prop_fmap2 :: (TMRCtx t m r) => t m r -> Bool -prop_fmap2 x = (fmapT id x) == (fmap id x) \\ witness entailEqT x \\ witness entailIndexT x - --- tests that multiplication in the extension ring matches CRT multiplication -prop_mul_ext :: forall t m r . (TMRCtx t m r) - => t m r -> t m r -> Bool -prop_mul_ext x y = - 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 = x * y - z' = fmapT fromExt $ (fmapT toExt x) * (fmapT toExt y) - in z == z') \\ witness entailEqT x - \\ witness entailRingT x - \\ witness entailRingT (fmap toExt x) - \\ witness entailIndexT x - -gInvGTests = testGroup "GInv.G == id" [ - testGroup "Pow basis" $ groupTMR $ wrapTmrToBool prop_ginv_pow, - testGroup "Dec basis" $ groupTMR $ wrapTmrToBool prop_ginv_dec, - testGroup "CRT basis" $ groupTMR $ wrapTmrToBool prop_ginv_crt] - --- divG . mulG == id in Pow basis -prop_ginv_pow :: (TMRCtx t m r) => t m r -> Bool -prop_ginv_pow x = (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 :: (TMRCtx t m r) => t m r -> Bool -prop_ginv_dec x = (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 :: (TMRCtx t m r) => t m r -> Bool -prop_ginv_crt x = fromMaybe (error "no CRT in prop_ginv_crt") $ do - divGCRT' <- divGCRT - mulGCRT' <- mulGCRT - return $ (divGCRT' $ mulGCRT' x) == x \\ witness entailEqT x - --- crtInv . crt == id -prop_crt_inv :: (TMRCtx t m r) => t m r -> Bool -prop_crt_inv x = fromMaybe (error "no CRT in prop_crt_inv") $ do - crt' <- crt - crtInv' <- crtInv - return $ (crtInv' $ crt' x) == x \\ witness entailEqT x - --- lInv . l == id -prop_l_inv :: (TMRCtx t m r) => t m r -> Bool -prop_l_inv x = (lInv $ l x) == x \\ witness entailEqT x - --- scalarCRT = crt . scalarPow -prop_scalar_crt :: forall t m r . (TMRCtx t m r) - => Proxy (t m r) -> r -> Bool -prop_scalar_crt _ r = fromMaybe (error "no CRT in prop_scalar_crt") $ do - scalarCRT' <- scalarCRT - crt' <- crt - return $ (scalarCRT' r :: t m r) == (crt' $ scalarPow r) - \\ proxy entailEqT (Proxy::Proxy (t m r)) - -gCommuteTests = testGroup "G commutes with L" [ - testGroup "Dec basis" $ groupTMR $ wrapTmrToBool prop_g_dec, - testGroup "CRT basis" $ groupTMR $ wrapTmrToBool prop_g_crt] - --- mulGDec == lInv. mulGPow . l -prop_g_dec :: (TMRCtx t m r) => t m r -> Bool -prop_g_dec x = (mulGDec x) == (lInv $ mulGPow $ l x) \\ witness entailEqT x - -prop_g_crt :: (TMRCtx t m r) => t m r -> Bool -prop_g_crt x = fromMaybe (error "no CRT in prop_g_crt") $ do - mulGCRT' <- mulGCRT - crt' <- crt - crtInv' <- crtInv - return $ (mulGCRT' x) == (crt' $ mulGPow $ crtInv' x) \\ witness entailEqT x - -type TMRWrapCtx t m r = (TMRCtx t m r, Show (t m r), Arbitrary (t m r), Show r, Arbitrary r) - -wrap2TmrToBool :: (TMRWrapCtx t m r) => (t m r -> t m r -> Bool) - -> Proxy t -> Proxy '(m,r) -> Property -wrap2TmrToBool f _ _ = property f - -wrapTmrToBool :: (TMRWrapCtx t m r) => (t m r -> Bool) - -> Proxy t -> Proxy '(m,r) -> Property -wrapTmrToBool f _ _ = property f - -wrapRToBool :: (TMRWrapCtx t m r) => (Proxy (t m r) -> r -> Bool) - -> Proxy t -> Proxy '(m,r) -> Property -wrapRToBool f _ _ = property $ f Proxy - -groupTMR :: (forall t m r . (TMRWrapCtx t m r) - => Proxy t - -> Proxy '(m,r) - -> Property) -> [Test] -groupTMR f = - [testGroup "CT" $ groupMR (f (Proxy::Proxy CT)), - testGroup "RT" $ groupMR (f (Proxy::Proxy RT))] - -groupExtTests :: (forall t m r . (TMRWrapCtx t m r) - => Proxy t - -> Proxy '(m,r) - -> Property) -> [Test] -groupExtTests f = - [testGroup "CT" $ groupMRExt (f (Proxy::Proxy CT)), - testGroup "RT" $ groupMRExt (f (Proxy::Proxy RT))] - -type MRWrapCtx m r = (TMRWrapCtx CT m r, TMRWrapCtx RT m r) - -groupMR :: (forall m r . (MRWrapCtx m r) => Proxy '(m, r) -> Property) - -> [Test] -groupMR f = [testProperty "F7/Q29" $ f (Proxy::Proxy '(F7, Zq Q29)), - testProperty "F12/SmoothZQ1" $ f (Proxy::Proxy '(F12, SmoothZQ1)), - testProperty "F1/Q17" $ f (Proxy::Proxy '(F1, Zq Q17)), - testProperty "F2/Q17" $ f (Proxy::Proxy '(F2, Zq Q17)), - testProperty "F4/Q17" $ f (Proxy::Proxy '(F4, Zq Q17)), - testProperty "F8/Q17" $ f (Proxy::Proxy '(F8, Zq Q17)), - testProperty "F21/Q8191" $ f (Proxy::Proxy '(F21, Zq Q8191)), - testProperty "F42/Q8191" $ f (Proxy::Proxy '(F42, Zq Q8191)), - testProperty "F42/ZQ1" $ f (Proxy::Proxy '(F42, ZQ1)), - testProperty "F42/ZQ2" $ f (Proxy::Proxy '(F42, ZQ2))] - --- we can't include a large modulus here because there is not enough --- precision in Doubles to handle the error -groupMRExt :: (forall m r . (MRWrapCtx m r) => Proxy '(m, r) -> Property) - -> [Test] -groupMRExt f = [testProperty "F7/Q29" $ f (Proxy::Proxy '(F7, Zq Q29)), - testProperty "F1/Q17" $ f (Proxy::Proxy '(F1, Zq Q17)), - testProperty "F2/Q17" $ f (Proxy::Proxy '(F2, Zq Q17)), - testProperty "F4/Q17" $ f (Proxy::Proxy '(F4, Zq Q17)), - testProperty "F8/Q17" $ f (Proxy::Proxy '(F8, Zq Q17)), - testProperty "F21/Q8191" $ f (Proxy::Proxy '(F21, Zq Q8191)), - testProperty "F42/Q8191" $ f (Proxy::Proxy '(F42, Zq Q8191)), - testProperty "F42/ZQ1" $ f (Proxy::Proxy '(F42, ZQ1)), - testProperty "F42/ZQ2" $ f (Proxy::Proxy '(F42, ZQ2))] - - - - - - - - - - - -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) - --- groups related tests -tremTests = testGroup "Tr.Em == id" [ - testGroup "Pow basis" $ groupTMM'R $ wrapTmm'rToBool prop_trem_pow, - testGroup "Dec basis" $ groupTMM'R $ wrapTmm'rToBool prop_trem_dec, - testGroup "CRT basis" $ groupTMM'R $ wrapTmm'rToBool 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) - => Proxy m' -> t m r -> Bool -prop_trem_pow _ x = (twacePowDec $ (embedPow x :: t m' r)) == x \\ witness entailEqT x - --- tests that twace . embed == id in the Dec basis -prop_trem_dec :: forall t m m' r . (TMM'RCtx t m m' r) - => Proxy m' -> t m r -> Bool -prop_trem_dec _ x = (twacePowDec $ (embedDec x :: t m' r)) == x \\ witness entailEqT x - --- tests that twace . embed == id in the CRT basis -prop_trem_crt :: forall t m m' r . (TMM'RCtx t m m' r) - => Proxy m' -> t m r -> Bool -prop_trem_crt _ x = fromMaybe (error "no CRT in prop_trem_crt") $ - (x==) <$> (twaceCRT <*> (embedCRT <*> pure x :: Maybe (t m' r))) \\ witness entailEqT x - -embedCommuteTests = testGroup "Em commutes with L" [ - testGroup "Dec basis" $ groupTMM'R $ wrapTmm'rToBool prop_embed_dec, - testGroup "CRT basis" $ groupTMM'R $ wrapTmm'rToBool prop_embed_crt] - --- embedDec == lInv . embedPow . l -prop_embed_dec :: forall t m m' r . (TMM'RCtx t m m' r) => Proxy m' -> t m r -> Bool -prop_embed_dec _ x = (embedDec x :: t m' r) == (lInv $ embedPow $ l x) - \\ proxy entailEqT (Proxy::Proxy (t m' r)) - --- embedCRT = crt . embedPow . crtInv -prop_embed_crt :: forall t m m' r . (TMM'RCtx t m m' r) => Proxy m' -> t m r -> Bool -prop_embed_crt _ x = fromMaybe (error "no CRT in prop_embed_crt") $ do - crt' <- crt - crtInv' <- crtInv - embedCRT' <- embedCRT - return $ (embedCRT' x :: t m' r) == (crt' $ embedPow $ crtInv' x) - \\ proxy entailEqT (Proxy::Proxy (t m' r)) - -twaceCommuteTests = testGroup "Tw commutes with L" [ - testGroup "Dec basis" $ groupTMM'R $ wrapTm'mrToBool prop_twace_dec, - testGroup "CRT basis" $ groupTMM'R $ wrapTm'mrToBool prop_twace_crt] - --- twacePowDec = lInv . twacePowDec . l -prop_twace_dec :: forall t m m' r . (TMM'RCtx t m m' r) => Proxy m -> t m' r -> Bool -prop_twace_dec _ x = (twacePowDec x :: t m r) == (lInv $ twacePowDec $ l x) - \\ proxy entailEqT (Proxy::Proxy (t m r)) - --- twaceCRT = crt . twacePowDec . crtInv -prop_twace_crt :: forall t m m' r . (TMM'RCtx t m m' r) => Proxy m -> t m' r -> Bool -prop_twace_crt _ x = fromMaybe (error "no CRT in prop_trace_crt") $ do - twaceCRT' <- twaceCRT - crt' <- crt - crtInv' <- crtInv - return $ (twaceCRT' x :: t m r) == (crt' $ twacePowDec $ crtInv' x) - \\ proxy entailEqT (Proxy::Proxy (t m r)) - -twaceInvarTests = testGroup "Twace invariants" [ - testGroup "Tw and Em ID for equal indices" $ groupTMR $ wrapTmrToBool $ prop_twEmID, - testGroup "Invar1 Pow basis" $ groupTMM'R $ wrapProxyTmm'rToBool prop_twace_invar1_pow, - testGroup "Invar1 Dec basis" $ groupTMM'R $ wrapProxyTmm'rToBool prop_twace_invar1_dec, - testGroup "Invar1 CRT basis" $ groupTMM'R $ wrapProxyTmm'rToBool prop_twace_invar1_crt, - testGroup "Invar2 Pow/Dec basis" $ groupTMM'R $ wrapProxyTmm'rToBool prop_twace_invar2_powdec, - testGroup "Invar2 CRT basis" $ groupTMM'R $ wrapProxyTmm'rToBool 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) => t m r -> Bool -prop_twEmID x = ((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 - --- twace mhat'/g' = mhat*totm'/totm/g (Pow basis) -prop_twace_invar1_pow :: forall t m m' r . (TMM'RCtx t m m' r) => Proxy m' -> Proxy (t m r) -> Bool -prop_twace_invar1_pow _ _ = fromMaybe (error "could not divide by G in prop_twace_invar1_pow") $ do - let mhat = proxy valueHatFact (Proxy::Proxy m) - mhat' = proxy valueHatFact (Proxy::Proxy m') - totm = proxy totientFact (Proxy::Proxy m) - totm' = proxy totientFact (Proxy::Proxy m') - output :: t m r <- divGPow $ scalarPow $ fromIntegral $ mhat * totm' `div` totm - input :: t m' r <- divGPow $ scalarPow $ fromIntegral mhat' - return $ (twacePowDec input) == output \\ proxy entailEqT (Proxy::Proxy (t m r)) - --- twace mhat'/g' = mhat*totm'/totm/g (Dec basis) -prop_twace_invar1_dec :: forall t m m' r . (TMM'RCtx t m m' r) => Proxy m' -> Proxy (t m r) -> Bool -prop_twace_invar1_dec _ _ = fromMaybe (error "could not divide by G in prop_twace_invar1_dec") $ do - let mhat = proxy valueHatFact (Proxy::Proxy m) - mhat' = proxy valueHatFact (Proxy::Proxy m') - totm = proxy totientFact (Proxy::Proxy m) - totm' = proxy totientFact (Proxy::Proxy m') - output :: t m r <- divGDec $ lInv $ scalarPow $ fromIntegral $ mhat * totm' `div` totm - input :: t m' r <- divGDec $ lInv $ scalarPow $ fromIntegral mhat' - return $ (twacePowDec input) == output \\ proxy entailEqT (Proxy::Proxy (t m r)) - --- twace mhat'/g' = mhat*totm'/totm/g (CRT basis) -prop_twace_invar1_crt :: forall t m m' r . (TMM'RCtx t m m' r) => Proxy m' -> Proxy (t m r) -> Bool -prop_twace_invar1_crt _ _ = fromMaybe (error "no CRT in prop_twace_invar1_crt") $ do - let mhat = proxy valueHatFact (Proxy::Proxy m) - mhat' = proxy valueHatFact (Proxy::Proxy m') - totm = proxy totientFact (Proxy::Proxy m) - totm' = proxy totientFact (Proxy::Proxy m') - scalarCRT1 <- scalarCRT - scalarCRT2 <- scalarCRT - divGCRT1 <- divGCRT - divGCRT2 <- divGCRT - twaceCRT' <- twaceCRT - let output :: t m r = divGCRT1 $ scalarCRT1 $ fromIntegral $ mhat * totm' `div` totm - input :: t m' r = divGCRT2 $ scalarCRT2 $ fromIntegral mhat' - return $ (twaceCRT' input) == output \\ proxy entailEqT (Proxy::Proxy (t m r)) - --- twace preserves scalars in Pow/Dec basis -prop_twace_invar2_powdec :: forall t m m' r . (TMM'RCtx t m m' r) => Proxy m' -> Proxy (t m r) -> Bool -prop_twace_invar2_powdec _ _ = - let output = scalarPow $ one :: t m r - input = scalarPow $ one :: t m' r - in (twacePowDec input) == output \\ proxy entailEqT (Proxy::Proxy (t m r)) - --- twace preserves scalars in Pow/Dec basis -prop_twace_invar2_crt :: forall t m m' r . (TMM'RCtx t m m' r) => Proxy m' -> Proxy (t m r) -> Bool -prop_twace_invar2_crt _ _ = fromMaybe (error "no CRT in prop_twace_invar2_crt") $ do - scalarCRT1 <- scalarCRT - scalarCRT2 <- scalarCRT - let input = scalarCRT1 one :: t m' r - output = scalarCRT2 one :: t m r - return $ (twacePowDec input) == output \\ proxy entailEqT (Proxy::Proxy (t m r)) - -type TMM'RWrapCtx t m m' r = (TMM'RCtx t m m' r, Show (t m' r), Show (t m r), Arbitrary (t m' r), Arbitrary (t m r)) - -wrapProxyTmm'rToBool :: (TMM'RWrapCtx t m m' r) - => (Proxy m' -> Proxy (t m r) -> Bool) - -> Proxy t -> Proxy '(m,m',r) -> Property -wrapProxyTmm'rToBool f _ _ = property $ f Proxy Proxy - -wrapTmm'rToBool :: (TMM'RWrapCtx t m m' r) => (Proxy m' -> t m r -> Bool) - -> Proxy t -> Proxy '(m,m',r) -> Property -wrapTmm'rToBool f _ _ = property $ f Proxy - -wrapTm'mrToBool :: (TMM'RWrapCtx t m m' r) => (Proxy m -> t m' r -> Bool) - -> Proxy t -> Proxy '(m,m',r) -> Property -wrapTm'mrToBool f _ _ = property $ f Proxy - -groupTMM'R :: (forall t m m' r . TMM'RWrapCtx t m m' r - => Proxy t - -> Proxy '(m,m',r) - -> Property) -> [Test] -groupTMM'R f = - [testGroup "CT" $ groupMM'R (f (Proxy::Proxy CT)), - testGroup "RT" $ groupMM'R (f (Proxy::Proxy RT))] - -type MM'RWrapCtx m m' r = (TMM'RWrapCtx CT m m' r, TMM'RWrapCtx RT m m' r) - -groupMM'R :: (forall m m' r . (MM'RWrapCtx m m' r) - => Proxy '(m, m', r) -> Property) -> [Test] -groupMM'R f = [testProperty "F1/F7/Q29" $ f (Proxy::Proxy '(F1, F7, Zq Q29)), - testProperty "F4/F12/Q536871001" $ f (Proxy::Proxy '(F4, F12, Zq Q536871001)), - testProperty "F4/F12/SmoothZQ1" $ f (Proxy::Proxy '(F4, F12, SmoothZQ1)), - testProperty "F2/F8/Q17" $ f (Proxy::Proxy '(F2, F8, Zq Q17)), - testProperty "F8/F8/Q17" $ f (Proxy::Proxy '(F8, F8, Zq Q17)), - testProperty "F12/F12/SmoothZQ1" $ f (Proxy::Proxy '(F2, F8, SmoothZQ1)), - testProperty "F4/F8/Q17" $ f (Proxy::Proxy '(F4, F8, Zq Q17)), - testProperty "F3/F21/Q8191" $ f (Proxy::Proxy '(F3, F21, Zq Q8191)), - testProperty "F7/F21/Q8191" $ f (Proxy::Proxy '(F7, F21, Zq Q8191)), - testProperty "F3/F42/Q8191" $ f (Proxy::Proxy '(F3, F42, Zq Q8191)), - testProperty "F3/F21/ZQ1" $ f (Proxy::Proxy '(F3, F21, ZQ1)), - testProperty "F7/F21/ZQ2" $ f (Proxy::Proxy '(F7, F21, ZQ2)), - testProperty "F3/F42/ZQ3" $ f (Proxy::Proxy '(F3, F42, ZQ3))] diff --git a/test-suite/TestTypes.hs b/test-suite/TestTypes.hs deleted file mode 100644 --- a/test-suite/TestTypes.hs +++ /dev/null @@ -1,90 +0,0 @@ -{-# LANGUAGE KindSignatures, PolyKinds, DataKinds, FlexibleInstances, RankNTypes, - TypeOperators, ConstraintKinds, FlexibleContexts, ScopedTypeVariables, - MultiParamTypeClasses, TypeFamilies, NoImplicitPrelude, RebindableSyntax #-} - -module TestTypes ( - ZP2, ZP3, ZP4, ZP8 -, PP2 -, SmoothZQ1, SmoothZQ2, SmoothZQ3 -, SmoothQ1 -, Zq, ZQ1, ZQ2, ZQ3 -, Q17, Q29, Q8191, Q80221, Q536871001) where - -import Control.Monad -import Control.Monad.Random - -import Crypto.Lol -import Crypto.Lol.Reflects -import Crypto.Lol.Factored - -import Data.Type.Natural - -import Test.QuickCheck.Monadic - -instance (MonadRandom m) => MonadRandom (PropertyM m) where - getRandom = run getRandom - getRandoms = run getRandoms - getRandomR r = run $ getRandomR r - getRandomRs r = run $ getRandomRs r - --- three 24-bit moduli, enough to handle rounding for p=32 (depth-4 circuit at ~17 bits per mul) -data Q18869761 -instance (ToInteger i) => Reflects Q18869761 i where value = return 18869761 -type ZQ1 = Zq Q18869761 - -data Q19393921 -instance (ToInteger i) => Reflects Q19393921 i where value = return 19393921 -type ZQ2 = (Zq Q19393921, ZQ1) - -data Q19918081 -instance (ToInteger i) => Reflects Q19918081 i where value = return 19918081 -type ZQ3 = (Zq Q19918081, ZQ2) - --- a 31-bit modulus, for rounding off after the last four hops -data Q2149056001 -instance (ToInteger i) => Reflects Q2149056001 i where value = return 2149056001 -type ZQ4 = (Zq Q2149056001, ZQ3) - --- for rounding off after the first hop -data Q3144961 -instance (ToInteger i) => Reflects Q3144961 i where value = return 3144961 -type ZQ5 = (Zq Q3144961, ZQ4) - -data Q7338241 -instance (ToInteger i) => Reflects Q7338241 i where value = return 7338241 -type ZQ6 = (Zq Q7338241, ZQ5) - --- concrete types useful for building tests or real applications -data Q17 -data Q29 -data Q8191 -- 1028th prime, = 1 mod 21 -data Q80221 -- good for 28 -data Q536871001 --- the next three moduli are "good" for any index dividing 128*27*25*7 -data SmoothQ1 -data SmoothQ2 -data SmoothQ3 - -instance (ToInteger i) => Reflects Q17 i where value = return 17 -instance (ToInteger i) => Reflects Q29 i where value = return 29 -instance (ToInteger i) => Reflects Q8191 i where value = return 8191 -instance (ToInteger i) => Reflects Q536871001 i where value = return 536871001 -instance (ToInteger i) => Reflects Q80221 i where value = return 80221 -instance (ToInteger i) => Reflects SmoothQ1 i where value = return 2148249601 -instance (ToInteger i) => Reflects SmoothQ2 i where value = return 2148854401 -instance (ToInteger i) => Reflects SmoothQ3 i where value = return 2150668801 - -type Zq (q :: k) = ZqBasic q Z -type Z = Int64 - -type PP2 e = ToPP N2 e -type PP3 e = ToPP N3 e - -type ZP2 = Zq (PP2 N1) -type ZP3 = Zq (PP3 N1) -type ZP4 = Zq (PP2 N2) -type ZP8 = Zq (PP2 N3) - -type SmoothZQ1 = Zq SmoothQ1 -type SmoothZQ2 = (Zq SmoothQ2, SmoothZQ1) -type SmoothZQ3 = (Zq SmoothQ3, SmoothZQ2) diff --git a/test-suite/ZqTests.hs b/test-suite/ZqTests.hs deleted file mode 100644 --- a/test-suite/ZqTests.hs +++ /dev/null @@ -1,56 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude, RebindableSyntax, ScopedTypeVariables, DataKinds, TypeOperators, PolyKinds, FlexibleContexts, RankNTypes, KindSignatures, MultiParamTypeClasses #-} - -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)) - -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)) - -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)) - -type ZqModuli = '[7, 13, 17, 11, 13, 29] - -class CallZqProp xs where - callProp :: Proxy xs -> Gen Int -> (forall (q :: Nat) . (Reflects q Int, KnownNat q) => Proxy q -> Int -> Int -> Bool) -> [Test] - - callProp2 :: Proxy xs - -> Gen Int - -> (forall (q :: Nat) . (Reflects q Int, KnownNat q) => Proxy q -> Int -> Bool) - -> [Test] - -instance CallZqProp '[] where - callProp _ _ _ = [] - callProp2 _ _ _ = [] - -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) - -zqModuli :: Proxy ZqModuli -zqModuli = Proxy - -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] diff --git a/tests/CycTests.hs b/tests/CycTests.hs new file mode 100644 --- /dev/null +++ b/tests/CycTests.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE DataKinds, FlexibleContexts, NoImplicitPrelude, PolyKinds, + ScopedTypeVariables, TypeOperators, TypeFamilies #-} +module CycTests (cycTests) where + +import Control.Monad (liftM2,join) + +import Crypto.Lol +import Crypto.Lol.Types.ZPP + +import Test.Framework (buildTest) + +import Utils +import Harness.Cyc +import Tests + +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 + ] + +prop_mulgPow :: (CElt t r, Fact m, Eq 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 = + 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 = + 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 = + let xs = map embed (coeffsCyc Pow x :: [Cyc t m r]) + bs = proxy powBasis (Proxy::Proxy m) + in test $ (sum $ zipWith (*) xs bs) == x + +-- verifies that CRT set elements satisfy c_i * c_j = delta_ij * c_i +-- 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 = + 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 = + '[ '(F7, Zq 29), + '(F7, Zq 32), + '(F12, Zq 2148249601), + '(F1, Zq 17), + '(F2, Zq 17), + '(F4, Zq 17), + '(F8, Zq 17), + '(F21, Zq 8191), + '(F42, Zq 8191), + '(F42, Zq 18869761), + '(F42, Zq 1024), + '(F42, Zq (18869761 ** 19393921)), + '(F89, Zq 179) + ] + +type MM'RCombos = '[ + '(F1, F7, Zq PP8), + '(F1, F7, Zq PP2) + ] + +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 + +-- checks cardinality of the CRT set +{- +prop_crtSet_card pm _ + let inferLen = length $ (proxy crtSetDec pm :: [t m' r]) + expectLen = + in +-} diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,14 @@ + +import TensorTests +import CycTests +import ZqTests + +import Test.Framework + +main :: IO () +main = do + flip defaultMainWithArgs ["--threads=1","--maximum-generated-tests=100"] + [ testGroup "Tensor Tests" tensorTests + ,testGroup "Cyc Tests" cycTests + ,testGroup "Zq Tests" zqTests + ] diff --git a/tests/TensorTests.hs b/tests/TensorTests.hs new file mode 100644 --- /dev/null +++ b/tests/TensorTests.hs @@ -0,0 +1,343 @@ +{-# LANGUAGE ConstraintKinds, FlexibleContexts, DataKinds, NoImplicitPrelude, + RebindableSyntax, ScopedTypeVariables, TypeFamilies, TypeOperators, + UndecidableInstances #-} + +module TensorTests (tensorTests) where + +import Harness.Cyc +import Tests +import Utils + +import TestTypes + +import Crypto.Lol +import Crypto.Lol.CRTrans +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 + +tensorTests = + [testGroupM "fmapT comparison" $ applyBasic (Proxy::Proxy TMRParams) $ hideArgs prop_fmapT, + testGroupM "fmap comparison" $ applyBasic (Proxy::Proxy 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, + 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, + testGroup "Tw commutes with L" twaceCommuteTests, + testGroup "Twace invariants" twaceInvarTests + ] + +prop_fmapT :: (Tensor t, TElt t r, Fact m, Eq r) => t m r -> Test '(t,m,r) +prop_fmapT x = test $ fmapT id x == x \\ witness entailEqT x \\ witness entailIndexT x + +prop_fmap :: (Tensor t, TElt t r, Fact m, Eq r) => t m r -> Test '(t,m,r) +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) + => t m r -> Test '(t,m,r) +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) + => t m r -> Test '(t,m,r) +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) + => 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 = [ + 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] + +-- 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) + => t m r -> Test '(t,m,r) +prop_g_crt x = test $ fromMaybe (error "no CRT in prop_g_crt") $ do + mulGCRT' <- mulGCRT + crt' <- crt + crtInv' <- crtInv + return $ (mulGCRT' x) == (crt' $ mulGPow $ crtInv' x) \\ witness entailEqT x + +gCommuteTests = [ + testGroupM "Dec basis" $ applyBasic (Proxy::Proxy TMRParams) $ hideArgs prop_g_dec, + testGroupM "CRT basis" $ applyBasic (Proxy::Proxy 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) + => t m r -> Test '(t,m,r) +prop_crt_inv x = test $ fromMaybe (error "no CRT in prop_crt_inv") $ do + crt' <- crt + crtInv' <- crtInv + return $ (crtInv' $ crt' x) == x \\ witness entailEqT x + +-- lInv . l == id +prop_l_inv :: (Tensor t, Ring r, Eq r, Fact m, TElt t r) => t m r -> Test '(t,m,r) +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) + => r -> Test '(t,m,r) +prop_scalar_crt r = test $ fromMaybe (error "no CRT in prop_scalar_crt") $ do + scalarCRT' <- scalarCRT + crt' <- crt + 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), + 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) + => r -> Test '(t,m,r) +prop_gsqnorm x = test $ + let crtCT = fromJust crt + crtRT = fromJust crt + -- not mathematically meaningful, we just need some "random" coefficients + ct = fmapT lift (mulGDec $ lInv $ crtCT $ scalarPow x :: CT m r) + rt = fmapT lift (mulGDec $ lInv $ crtRT $ scalarPow x :: RT m r) + 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) + +-- groups related tests +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] + +-- tests that twace . embed == id in the Pow basis +prop_trem_pow :: forall t m m' r . (TMM'RCtx t m m' r) + => t m r -> Test '(t,m,m',r) +prop_trem_pow x = test $ (twacePowDec $ (embedPow x :: t m' r)) == x \\ witness entailEqT x + +-- tests that twace . embed == id in the Dec basis +prop_trem_dec :: forall t m m' r . (TMM'RCtx t m m' r) + => t m r -> Test '(t,m,m',r) +prop_trem_dec x = test $ (twacePowDec $ (embedDec x :: t m' r)) == x \\ witness entailEqT x + +-- tests that twace . embed == id in the CRT basis +prop_trem_crt :: forall t m m' r . (TMM'RCtx t m m' r) + => t m r -> Test '(t,m,m',r) +prop_trem_crt x = test $ fromMaybe (error "no CRT in prop_trem_crt") $ + (x==) <$> (twaceCRT <*> (embedCRT <*> pure x :: Maybe (t m' r))) \\ witness entailEqT x + + + +embedCommuteTests = [ + testGroupM "Dec basis" $ applyTwoIdx (Proxy::Proxy TrEmParams) $ hideArgs prop_embed_dec, + testGroupM "CRT basis" $ applyTwoIdx (Proxy::Proxy 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) + \\ proxy entailEqT (Proxy::Proxy (t m' r)) + +-- embedCRT = crt . embedPow . crtInv +prop_embed_crt :: forall t m m' r . (TMM'RCtx t m m' r) => t m r -> Test '(t,m,m',r) +prop_embed_crt x = test $ fromMaybe (error "no CRT in prop_embed_crt") $ do + crt' <- crt + crtInv' <- crtInv + embedCRT' <- embedCRT + return $ (embedCRT' x :: t m' r) == (crt' $ embedPow $ crtInv' x) + \\ proxy entailEqT (Proxy::Proxy (t m' r)) + +twaceCommuteTests = [ + testGroupM "Dec basis" $ applyTwoIdx (Proxy::Proxy TrEmParams) $ hideArgs prop_twace_dec, + testGroupM "CRT basis" $ applyTwoIdx (Proxy::Proxy 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) +prop_twace_dec x = test $ (twacePowDec x :: t m r) == (lInv $ twacePowDec $ l x) + \\ proxy entailEqT (Proxy::Proxy (t m r)) + +-- twaceCRT = crt . twacePowDec . crtInv +prop_twace_crt :: forall t m m' r . (TMM'RCtx t m m' r) => t m' r -> Test '(t,m,m',r) +prop_twace_crt x = test $ fromMaybe (error "no CRT in prop_trace_crt") $ do + twaceCRT' <- twaceCRT + crt' <- crt + crtInv' <- crtInv + return $ (twaceCRT' x :: t m r) == (crt' $ twacePowDec $ crtInv' x) + \\ proxy entailEqT (Proxy::Proxy (t m r)) + +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 + ] + +prop_twEmID :: forall t m r . (Tensor t, TElt t r, CRTrans r, Fact m, m `Divides` m, Eq r, ZeroTestable r, IntegralDomain r) + => t m r -> Test '(t,m,r) +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 + +-- twace mhat'/g' = mhat*totm'/totm/g (Pow basis) +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) + mhat' = proxy valueHatFact (Proxy::Proxy m') + totm = proxy totientFact (Proxy::Proxy m) + totm' = proxy totientFact (Proxy::Proxy m') + output :: t m r <- divGPow $ scalarPow $ fromIntegral $ mhat * totm' `div` totm + input :: t m' r <- divGPow $ scalarPow $ fromIntegral mhat' + return $ (twacePowDec input) == output \\ proxy entailEqT (Proxy::Proxy (t m r)) + +-- twace mhat'/g' = mhat*totm'/totm/g (Dec basis) +prop_twace_invar1_dec :: forall t m m' r . (TMM'RCtx t m m' r) => Test '(t,m,m',r) +prop_twace_invar1_dec = test $ fromMaybe (error "could not divide by G in prop_twace_invar1_dec") $ do + let mhat = proxy valueHatFact (Proxy::Proxy m) + mhat' = proxy valueHatFact (Proxy::Proxy m') + totm = proxy totientFact (Proxy::Proxy m) + totm' = proxy totientFact (Proxy::Proxy m') + output :: t m r <- divGDec $ lInv $ scalarPow $ fromIntegral $ mhat * totm' `div` totm + input :: t m' r <- divGDec $ lInv $ scalarPow $ fromIntegral mhat' + return $ (twacePowDec input) == output \\ proxy entailEqT (Proxy::Proxy (t m r)) + +-- twace mhat'/g' = mhat*totm'/totm/g (CRT basis) +prop_twace_invar1_crt :: forall t m m' r . (TMM'RCtx t m m' r) => Test '(t,m,m',r) +prop_twace_invar1_crt = test $ fromMaybe (error "no CRT in prop_twace_invar1_crt") $ do + let mhat = proxy valueHatFact (Proxy::Proxy m) + mhat' = proxy valueHatFact (Proxy::Proxy m') + totm = proxy totientFact (Proxy::Proxy m) + totm' = proxy totientFact (Proxy::Proxy m') + scalarCRT1 <- scalarCRT + scalarCRT2 <- scalarCRT + divGCRT1 <- divGCRT + divGCRT2 <- divGCRT + twaceCRT' <- twaceCRT + let output :: t m r = divGCRT1 $ scalarCRT1 $ fromIntegral $ mhat * totm' `div` totm + input :: t m' r = divGCRT2 $ scalarCRT2 $ fromIntegral mhat' + return $ (twaceCRT' input) == output \\ proxy entailEqT (Proxy::Proxy (t m r)) + +-- twace preserves scalars in Pow/Dec basis +prop_twace_invar2_powdec :: forall t m m' r . (TMM'RCtx t m m' r) => Test '(t,m,m',r) +prop_twace_invar2_powdec = test $ + let output = scalarPow $ one :: t m r + input = scalarPow $ one :: t m' r + in (twacePowDec input) == output \\ proxy entailEqT (Proxy::Proxy (t m r)) + +-- twace preserves scalars in Pow/Dec basis +prop_twace_invar2_crt :: forall t m m' r . (TMM'RCtx t m m' r) => Test '(t,m,m',r) +prop_twace_invar2_crt = test $ fromMaybe (error "no CRT in prop_twace_invar2_crt") $ do + scalarCRT1 <- scalarCRT + scalarCRT2 <- scalarCRT + let input = scalarCRT1 one :: t m' r + 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), + '(F12, SmoothZQ1), + '(F1, Zq 17), + '(F2, Zq 17), + '(F4, Zq 17), + '(F8, Zq 17), + '(F21, Zq 8191), + '(F42, Zq 8191), + '(F42, ZQ1), + '(F2, ZQ2), + '(F3, ZQ2), + '(F7, ZQ2), + '(F6, ZQ2), + '(F42, SmoothZQ3), + '(F42, ZQ2), + '(F89, Zq 179) + ] + +-- we can't include a large modulus here because there is not enough +-- precision in Doubles to handle the error +type MRExtCombos = '[ + '(F7, Zq 29), + '(F1, Zq 17), + '(F2, Zq 17), + '(F4, Zq 17), + '(F8, Zq 17), + '(F21, Zq 8191), + '(F42, Zq 8191), + '(F42, ZQ1), + '(F42, ZQ2), + '(F89, Zq 179) + ] + +type MM'RCombos = '[ + '(F1, F7, Zq 29), + '(F4, F12, Zq 536871001), + '(F4, F12, SmoothZQ1), + '(F2, F8, Zq 17), + '(F8, F8, Zq 17), + '(F2, F8, SmoothZQ1), + '(F4, F8, Zq 17), + '(F3, F21, Zq 8191), + '(F7, F21, Zq 8191), + '(F3, F42, Zq 8191), + '(F3, F21, ZQ1), + '(F7, F21, ZQ2), + '(F3, F42, ZQ3) + ] + +type TMRParams = ( '(,) <$> Tensors) <*> MRCombos +type ExtParams = ( '(,) <$> Tensors) <*> MRExtCombos +type TrEmParams = ( '(,) <$> Tensors) <*> MM'RCombos +type NormParams = ( '(,) <$> '[RT]) <*> (Filter Liftable MRCombos) + +data Liftable :: TyFun (Factored, *) Bool -> * +type instance Apply Liftable '(m,zq) = Int64 :== (LiftOf zq) diff --git a/tests/ZqTests.hs b/tests/ZqTests.hs new file mode 100644 --- /dev/null +++ b/tests/ZqTests.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE NoImplicitPrelude, RebindableSyntax, ScopedTypeVariables, DataKinds, TypeOperators, PolyKinds, FlexibleContexts, RankNTypes, KindSignatures, MultiParamTypeClasses #-} + +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)) + +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)) + +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)) + +type ZqModuli = '[7, 13, 17, 11, 13, 29] + +class CallZqProp xs where + callProp :: Proxy xs -> Gen Int -> (forall (q :: Nat) . (Reflects q Int, KnownNat q) => Proxy q -> Int -> Int -> Bool) -> [Test] + + callProp2 :: Proxy xs + -> Gen Int + -> (forall (q :: Nat) . (Reflects q Int, KnownNat q) => Proxy q -> Int -> Bool) + -> [Test] + +instance CallZqProp '[] where + callProp _ _ _ = [] + callProp2 _ _ _ = [] + +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) + +zqModuli :: Proxy ZqModuli +zqModuli = Proxy + +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] diff --git a/utils/Apply.hs b/utils/Apply.hs new file mode 100644 --- /dev/null +++ b/utils/Apply.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE DataKinds, FlexibleInstances, MultiParamTypeClasses, PolyKinds, + TypeFamilies, TypeOperators #-} + +-- applies functions to proxy arguments +module Apply where + +class (params :: [k]) `Satisfy` (ctx :: *) where + data ArgsCtx ctx + + run :: proxy params + -> (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/Benchmarks.hs b/utils/Benchmarks.hs new file mode 100644 --- /dev/null +++ b/utils/Benchmarks.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, + PolyKinds, RankNTypes, ScopedTypeVariables, TypeFamilies #-} + +module Benchmarks +(Benchmarks.bench +,benchIO +,benchGroup +,hideArgs +,Bench(..) +,Benchmark +,NFData) where + +import Gen +import Utils + +import Control.DeepSeq +import Control.Monad.Random +import Control.Monad.State +import Criterion as C + +import Data.Proxy + +-- wrapper for Criterion's `nf` +bench :: NFData b => (a -> b) -> a -> Bench params +bench f = Bench . nf f + +-- wrapper for Criterion's `nfIO` +benchIO :: NFData b => IO b -> Bench params +benchIO = Bench . nfIO + +-- 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 +-- one that takes a proxy for its arguments +hideArgs :: (GenArgs rnd bnch, Monad rnd, ShowType a, + ResultOf bnch ~ Bench a) + => bnch -> Proxy a -> rnd Benchmark +hideArgs f p = (C.bench (showType p) . unbench) <$> genArgs f + +newtype Bench params = Bench {unbench :: Benchmarkable} + +instance (Monad rnd) => GenArgs rnd (Bench params) where + type ResultOf (Bench params) = Bench params + genArgs = return diff --git a/utils/Gen.hs b/utils/Gen.hs new file mode 100644 --- /dev/null +++ b/utils/Gen.hs @@ -0,0 +1,27 @@ +{-# 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/Harness/Cyc.hs b/utils/Harness/Cyc.hs new file mode 100644 --- /dev/null +++ b/utils/Harness/Cyc.hs @@ -0,0 +1,102 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/utils/TestTypes.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE ConstraintKinds, DataKinds, FlexibleContexts, + FlexibleInstances, KindSignatures, MultiParamTypeClasses, + NoImplicitPrelude, PolyKinds, RankNTypes, RebindableSyntax, + ScopedTypeVariables, TypeFamilies, TypeOperators #-} + +module TestTypes ( + +SmoothZQ1, SmoothZQ2, SmoothZQ3 +, Zq, ZQ1, ZQ2, ZQ3) where + +import Control.Monad +import Control.Monad.Random + +import Crypto.Lol +import Crypto.Lol.Reflects + +import Utils + +import Test.QuickCheck.Monadic + +instance (MonadRandom m) => MonadRandom (PropertyM m) where + getRandom = run getRandom + getRandoms = run getRandoms + getRandomR r = run $ getRandomR r + getRandomRs r = run $ getRandomRs r + +-- three 24-bit moduli, enough to handle rounding for p=32 (depth-4 circuit at ~17 bits per mul) +type ZQ1 = Zq 18869761 +type ZQ2 = Zq (19393921 ** 18869761) +type ZQ3 = Zq (19918081 ** 19393921 ** 18869761) + +-- the next three moduli are "good" for any index dividing 128*27*25*7 +type SmoothQ1 = 2148249601 +type SmoothQ2 = 2148854401 +type SmoothQ3 = 2150668801 + +type SmoothZQ1 = Zq 2148249601 +type SmoothZQ2 = Zq (2148854401 ** 2148249601) +type SmoothZQ3 = Zq (2148854401 ** 2148249601 ** 2150668801) diff --git a/utils/Tests.hs b/utils/Tests.hs new file mode 100644 --- /dev/null +++ b/utils/Tests.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE FlexibleContexts, FlexibleInstances, GADTs, MultiParamTypeClasses, + PolyKinds, RankNTypes, ScopedTypeVariables, TypeFamilies #-} +module Tests +(test +,testIO +,TF.testGroup +,testGroupM +,hideArgs +,Test(..)) where + +import Gen +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 + +testIO :: (forall m . MonadRandom m => m Bool) -> Test params +testIO = TestM + +testGroupM :: String -> [IO TF.Test] -> TF.Test +testGroupM str = TF.buildTest . (TF.testGroup str <$>) . sequence + +-- 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) + => bnch -> Proxy a -> rnd TF.Test +hideArgs f p = do + res <- genArgs f + case res of + Test b -> return $ testProperty (showType p) b + TestM b -> testProperty (showType p) <$> b + +data Test params where + Test :: Bool -> Test params + TestM :: (forall m . MonadRandom m => m Bool) -> Test params + +instance (MonadRandom rnd) => GenArgs rnd (Test params) where + type ResultOf (Test params) = Test params + genArgs = return diff --git a/utils/Utils.hs b/utils/Utils.hs new file mode 100644 --- /dev/null +++ b/utils/Utils.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE DataKinds, FlexibleContexts, FlexibleInstances, GADTs, + GeneralizedNewtypeDeriving, MultiParamTypeClasses, + PolyKinds, RankNTypes, ConstraintKinds, ScopedTypeVariables, + KindSignatures, + TypeFamilies, TypeOperators, UndecidableInstances #-} + +module Utils +(Zq +,type (**) +,type (<$>) +,type (<*>) + +,module Data.Promotion.Prelude.List + +,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.Reflects +import Crypto.Lol.Types.ZqBasic +import Crypto.Random.DRBG + +import Data.Promotion.Prelude.List +{- +import Math.NumberTheory.Primes.Testing (isPrime) + +-- an infinite list of primes greater than the input and congruent to +-- 1 mod m +goodQs :: (Integral i) => i -> i -> [i] +goodQs m lower = checkVal (lower + ((m-lower) `mod` m) + 1) + where checkVal v = if (isPrime (fromIntegral v :: Integer)) + then v : checkVal (v+m) + else checkVal (v+m) +-} + +infixr 9 ** +data a ** b + +type family Zq (a :: k) :: * where + Zq (a ** b) = (Zq a, Zq b) + Zq q = (ZqBasic q Int64) + + +type family (f :: (k1 -> k2)) <$> (xs :: [k1]) where + f <$> '[] = '[] + f <$> (x ': xs) = (f x) ': (f <$> xs) + +type family (fs :: [k1 -> k2]) <*> (xs :: [k1]) where + fs <*> xs = Go fs xs xs + +type family Go (fs :: [k1 -> k2]) (xs :: [k1]) (ys :: [k1]) where + Go '[] xs ys = '[] + Go (f ': fs) '[] ys = Go fs ys ys + Go (f ': fs) (x ': xs) ys = (f x) ': (Go (f ': fs) xs ys) + + + + + + + +-- a wrapper type for printing test/benchmark names +data ArgType (a :: k) = AT + +-- allows automatic printing of test parameters +type ShowType a = Show (ArgType a) + +showType :: forall a . (Show (ArgType a)) => Proxy a -> String +showType _ = show (AT :: ArgType a) + +instance Show (ArgType HashDRBG) where + show _ = "HashDRBG" + +instance (Fact m) => Show (ArgType m) where + 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))) + +instance Show (ArgType RT) where + show _ = "RT" + +instance Show (ArgType CT) where + show _ = "CT" + +instance Show (ArgType Int64) where + show _ = "Int64" + +instance Show (ArgType TrivGad) where + show _ = "TrivGad" + +instance (Reflects b Integer) => Show (ArgType (BaseBGad (b :: k))) where + 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)) + +-- 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)) + => Show (ArgType '(a,b)) where + show _ = (show (AT :: ArgType a)) ++ " " ++ (show (AT :: ArgType b)) + +instance (Show (ArgType a), Show (ArgType '(b,c))) + => Show (ArgType '(a,b,c)) where + show _ = (show (AT :: ArgType a)) ++ " " ++ (show (AT :: ArgType '(b,c))) + +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))) + +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))) + +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))) + +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))) + +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)))