module Crypto.Lol.Cyclotomic.Cyc
(
Cyc, CElt, U.NFElt
, scalarCyc
, cycPow, cycDec, cycCRT, cycCRTC, cycCRTE, cycPC, cycPE
, uncycPow, uncycDec, uncycCRT, unzipCyc
, mulG, divG, gSqNorm, liftCyc, liftPow, liftDec
, advisePow, adviseDec, adviseCRT
, tGaussian, errorRounded, errorCoset
, embed, twace, coeffsCyc, coeffsPow, coeffsDec, powBasis, crtSet
) 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,
errorCoset, errorRounded, gSqNorm, mulG,
powBasis, tGaussian)
import Crypto.Lol.CRTrans
import qualified Crypto.Lol.Cyclotomic.RescaleCyc as R
import Crypto.Lol.Cyclotomic.Tensor (TElt, Tensor)
import qualified Crypto.Lol.Cyclotomic.UCyc as U
import Crypto.Lol.Gadget
import Crypto.Lol.Prelude as LP
import Crypto.Lol.Types.FiniteField
import Crypto.Lol.Types.Proto
import Crypto.Lol.Types.ZPP
import Control.Applicative hiding ((*>))
import Control.Arrow
import Control.DeepSeq
import Control.Monad.Identity
import Control.Monad.Random
import Data.Coerce
import Data.Traversable
import Test.QuickCheck
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 :: !(UCycEC t m r) -> Cyc t m r
Scalar :: !r -> Cyc t m r
Sub :: (l `Divides` m) => !(Cyc t l r) -> Cyc t m r
type CElt t r = (UCRTElt t r, ZeroTestable r)
cycPow :: UCyc t m P r -> Cyc t m r
cycPow = Pow
cycDec :: UCyc t m D r -> Cyc t m r
cycDec = Dec
cycCRT :: UCycEC t m r -> Cyc t m r
cycCRT = CRT
cycCRTC :: UCyc t m C r -> Cyc t m r
cycCRTC = CRT . Right
cycCRTE :: UCyc t m E r -> Cyc t m r
cycCRTE = CRT . Left
cycPC :: Either (UCyc t m P r) (UCyc t m C r) -> Cyc t m r
cycPC = either Pow (CRT . Right)
cycPE :: Either (UCyc t m P r) (UCyc t m E r) -> Cyc t m r
cycPE = either Pow (CRT . Left)
scalarCyc :: r -> Cyc t m r
scalarCyc = Scalar
uncycPow :: (Fact m, CElt t r) => Cyc t m r -> UCyc t m P r
uncycPow c = let (Pow u) = toPow' c in u
uncycDec :: (Fact m, CElt t r) => Cyc t m r -> UCyc t m D r
uncycDec c = let (Dec u) = toDec' c in u
uncycCRT :: (Fact m, CElt t r) => Cyc t m r -> UCycEC t m r
uncycCRT c = let (CRT u) = toCRT' c in u
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 (Right u)) = isZero u
isZero c@(CRT _) = isZero $ toPow' c
isZero (Scalar c) = isZero c
isZero (Sub c) = isZero c
instance (Eq r, Fact m, CElt t r) => Eq (Cyc t m r) where
(Scalar c1) == (Scalar c2) = c1 == c2
(Pow u1) == (Pow u2) = u1 == u2
(Dec u1) == (Dec u2) = u1 == u2
(CRT (Right u1)) == (CRT (Right u2)) = u1 == u2
(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)
(Scalar c1) == (Pow u2) = scalarPow c1 == u2
(Pow u1) == (Scalar c2) = u1 == scalarPow c2
c1 == c2 = toPow' c1 == toPow' c2
instance (Fact m, CElt t r) => Additive.C (Cyc t m r) where
zero = Scalar zero
(Scalar c1) + c2 | isZero c1 = c2
c1 + (Scalar c2) | isZero c2 = c1
(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 (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 c) + (Pow u) = Pow $ scalarPow c + u
(Scalar c) + (Dec u) = Pow $ scalarPow c + toPow u
(Scalar c) + (CRT u) = CRT $ scalarCRT c + u
(Scalar c1) + (Sub c2) = Sub $ Scalar c1 + c2
(Pow u) + (Scalar c) = Pow $ u + scalarPow c
(Dec u) + (Scalar c) = Pow $ toPow u + scalarPow c
(CRT u) + (Scalar c) = CRT $ u + scalarCRT c
(Sub c1) + (Scalar c2) = Sub $ c1 + Scalar c2
(Sub c1) + c2 = embed' c1 + c2
c1 + (Sub c2) = c1 + embed' c2
(Dec u1) + (Pow u2) = Pow $ toPow u1 + u2
(Pow u1) + (Dec u2) = Pow $ u1 + toPow u2
(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
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
one = Scalar one
fromInteger = Scalar . fromInteger
v1@(Scalar c1) * _ | isZero c1 = v1
_ * v2@(Scalar c2) | isZero c2 = v2
(CRT u1) * (CRT u2) = either (Pow . toPow) (CRT . Right) $ u1*u2
(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
(Sub (c1 :: Cyc t m1 r)) * (Sub (c2 :: Cyc t m2 r)) =
(Sub $ (toCRT' $ Sub c1 :: Cyc t (FLCM m1 m2) r) * toCRT' (Sub c2))
\\ lcm2Divides (Proxy::Proxy m1) (Proxy::Proxy m2) (Proxy::Proxy m)
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
r *> (Pow v) = Pow $ r LP.*> v
r *> x = r *> toPow' x
advisePow, adviseDec, adviseCRT :: (Fact m, CElt t r) => Cyc t m r -> Cyc t m r
advisePow = toPow'
adviseDec = toDec'
adviseCRT = toCRT'
mulG :: (Fact m, CElt t r) => Cyc t m r -> Cyc t m r
mulG (Pow u) = Pow $ U.mulG u
mulG (Dec u) = Dec $ U.mulG u
mulG (CRT u) = CRT $ either (Left . U.mulG) (Right . U.mulG) u
mulG c@(Scalar _) = mulG $ toCRT' c
mulG (Sub c) = mulG $ embed' c
divG :: (Fact m, CElt t r, IntegralDomain r)
=> Cyc t m r -> Maybe (Cyc t m r)
divG (Pow u) = Pow <$> U.divGPow u
divG (Dec u) = Dec <$> U.divGDec u
divG (CRT (Left u)) = Pow <$> U.divGPow (U.toPow u)
divG (CRT (Right u)) = Just $ (CRT . Right) $ U.divGCRTC u
divG c@(Scalar _) = divG $ toCRT' c
divG (Sub c) = divG $ embed' c
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
gSqNorm :: forall t m r . (Fact m, CElt t r) => Cyc t m r -> r
gSqNorm (Dec u) = U.gSqNorm u
gSqNorm c = gSqNorm $ toDec' c
errorRounded :: (ToInteger z, Tensor t, Fact m, TElt t z,
ToRational v, MonadRandom rnd) => v -> rnd (Cyc t m z)
errorRounded = (Dec <$>) . U.errorRounded
errorCoset ::
(Mod zp, z ~ ModRep zp, Lift zp z, Fact m,
CElt t zp, ToRational v, MonadRandom rnd)
=> v -> Cyc t m zp -> rnd (Cyc t m z)
errorCoset v = (Dec <$>) . U.errorCoset v . uncycDec
embed :: forall t m m' r . (m `Divides` m') => Cyc t m r -> Cyc t m' r
embed (Scalar c) = Scalar c
embed (Sub (c :: Cyc t l r)) = Sub c
\\ transDivides (Proxy::Proxy l) (Proxy::Proxy m) (Proxy::Proxy m')
embed c = Sub c
embed' :: forall t r l m . (l `Divides` m, CElt t r) => Cyc t l r -> Cyc t m r
embed' (Pow u) = Pow $ embedPow u
embed' (Dec u) = Dec $ embedDec u
embed' (CRT u) = either (cycPE . embedCRTE) (cycPC . embedCRTC) u
embed' (Scalar c) = Scalar c
embed' (Sub (c :: Cyc t k r)) = embed' c
\\ transDivides (Proxy::Proxy k) (Proxy::Proxy l) (Proxy::Proxy m)
twace :: forall t m m' r . (m `Divides` m', UCRTElt t r, ZeroTestable r)
=> Cyc t m' r -> Cyc t m r
twace (Pow u) = Pow $ U.twacePow u
twace (Dec u) = Dec $ U.twaceDec u
twace (CRT u) = either (cycPE . twaceCRTE) (cycPC . twaceCRTC) u
twace (Scalar u) = Scalar u
twace (Sub (c :: Cyc t l r)) = Sub (twace c :: Cyc t (FGCD l m) r)
\\ gcdDivides (Proxy::Proxy l) (Proxy::Proxy m)
coeffsCyc :: (m `Divides` m', CElt t r) => R.Basis -> Cyc t m' r -> [Cyc t m r]
coeffsCyc R.Pow c' = Pow <$> U.coeffsPow (uncycPow c')
coeffsCyc R.Dec c' = Dec <$> U.coeffsDec (uncycDec c')
coeffsPow, coeffsDec :: (m `Divides` m', CElt t r) => Cyc t m' r -> [Cyc t m r]
coeffsPow = coeffsCyc R.Pow
coeffsDec = coeffsCyc R.Dec
powBasis :: (m `Divides` m', CElt t r) => Tagged m [Cyc t m' r]
powBasis = (Pow <$>) <$> U.powBasis
crtSet :: (m `Divides` m', ZPP r, CElt t r, TElt t (ZpOf r))
=> Tagged m [Cyc t m' r]
crtSet = (Pow <$>) <$> U.crtSet
instance (Reduce a b, Fact m, CElt t a, CElt t b)
=> Reduce (Cyc t m a) (Cyc t m b) where
reduce (Pow u) = Pow $ reduce u
reduce (Dec u) = Dec $ reduce u
reduce (CRT u) = Pow $ reduce $ either toPow toPow u
reduce (Scalar c) = Scalar $ reduce c
reduce (Sub (c :: Cyc t l a)) = Sub (reduce c :: Cyc t l b)
type instance LiftOf (Cyc t m r) = Cyc t m (LiftOf r)
liftCyc :: (Lift b a, Fact m, TElt t a, CElt t b)
=> R.Basis -> Cyc t m b -> Cyc t m a
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
liftPow (Pow u) = Pow $ lift u
liftPow (Dec u) = Pow $ lift $ toPow u
liftPow (CRT u) = Pow $ lift $ either toPow toPow u
liftPow (Scalar c) = Scalar $ lift c
liftPow (Sub c) = Sub $ liftPow c
liftDec c = Dec $ lift $ uncycDec c
unzipCyc :: (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)
unzipCyc (Pow u) = Pow *** Pow $ U.unzipPow u
unzipCyc (Dec u) = Dec *** Dec $ U.unzipDec u
unzipCyc (CRT u) = either ((cycPE *** cycPE) . unzipCRTE)
((cycPC *** cycPC) . unzipCRTC) u
unzipCyc (Scalar c) = Scalar *** Scalar $ c
unzipCyc (Sub c) = Sub *** Sub $ unzipCyc c
instance (Rescale a b, CElt t a, TElt t b)
=> R.RescaleCyc (Cyc t) a b where
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
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
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) = unzipCyc c
z = liftCyc bas a
in Scalar (recip (reduce aval)) * (b reduce z)
instance (Gadget gad zq, Fact m, CElt t zq) => Gadget gad (Cyc t m zq) where
gadget = (scalarCyc <$>) <$> gadget
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)
decompose (Scalar c) = pasteT $ Scalar <$> peelT (decompose c)
decompose (Sub c) = pasteT $ Sub <$> peelT (decompose c)
decompose (Pow u) = fromZL $ Pow <$> traverse (toZL . decompose) u
decompose c = decompose $ toPow' c
toZL :: Tagged s [a] -> TaggedT s ZipList a
toZL = coerce
fromZL :: TaggedT s ZipList a -> Tagged s [a]
fromZL = coerce
instance (Correct gad zq, Fact m, CElt t zq) => Correct gad (Cyc t m zq) where
correct bs = Dec *** (Dec <$>) $
second sequence $ fmap fst &&& fmap snd $ (correct . pasteT) <$>
sequenceA (uncycDec <$> peelT bs)
toPow', toDec', toCRT' :: (Fact m, UCRTElt t r, ZeroTestable r) => Cyc t m r -> Cyc t m r
toPow' c@(Pow _) = c
toPow' (Dec u) = Pow $ toPow u
toPow' (CRT u) = Pow $ either toPow toPow u
toPow' (Scalar c) = Pow $ scalarPow c
toPow' (Sub c) = toPow' $ embed' c
toDec' (Pow u) = Dec $ toDec u
toDec' c@(Dec _) = c
toDec' (CRT u) = Dec $ either toDec toDec u
toDec' (Scalar c) = Dec $ toDec $ scalarPow c
toDec' (Sub c) = toDec' $ embed' c
toCRT' (Pow u) = CRT $ toCRT u
toCRT' (Dec u) = CRT $ toCRT u
toCRT' c@(CRT _) = c
toCRT' (Scalar c) = CRT $ scalarCRT c
toCRT' (Sub c) = toCRT' $ embed' $ toCRT' c
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, UCRTElt t r) => Random (Cyc t m r) where
random g = let (u,g') = random g
in (either Pow (CRT . Right) u, g')
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 (Fact m, CElt t r, Protoable (UCyc t m D r))
=> Protoable (Cyc t m r) where
type ProtoType (Cyc t m r) = ProtoType (UCyc t m D r)
toProto (Dec uc) = toProto uc
toProto x = toProto $ toDec' x
fromProto x = Dec <$> fromProto x