module Crypto.Lol.Cyclotomic.UCyc
(
UCyc, P, D, C, E, UCycEC, UCycPC, UCRTElt, NFElt
, toPow, toDec, toCRT, fmapPow, fmapDec
, unzipPow, unzipDec, unzipCRTC, unzipCRTE
, scalarPow, scalarCRT
, mulG, divGPow, divGDec, divGCRTC, gSqNorm
, tGaussian, errorRounded, errorCoset
, embedPow, embedDec, embedCRTC, embedCRTE
, twacePow, twaceDec, twaceCRTC, twaceCRTE
, coeffsPow, coeffsDec, powBasis, crtSet
) where
import Crypto.Lol.Cyclotomic.Tensor hiding (divGDec, divGPow, embedCRT,
embedDec, embedPow, scalarCRT,
scalarPow, twaceCRT)
import Crypto.Lol.CRTrans
import Crypto.Lol.Cyclotomic.CRTSentinel
import qualified Crypto.Lol.Cyclotomic.Tensor as T
import Crypto.Lol.Prelude as LP
import Crypto.Lol.Types.FiniteField
import Crypto.Lol.Types.ZPP
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.Identity
import Control.Monad.Random
import Data.Foldable as F
import Data.Maybe
import Data.Traversable
import Test.QuickCheck
import Crypto.Lol.Types.Proto
data P
data D
data C
data E
type UCycEC t m r = Either (UCyc t m E r) (UCyc t m C r)
type UCycPC t m r = Either (UCyc t m P r) (UCyc t m C r)
data UCyc t (m :: Factored) rep r where
Pow :: !(t m r) -> UCyc t m P r
Dec :: !(t m r) -> UCyc t m D r
CRTC :: !(CSentinel t m r) -> !(t m r) -> UCyc t m C r
CRTE :: !(ESentinel t m r) -> !(t m (CRTExt r)) -> UCyc t m E r
type UCRTElt t r = (Tensor t, CRTEmbed r,
CRTrans Maybe r, TElt t r,
CRTrans Identity (CRTExt r), TElt t (CRTExt r))
type NFElt r = (NFData r, NFData (CRTExt r))
scalarPow :: (Tensor t, Fact m, Ring r, TElt t r) => r -> UCyc t m P r
scalarPow = Pow . T.scalarPow
scalarCRT :: (Fact m, UCRTElt t r) => r -> UCycEC t m r
scalarCRT r = case crtSentinel of
Right s -> Right $ CRTC s $ scalarCRTCS s r
Left s -> Left $ CRTE s $ runIdentity T.scalarCRT $ toExt r
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
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
instance (Eq r, Tensor t, Fact m, TElt t r) => Eq (UCyc t m C r) where
(CRTC _ v1) == (CRTC _ v2) = v1 == v2 \\ witness entailEqT v1
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
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
instance (ZeroTestable r, Tensor t, Fact m, TElt t r)
=> ZeroTestable.C (UCyc t m C r) where
isZero (CRTC _ v) = isZero v \\ witness entailZTT v
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
instance (Additive r, Tensor t, Fact m, TElt t r) => Additive.C (UCyc t m D r) where
zero = Dec $ T.scalarPow zero
(Dec v1) + (Dec v2) = Dec $ zipWithT (+) v1 v2
(Dec v1) (Dec v2) = Dec $ zipWithT () v1 v2
negate (Dec v) = Dec $ fmapT negate v
instance (Fact m, UCRTElt t r) => Additive.C (UCycEC t m r) where
zero = scalarCRT zero
(Right (CRTC s v1)) + (Right (CRTC _ v2)) = Right $ CRTC s $ zipWithT (+) v1 v2
(Left (CRTE s v1)) + (Left (CRTE _ v2)) = Left $ CRTE s $ zipWithT (+) v1 v2
_ + _ = error "UCyc (+) internal error: mixed CRTC/CRTE"
(Right (CRTC s v1)) (Right (CRTC _ v2)) = Right $ CRTC s $ zipWithT () v1 v2
(Left (CRTE s v1)) (Left (CRTE _ v2)) = Left $ CRTE s $ zipWithT () v1 v2
_ _ = error "UCyc (-) internal error: mixed CRTC/CRTE"
negate (Right (CRTC s v)) = Right $ CRTC s $ fmapT negate v
negate (Left (CRTE s v)) = Left $ CRTE s $ fmapT negate v
instance (Fact m, UCRTElt t r) => Ring.C (UCycEC t m r) where
one = scalarCRT one
fromInteger c = scalarCRT $ fromInteger c
(Right (CRTC s v1)) * (Right (CRTC _ v2)) = Right $ CRTC s $ zipWithT (*) v1 v2
(Left (CRTE s v1)) * (Left (CRTE _ v2)) = Left $ CRTE s $ zipWithT (*) v1 v2
_ * _ = error "UCyc internal error: mixed CRTC/CRTE"
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
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
instance (Ring r, Fact m, UCRTElt t r) => Module.C r (UCycEC t m r) where
r *> (Right (CRTC s v)) = Right $ CRTC s $ fmapT (r *) v
r *> (Left (CRTE s v)) = Left $ CRTE s $ fmapT (toExt r *) v
instance (GFCtx fp d, Fact m, Tensor t, TElt t fp)
=> Module.C (GF fp d) (UCyc t m P fp) where
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
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
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
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
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
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
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
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
unzipPow :: (Tensor t, Fact m, TElt t (a,b), TElt t a, TElt t b)
=> UCyc t m P (a,b) -> (UCyc t m P a, UCyc t m P b)
unzipPow (Pow v) = Pow *** Pow $ unzipT v
unzipDec :: (Tensor t, Fact m, TElt t (a,b), TElt t a, TElt t b)
=> UCyc t m D (a,b) -> (UCyc t m D a, UCyc t m D b)
unzipDec (Dec v) = Dec *** Dec $ unzipT v
unzipCRTC :: (Fact m, UCRTElt t (a,b), UCRTElt t a, UCRTElt t b)
=> UCyc t m C (a,b)
-> (Either (UCyc t m P a) (UCyc t m C a),
Either (UCyc t m P b) (UCyc t m C b))
unzipCRTC (CRTC s v)
= let (ac,bc) = unzipT v
(ap,bp) = Pow *** Pow $ unzipT $ crtInvCS s v
in (fromMaybe (Left ap) (Right <$> (CRTC <$> crtCSentinel <*> pure ac)),
fromMaybe (Left bp) (Right <$> (CRTC <$> crtCSentinel <*> pure bc)))
unzipCRTE :: (Fact m, UCRTElt t (a,b), UCRTElt t a, UCRTElt t b)
=> UCyc t m E (a,b)
-> (Either (UCyc t m P a) (UCyc t m E a),
Either (UCyc t m P b) (UCyc t m E b))
unzipCRTE (CRTE _ v)
= let (ae,be) = unzipT v
(a',b') = unzipT $ fmapT fromExt $ runIdentity crtInv v
(ap,bp) = Pow *** Pow $ (a',b')
in (fromMaybe (Left ap) (Right <$> (CRTE <$> crtESentinel <*> pure ae)),
fromMaybe (Left bp) (Right <$> (CRTE <$> crtESentinel <*> pure be)))
mulG :: (Fact m, UCRTElt t r) => UCyc t m rep r -> UCyc t m rep r
mulG (Pow v) = Pow $ mulGPow v
mulG (Dec v) = Dec $ mulGDec v
mulG (CRTC s v) = CRTC s $ mulGCRTCS s v
mulG (CRTE s v) = CRTE s $ runIdentity mulGCRT v
divGPow :: (Fact m, UCRTElt t r, ZeroTestable r, IntegralDomain r)
=> UCyc t m P r -> Maybe (UCyc t m P r)
divGPow (Pow v) = Pow <$> T.divGPow v
divGDec :: (Fact m, UCRTElt t r, ZeroTestable r, IntegralDomain r)
=> UCyc t m D r -> Maybe (UCyc t m D r)
divGDec (Dec v) = Dec <$> T.divGDec v
divGCRTC :: (Fact m, UCRTElt t r)
=> UCyc t m C r -> UCyc t m C r
divGCRTC (CRTC s v) = CRTC s $ divGCRTCS s v
gSqNorm :: (Ring r, Tensor t, Fact m, TElt t r) => UCyc t m D r -> r
gSqNorm (Dec v) = gSqNormDec v
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
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)
errorRounded svar =
Dec . fmapT (roundMult one) <$> (tGaussianDec svar :: rnd (t m Double))
errorCoset :: forall t m zp z v rnd .
(Mod zp, z ~ ModRep zp, Lift zp z, Tensor t, Fact m,
ToRational v, MonadRandom rnd)
=> v -> UCyc t m D zp -> rnd (UCyc t m D z)
errorCoset =
let pval = fromIntegral $ proxy modulus (Proxy::Proxy zp)
in \ svar c -> do err :: UCyc t m D Double <- tGaussian (svar*pval*pval)
return $! roundCoset <$> c <*> err
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
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
embedCRTC :: (m `Divides` m', UCRTElt t r)
=> UCyc t m C r -> Either (UCyc t m' P r) (UCyc t m' C r)
embedCRTC x@(CRTC s v) =
case crtSentinel of
Left _ -> Left $ embedPow $ toPow x
Right s' -> Right $ CRTC s' $ embedCRTCS s s' v
embedCRTE :: forall m m' t r . (m `Divides` m', UCRTElt t r)
=> UCyc t m E r -> Either (UCyc t m' P r) (UCyc t m' E r)
embedCRTE x@(CRTE _ v) =
case crtSentinel of
Left s -> Right $ CRTE s $ runIdentity T.embedCRT v
Right _ -> Left $ embedPow $ toPow x
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
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
twaceCRTC :: (m `Divides` m', UCRTElt t r)
=> UCyc t m' C r -> UCycPC t m r
twaceCRTC x@(CRTC s' v) =
case crtSentinel of
Left _ -> Left $ twacePow $ toPow x
Right s -> Right $ CRTC s $ twaceCRTCS s' s v
twaceCRTE :: forall t m m' r . (m `Divides` m', UCRTElt t r)
=> UCyc t m' E r -> Either (UCyc t m P r) (UCyc t m E r)
twaceCRTE x@(CRTE _ v) =
case crtSentinel of
Left s -> Right $ CRTE s $ runIdentity T.twaceCRT v
Right _ -> Left $ twacePow $ toPow x
coeffsPow :: (Ring r, Tensor t, m `Divides` m', TElt t r)
=> UCyc t m' P r -> [UCyc t m P r]
coeffsPow (Pow v) = LP.map Pow $ coeffs v
coeffsDec :: (Ring r, Tensor t, m `Divides` m', TElt t r)
=> UCyc t m' D r -> [UCyc t m D r]
coeffsDec (Dec v) = LP.map Dec $ coeffs v
powBasis :: (Ring r, Tensor t, m `Divides` m', TElt t r)
=> Tagged m [UCyc t m' P r]
powBasis = (Pow <$>) <$> powBasisPow
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',
UCRTElt t r, TElt t (ZpOf r))
=> Tagged m [UCyc t m' P r]
crtSet =
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 toPowCE . (^(p^(e1))) . toCRT else toPow) .
Dec . fmapT liftZp) <$>
(crtSetDec :: Tagged mbar [t m'bar (ZpOf r)]))
\\ pFreeDivides pp pm pm' \\ pSplitTheorems pp pm \\ pSplitTheorems pp pm'
toPow :: (Fact m, UCRTElt t r) => UCyc t m rep r -> UCyc t m P r
toPow x@(Pow _) = x
toPow (Dec v) = Pow $ l v
toPow (CRTC s v) = Pow $ crtInvCS s v
toPow (CRTE _ v) = Pow $ fmapT fromExt $ runIdentity crtInv v
toPowCE :: (Fact m, UCRTElt t r) => UCycEC t m r -> UCyc t m P r
toPowCE (Left u) = toPow u
toPowCE (Right u) = toPow u
toDec :: (Fact m, UCRTElt t r) => UCyc t m rep r -> UCyc t m D r
toDec (Pow v) = Dec $ lInv v
toDec x@(Dec _) = x
toDec x@(CRTC _ _) = toDec $ toPow x
toDec x@(CRTE _ _) = toDec $ toPow x
toCRT :: forall t m rep r . (Fact m, UCRTElt t r)
=> UCyc t m rep r -> UCycEC t m r
toCRT = let fromPow :: t m r -> UCycEC t m r
fromPow = case crtSentinel of
Right s -> Right . CRTC s . crtCS s
Left s -> Left . CRTE s . runIdentity crt . fmapT toExt
in \x -> case x of
(CRTC _ _) -> Right x
(CRTE _ _) -> Left x
(Pow v) -> fromPow v
(Dec v) -> fromPow $ l v
instance (Tensor t, Fact m) => Functor (UCyc t m P) where
fmap f x = pure f <*> x
instance (Tensor t, Fact m) => Functor (UCyc t m D) where
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
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
instance (Tensor t, Fact m) => Foldable (UCyc t m P) where
foldr f b (Pow v) = F.foldr f b v \\ witness entailIndexT v
instance (Tensor t, Fact m) => Foldable (UCyc t m D) where
foldr f b (Dec v) = F.foldr f b v \\ witness entailIndexT v
instance (Tensor t, Fact m) => Foldable (UCyc t m C) where
foldr f b (CRTC _ v) = F.foldr f b v \\ witness entailIndexT v
instance (Tensor t, Fact m) => Traversable (UCyc t m P) where
traverse f (Pow v) = Pow <$> traverse f v \\ witness entailIndexT v
instance (Tensor t, Fact m) => Traversable (UCyc t m D) where
traverse f (Dec v) = Dec <$> traverse f v \\ witness entailIndexT v
instance (Random r, UCRTElt t r, Fact m) => Random (UCyc t m P r) where
random g = let (v,g') = random g \\ witness entailRandomT v
in (Pow v, g')
randomR _ = error "randomR non-sensical for UCyc"
instance (Random r, UCRTElt t r, Fact m) => Random (UCyc t m D r) where
random g = let (v,g') = random g \\ witness entailRandomT v
in (Dec v, g')
randomR _ = error "randomR non-sensical for UCyc"
instance (Random r, UCRTElt t r, Fact m)
=> Random (UCycPC t m r) where
random = let cons = case crtSentinel of
Left _ -> Left . Pow
Right s -> Right . CRTC s
in \g -> let (v,g') = random g \\ witness entailRandomT v
in (cons v, g')
randomR _ = error "randomR non-sensical for UCyc"
instance (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 (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 (CRTC _ x) = rnf x \\ witness entailNFDataT x
rnf (CRTE _ x) = rnf x \\ witness entailNFDataT x
instance (Protoable (t m r)) => Protoable (UCyc t m D r) where
type ProtoType (UCyc t m D r) = ProtoType (t m r)
toProto (Dec t) = toProto t
fromProto t = Dec <$> fromProto t