diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,6 +1,22 @@ Changelog for lol project ================================ +0.6.0.0 +---- + * Support for serializing ring products, linear functions, and TypeReps. + * Split previous lol package into separate tensor packages lol-cpp and lol-repa + and utility packages lol-benches and lol-tests. + * Moved test and benchmark code to packages lol-tests and lol-benches, respectively. + * Simpler tests and benchmarks (though microbenchmarks might be slightly slower + than 0.5.0.2). + * Fixed minor bug in IrreducibleChar2.hs + * Moved tensor-specific instances (Elt, Unbox, etc) to tensor packages + (lol-cpp and lol-repa). + +0.5.0.2 +---- + * Updates to README. + 0.5.0.1 ---- * Benchmarks now compile. diff --git a/Crypto/Lol.hs b/Crypto/Lol.hs --- a/Crypto/Lol.hs +++ b/Crypto/Lol.hs @@ -1,42 +1,52 @@ +{-| +Module : Crypto.Lol +Description : Primary interface to the Lol library. +Copyright : (c) Eric Crockett, 2011-2017 + Chris Peikert, 2011-2017 +License : GPL-2 +Maintainer : ecrockett0@email.com +Stability : experimental +Portability : POSIX --- | \( \def\Z{\mathbb{Z}} \) --- \( \def\C{\mathbb{C}} \) --- \( \def\Q{\mathbb{Q}} \) --- \( \def\R{\mathbb{R}} \) --- \( \def\F{\mathbb{F}} \) --- \( \def\O{\mathcal{O}} \) --- --- This module re-exports primary interfaces, and should be the only import --- needed for most cryptographic application implmenetations. To instantiate an --- application with concrete types, you will also need to import --- "Crypto.Lol.Types". --- --- Below is a brief mathematical background which serves as reference --- material for reading the documentation. --- --- * \( \Z \) denotes the ring of integers, \( \Q \) is the rational numbers, --- \( \R \) denotes the real numbers, and \( \C \) represents the complex --- numbers. --- --- * \( \Z_q = \Z/(q\Z) \) is the integers mod \( q \). \( \Z_q \) is --- implemented in "Crypto.Lol.Types.ZqBasic". --- --- * The finite field of order \( p \) is denoted \( \F_{p} \), and is --- implemented in "Crypto.Lol.Types.FiniteField". --- --- * \( \zeta_m \in R \) is an arbitrary element of order \( m \) in a --- ring \( R \). --- --- * Throughout, \( m \) denotes a cyclotomic /index/. In code, the cyclotomic --- index is represented by the type parameter @m :: 'Factored'@. --- --- * The ring \( R=\O_m=\Z[\zeta_m] \) is the \( m \)th cyclotomic ring. --- We denote the quotient ring \( \Z_q[\zeta_m]) \) by \( R_q \). --- We refer to \( \Z \) or \( \Z_q \) as the /base ring/. --- Cyclotomic rings are encapsulated by "Crypto.Lol.Cyclotomic.Cyc". --- --- * \( n=\varphi(m) \) is the totient function of the cyclotomic index. --- This is the dimension of a cyclotomic ring over the base ring. + \( \def\Z{\mathbb{Z}} \) + \( \def\C{\mathbb{C}} \) + \( \def\Q{\mathbb{Q}} \) + \( \def\R{\mathbb{R}} \) + \( \def\F{\mathbb{F}} \) + \( \def\O{\mathcal{O}} \) + +This module re-exports primary interfaces, and should be the only import +needed for most cryptographic application implmenetations. To instantiate an +application with concrete types, you will also need to import +"Crypto.Lol.Types". + +Below is a brief mathematical background which serves as reference +material for reading the documentation. + + * \( \Z \) denotes the ring of integers, \( \Q \) is the rational numbers, + \( \R \) denotes the real numbers, and \( \C \) represents the complex + numbers. + + * \( \Z_q = \Z/(q\Z) \) is the integers mod \( q \). \( \Z_q \) is + implemented in "Crypto.Lol.Types.ZqBasic". + + * The finite field of order \( p \) is denoted \( \F_{p} \), and is + implemented in "Crypto.Lol.Types.FiniteField". + + * \( \zeta_m \in R \) is an arbitrary element of order \( m \) in a + ring \( R \). + + * Throughout, \( m \) denotes a cyclotomic /index/. In code, the cyclotomic + index is represented by the type parameter @m :: 'Factored'@. + + * The ring \( R=\O_m=\Z[\zeta_m] \) is the \( m \)th cyclotomic ring. + We denote the quotient ring \( \Z_q[\zeta_m]) \) by \( R_q \). + We refer to \( \Z \) or \( \Z_q \) as the /base ring/. + Cyclotomic rings are encapsulated by "Crypto.Lol.Cyclotomic.Cyc". + + * \( n=\varphi(m) \) is the totient function of the cyclotomic index. + This is the dimension of a cyclotomic ring over the base ring. +-} module Crypto.Lol ( module X diff --git a/Crypto/Lol/CRTrans.hs b/Crypto/Lol/CRTrans.hs --- a/Crypto/Lol/CRTrans.hs +++ b/Crypto/Lol/CRTrans.hs @@ -1,3 +1,19 @@ +{-| +Module : Crypto.Lol.CRTrans +Description : Functions related to the Chinese Remainder Transform. +Copyright : (c) Eric Crockett, 2011-2017 + Chris Peikert, 2011-2017 +License : GPL-2 +Maintainer : ecrockett0@email.com +Stability : experimental +Portability : POSIX + + \( \def\C{\mathbb{C}} \) + +Classes and helper methods for the Chinese remainder transform +and ring extensions. +-} + {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -5,11 +21,6 @@ {-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} - --- | \( \def\C{\mathbb{C}} \) --- --- Classes and helper methods for the Chinese remainder transform --- and ring extensions. module Crypto.Lol.CRTrans ( CRTrans(..), CRTEmbed(..) diff --git a/Crypto/Lol/Cyclotomic/CRTSentinel.hs b/Crypto/Lol/Cyclotomic/CRTSentinel.hs --- a/Crypto/Lol/Cyclotomic/CRTSentinel.hs +++ b/Crypto/Lol/Cyclotomic/CRTSentinel.hs @@ -1,13 +1,26 @@ +{-| +Module : Crypto.Lol.Cyclotomic.CRTSentinel +Description : Safely exposes a "sentinel" indicating usage of either CRT basis + over a base ring, or over its extension ring. +Copyright : (c) Eric Crockett, 2011-2017 + Chris Peikert, 2011-2017 +License : GPL-2 +Maintainer : ecrockett0@email.com +Stability : experimental +Portability : POSIX + +Safely exposes a "sentinel" indicating usage of either CRT basis +over a base ring, or over its extension ring. Exactly one of +'CSentinel' or 'ESentinel' has an externally exposed value. +-} + +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} - --- | Safely exposes a "sentinel" indicating usage of either CRT basis --- over a base ring, or over its extension ring. Exactly one of --- 'CSentinel' or 'ESentinel' has an externally exposed value. module Crypto.Lol.Cyclotomic.CRTSentinel ( CSentinel, ESentinel diff --git a/Crypto/Lol/Cyclotomic/Cyc.hs b/Crypto/Lol/Cyclotomic/Cyc.hs --- a/Crypto/Lol/Cyclotomic/Cyc.hs +++ b/Crypto/Lol/Cyclotomic/Cyc.hs @@ -1,3 +1,38 @@ +{-| +Module : Crypto.Lol.Cyclotomic.Cyc +Description : An implementation of cyclotomic rings that hides the + internal representations of ring elements. +Copyright : (c) Eric Crockett, 2011-2017 + Chris Peikert, 2011-2017 +License : GPL-2 +Maintainer : ecrockett0@email.com +Stability : experimental +Portability : POSIX + + \( \def\Z{\mathbb{Z}} \) + \( \def\F{\mathbb{F}} \) + \( \def\Q{\mathbb{Q}} \) + \( \def\Tw{\text{Tw}} \) + \( \def\Tr{\text{Tr}} \) + \( \def\O{\mathcal{O}} \) + +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". + +__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. +-} + {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} @@ -12,29 +47,8 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} --- | \( \def\Z{\mathbb{Z}} \) --- \( \def\F{\mathbb{F}} \) --- \( \def\Q{\mathbb{Q}} \) --- \( \def\Tw{\text{Tw}} \) --- \( \def\Tr{\text{Tr}} \) --- \( \def\O{\mathcal{O}} \) --- --- 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". --- --- __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 @@ -77,12 +91,10 @@ import Control.DeepSeq -- GHC warning is wrong: https://ghc.haskell.org/trac/ghc/ticket/12067 import Control.Monad.Identity -import Control.Monad.Random +import Control.Monad.Random hiding (lift) import Data.Coerce import Data.Traversable -import Test.QuickCheck - -- | Represents a cyclotomic ring such as \(\Z[\zeta_m]\), -- \(\Z_q[\zeta_m]\), and \(\Q[\zeta_m]\) in an explicit -- representation: @t@ is the @@ -611,13 +623,18 @@ 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 + +instance (Show r, Show (CRTExt r), Fact m, TElt t r, TElt t (CRTExt r), Tensor t) + => Show (Cyc t m r) where + show (Pow x) = "Pow " ++ show x + show (Dec x) = "Dec " ++ show x + show (CRT (Left x)) = "CRT " ++ show x + show (CRT (Right x)) = "CRT " ++ show x + show (Scalar x) = "Scalar " ++ show x + show (Sub x) = "Sub " ++ show x diff --git a/Crypto/Lol/Cyclotomic/Linear.hs b/Crypto/Lol/Cyclotomic/Linear.hs --- a/Crypto/Lol/Cyclotomic/Linear.hs +++ b/Crypto/Lol/Cyclotomic/Linear.hs @@ -1,3 +1,20 @@ +{-| +Module : Crypto.Lol.Cyclotomic.Linear +Description : Functions from one cyclotomic ring to another that are linear + over a common subring. +Copyright : (c) Eric Crockett, 2011-2017 + Chris Peikert, 2011-2017 +License : GPL-2 +Maintainer : ecrockett0@email.com +Stability : experimental +Portability : POSIX + + \( \def\lcm{\text{lcm}} \) + +Functions from one cyclotomic ring to another that are linear +over a common subring. +-} + {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} @@ -12,11 +29,6 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} --- | \( \def\lcm{\text{lcm}} \) --- --- Functions from one cyclotomic ring to another that are linear --- over a common subring. - module Crypto.Lol.Cyclotomic.Linear ( Linear, ExtendLinIdx , linearDec, evalLin, extendLin @@ -24,12 +36,18 @@ import Crypto.Lol.Cyclotomic.Cyc import Crypto.Lol.Prelude +import Crypto.Lol.Reflects +import Crypto.Lol.Types.Proto +import Crypto.Proto.Lol.RqProduct (RqProduct) +import Crypto.Proto.Lol.LinearRq (LinearRq(LinearRq)) import Algebra.Additive as Additive (C) import Control.Applicative import Control.DeepSeq +import Data.Word + -- | An \(E\)-linear function from \(R\) to \(S\). -- CJP: also have constructor for relative Pow basis of R/E? So far @@ -99,3 +117,18 @@ -- relax the constraint on E then we'd have to change the -- implementation to something more difficult. extendLin (RD ys) = RD (embed <$> ys) + +instance (Reflects e Word32, Reflects r Word32, + Protoable (Cyc t s zq), ProtoType (t s zq) ~ RqProduct) + => Protoable (Linear t zq e r s) where + type ProtoType (Linear t zq e r s) = LinearRq + toProto (RD cs) = LinearRq (proxy value (Proxy::Proxy e)) (proxy value (Proxy::Proxy r)) $ toProto cs + fromProto (LinearRq e r cs) = + let e' = proxy value (Proxy::Proxy e) + r' = proxy value (Proxy::Proxy r) + in if e == e' && r == r' + then RD <$> fromProto cs + else error $ "Could not deserialize Linear: types imply e=" ++ + show e' ++ " and r=" ++ show r' ++ + ", but serializd object is for e=" ++ + show e ++ " and r=" ++ show r diff --git a/Crypto/Lol/Cyclotomic/RescaleCyc.hs b/Crypto/Lol/Cyclotomic/RescaleCyc.hs --- a/Crypto/Lol/Cyclotomic/RescaleCyc.hs +++ b/Crypto/Lol/Cyclotomic/RescaleCyc.hs @@ -1,8 +1,19 @@ -{-# LANGUAGE MultiParamTypeClasses #-} +{-| +Module : Crypto.Lol.Cyclotomic.RescaleCyc +Description : A class and helper functions for rescaling cycltomic ring elements. +Copyright : (c) Eric Crockett, 2011-2017 + Chris Peikert, 2011-2017 +License : GPL-2 +Maintainer : ecrockett0@email.com +Stability : experimental +Portability : POSIX --- | \( \def\Z{\mathbb{Z}} \) --- --- A class and helper functions for rescaling cycltomic ring elements. + \( \def\Z{\mathbb{Z}} \) + +A class and helper functions for rescaling cycltomic ring elements. +-} + +{-# LANGUAGE MultiParamTypeClasses #-} module Crypto.Lol.Cyclotomic.RescaleCyc where diff --git a/Crypto/Lol/Cyclotomic/Tensor.hs b/Crypto/Lol/Cyclotomic/Tensor.hs --- a/Crypto/Lol/Cyclotomic/Tensor.hs +++ b/Crypto/Lol/Cyclotomic/Tensor.hs @@ -1,4 +1,24 @@ -{-# LANGUAGE CPP #-} +{-| +Module : Crypto.Lol.Cyclotomic.Tensor +Description : Interface for cyclotomic tensors, and + helper functions for tensor indexing. +Copyright : (c) Eric Crockett, 2011-2017 + Chris Peikert, 2011-2017 +License : GPL-2 +Maintainer : ecrockett0@email.com +Stability : experimental +Portability : POSIX + + \( \def\Z{\mathbb{Z}} \) + \( \def\Tw{\text{Tw}} \) + \( \def\Tr{\text{Tr}} \) + \( \def\CRT{\text{CRT}} \) + \( \def\O{\mathcal{O}} \) + +Interface for cyclotomic tensors, and helper functions for tensor +indexing. +-} + {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} @@ -11,19 +31,8 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -#if __GLASGOW_HASKELL__ >= 800 {-# LANGUAGE UndecidableSuperClasses #-} -#endif --- | \( \def\Z{\mathbb{Z}} \) --- \( \def\Tw{\text{Tw}} \) --- \( \def\Tr{\text{Tr}} \) --- \( \def\CRT{\text{CRT}} \) --- \( \def\O{\mathcal{O}} \) --- --- Interface for cyclotomic tensors, and helper functions for tensor --- indexing. - module Crypto.Lol.Cyclotomic.Tensor ( Tensor(..) -- * Top-level CRT functions @@ -371,11 +380,12 @@ -- 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, and CRT bases --- because all these bases have that factorization. The first argument is the --- list of \((\varphi(m),\varphi(m'))\) pairs for the (merged) prime powers +-- | Correspondences between the one-dim indexes into a basis of +-- \(\O_{m'}\), and pair indices into [extension basis of \( +-- \O_{m'}/\O_m \)] \(\otimes\) [basis of \(\O_m\)]. The +-- correspondences are the same for Pow, Dec, and CRT bases because +-- they all have such a factorization. The first argument is the list +-- of \((\varphi(m),\varphi(m'))\) pairs for the (merged) prime powers -- of \(m\),\(m'\). toIndexPair :: [(Int,Int)] -> Int -> (Int,Int) fromIndexPair :: [(Int,Int)] -> (Int,Int) -> Int @@ -440,23 +450,22 @@ -- | A lookup table for 'toIndexPair' applied to indices \([\varphi(m')]\). baseIndicesPow :: forall m m' . (m `Divides` m') => Tagged '(m, m') (U.Vector (Int,Int)) +baseIndicesPow = baseWrapper (toIndexPair . totients) {-# INLINABLE baseIndicesPow #-} + -- | A lookup table for 'baseIndexDec' applied to indices \([\varphi(m')]\). baseIndicesDec :: forall m m' . (m `Divides` m') => Tagged '(m, m') (U.Vector (Maybe (Int,Bool))) +-- this one is more complicated; requires the prime powers +baseIndicesDec = baseWrapper baseIndexDec {-# INLINABLE baseIndicesDec #-} + -- | 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 \(i_0\)th entry of the \(i_1\)th vector is -- 'fromIndexPair' \((i_1,i_0)\). diff --git a/Crypto/Lol/Cyclotomic/Tensor/CTensor.hs b/Crypto/Lol/Cyclotomic/Tensor/CTensor.hs deleted file mode 100644 --- a/Crypto/Lol/Cyclotomic/Tensor/CTensor.hs +++ /dev/null @@ -1,493 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RebindableSyntax #-} -{-# LANGUAGE RoleAnnotations #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE UndecidableInstances #-} - --- | 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.Except -import Control.Monad.Identity (Identity (..), runIdentity) -import Control.Monad.Random -import Control.Monad.Trans as T (lift) - -import Data.Coerce -import Data.Constraint hiding ((***)) -import Data.Int -import Data.Maybe -import Data.Traversable as T -import Data.Vector.Generic as V (fromList, toList, unzip) -import Data.Vector.Storable as SV (Vector, convert, foldl', - fromList, generate, - length, map, replicate, - replicateM, thaw, thaw, toList, - unsafeFreeze, - unsafeWith, zipWith, (!)) -import Data.Vector.Storable.Mutable as SM hiding (replicate) - -import Foreign.Marshal.Utils (with) -import Foreign.Ptr -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.Prelude as LP hiding - (replicate, - unzip, zip) -import Crypto.Lol.Reflects -import Crypto.Lol.Types.FiniteField -import Crypto.Lol.Types.IZipVector -import Crypto.Lol.Types.Proto -import Crypto.Lol.Types.RRq -import Crypto.Lol.Types.ZqBasic - -import Crypto.Proto.RLWE.Kq -import Crypto.Proto.RLWE.Rq - -import Data.Foldable as F -import Data.Sequence as S (fromList) - -import System.IO.Unsafe (unsafePerformIO) - --- | Newtype wrapper around a Vector. -newtype CT' (m :: Factored) r = CT' { unCT :: Vector r } - 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 - -deriving instance Show r => Show (CT m r) - -instance Eq r => Eq (CT m r) where - (ZV x) == (ZV y) = x == y - (CT x) == (CT y) = x == y - x@(CT _) == y = x == toCT y - y == x@(CT _) = x == toCT y - -instance (Fact m, Reflects q Int64) => Protoable (CT m (ZqBasic q Int64)) where - type ProtoType (CT m (ZqBasic q Int64)) = Rq - - toProto (CT (CT' xs)) = - let m = fromIntegral $ proxy valueFact (Proxy::Proxy m) - q = proxy value (Proxy::Proxy q) :: Int64 - in Rq m (fromIntegral q) $ S.fromList $ SV.toList $ SV.map LP.lift xs - toProto x@(ZV _) = toProto $ toCT x - - fromProto (Rq m' q' xs) = - let m = proxy valueFact (Proxy::Proxy m) :: Int - q = proxy value (Proxy::Proxy q) :: Int64 - n = proxy totientFact (Proxy::Proxy m) - xs' = SV.fromList $ F.toList xs - len = F.length xs - in if m == fromIntegral m' && len == n && fromIntegral q == q' - then return $ CT $ CT' $ SV.map reduce xs' - else throwError $ - "An error occurred while reading the proto type for CT.\n\ - \Expected m=" ++ show m ++ ", got " ++ show m' ++ "\n\ - \Expected n=" ++ show n ++ ", got " ++ show len ++ "\n\ - \Expected q=" ++ show q ++ ", got " ++ show q' ++ "." - -instance (Fact m, Reflects q Double) => Protoable (CT m (RRq q Double)) where - type ProtoType (CT m (RRq q Double)) = Kq - - toProto (CT (CT' xs)) = - let m = fromIntegral $ proxy valueFact (Proxy::Proxy m) - q = round (proxy value (Proxy::Proxy q) :: Double) - in Kq m q $ S.fromList $ SV.toList $ SV.map LP.lift xs - toProto x@(ZV _) = toProto $ toCT x - - fromProto (Kq m' q' xs) = - let m = proxy valueFact (Proxy::Proxy m) :: Int - q = round (proxy value (Proxy::Proxy q) :: Double) - n = proxy totientFact (Proxy::Proxy m) - xs' = SV.fromList $ F.toList xs - len = F.length xs - in if m == fromIntegral m' && len == n && q == q' - then return $ CT $ CT' $ SV.map reduce xs' - else throwError $ - "An error occurred while reading the proto type for CT.\n\ - \Expected m=" ++ show m ++ ", got " ++ show m' ++ "\n\ - \Expected n=" ++ show n ++ ", got " ++ show len ++ "\n\ - \Expected q=" ++ show q ++ ", got " ++ show q' ++ "." - -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 s, Storable r) => (CT' l s -> CT' m r) -> (CT l s -> CT m r) -{-# INLINABLE wrap #-} -wrap f (CT v) = CT $ f v -wrap f (ZV v) = CT $ f $ zvToCT' v - -wrapM :: (Storable s, Storable r, Monad mon) => (CT' l s -> mon (CT' m r)) - -> (CT l s -> mon (CT m r)) -{-# INLINABLE wrapM #-} -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 (very fast) C function for (*) and (+) -instance (Additive r, Storable r, Fact m) - => Additive.C (CT m r) where - (CT (CT' a)) + (CT (CT' b)) = CT $ CT' $ SV.zipWith (+) a b - a + b = toCT a + toCT b - negate (CT (CT' a)) = CT $ CT' $ SV.map negate a -- EAC: This probably should be converted to C code - negate a = negate $ toCT a - - 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) - => 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 $ basicDispatch dl - lInv = wrap $ basicDispatch dlinv - - mulGPow = wrap $ basicDispatch dmulgpow - mulGDec = wrap $ basicDispatch dmulgdec - - divGPow = wrapM $ dispatchGInv dginvpow - divGDec = wrapM $ dispatchGInv dginvdec - - crtFuncs = (,,,,) <$> - return (CT . repl) <*> - (wrap . untag (cZipDispatch dmul) <$> gCRT) <*> - (wrap . untag (cZipDispatch dmul) <$> gInvCRT) <*> - (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 = wrap $ coerce (SV.map f) - - zipWithT f v1' v2' = - let (CT (CT' v1)) = toCT v1' - (CT (CT' v2)) = toCT v2' - in CT $ CT' $ SV.zipWith f v1 v2 - - unzipT v = - let (CT (CT' x)) = toCT v - in (CT . CT') *** (CT . CT') $ unzip x - - {-# 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 #-} - {-# INLINE crtExtFuncs #-} - {-# INLINABLE coeffs #-} - {-# INLINABLE powBasisPow #-} - {-# INLINABLE crtSetDec #-} - {-# INLINABLE fmapT #-} - {-# INLINE zipWithT #-} - {-# INLINE 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 :: 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 :: Tagged '(m,m') [Vector r] -> Tagged m [CT' m' r] -coerceBasis = coerce - -dispatchGInv :: forall m r . (Storable r, Fact m) - => (Ptr r -> Int64 -> Ptr CPP -> Int16 -> IO Int16) - -> CT' m r -> Maybe (CT' m r) -dispatchGInv f = - let factors = proxy (marshalFactors <$> ppsFact) (Proxy::Proxy m) - totm = proxy (fromIntegral <$> totientFact) (Proxy::Proxy m) - numFacts = fromIntegral $ SV.length factors - in \(CT' x) -> unsafePerformIO $ do - yout <- SV.thaw x - ret <- SM.unsafeWith yout (\pout -> - SV.unsafeWith factors (\pfac -> - f pout totm pfac numFacts)) - if ret /= 0 - then Just . CT' <$> unsafeFreeze yout - else return Nothing - -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 :: (Storable r, Fact m) - => (Ptr r -> Int64 -> Ptr CPP -> Int16 -> IO ()) - -> CT' m r -> CT' m r -basicDispatch f = unsafePerformIO . withBasicArgs f - -gSqNormDec' :: (Storable r, Fact m, Dispatch r) - => Tagged m (CT' m r -> r) -gSqNormDec' = return $ (!0) . unCT . unsafePerformIO . withBasicArgs dnorm - -ctCRT :: (Storable r, CRTrans mon r, Dispatch r, Fact m) - => TaggedT m mon (CT' m r -> CT' m r) -ctCRT = do - ru' <- ru - return $ \x -> unsafePerformIO $ - withPtrArray ru' (flip withBasicArgs x . dcrt) - --- CTensor CRT^(-1) functions take inverse rus -ctCRTInv :: (Storable r, CRTrans mon r, Dispatch r, Fact m) - => TaggedT m mon (CT' m r -> CT' m r) -ctCRTInv = do - mhatInv <- snd <$> crtInfo - ruinv' <- ruInv - return $ \x -> unsafePerformIO $ - withPtrArray ruinv' (\ruptr -> with mhatInv (flip withBasicArgs x . dcrtinv ruptr)) - -cZipDispatch :: (Storable r, Fact m) - => (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) - -- takes ru (not ruInv) to match RT - ruinv' <- mapTaggedT (return . fromMaybe (error "complexGaussianRoots")) ru - totm <- pureT totientFact - m <- pureT valueFact - rad <- pureT radicalFact - yin <- T.lift $ realGaussians (var * fromIntegral (m `div` rad)) totm - return $ unsafePerformIO $ - withPtrArray ruinv' (\ruptr -> withBasicArgs (dgaussdec ruptr) (CT' yin)) - -instance (Arbitrary r, Fact m, Storable r) => Arbitrary (CT' m r) where - 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 - -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 :: (CRTrans mon r, Fact m, Storable r) - => TaggedT m mon [Vector r] -ru = do - mval <- pureT valueFact - wPow <- fst <$> crtInfo - LP.map - (\(p,e) -> do - let pp = p^e - pow = mval `div` pp - generate pp (wPow . (*pow))) <$> - pureT ppsFact - -ruInv = do - mval <- pureT valueFact - wPow <- fst <$> crtInfo - LP.map - (\(p,e) -> do - let pp = p^e - pow = mval `div` pp - generate pp (\i -> wPow $ -i*pow)) <$> - pureT ppsFact - -wrapVector :: forall mon m r . (Monad mon, Fact m, Ring r, Storable r) - => TaggedT m mon (Kron r) -> mon (CT' m r) -wrapVector v = do - vmat <- proxyT v (Proxy::Proxy m) - let n = proxy totientFact (Proxy::Proxy m) - return $ CT' $ generate n (flip (indexK vmat) 0) - -gCRT, gInvCRT :: (Storable r, CRTrans mon r, Fact m) - => mon (CT' m r) -gCRT = wrapVector gCRTK -gInvCRT = wrapVector gInvCRTK diff --git a/Crypto/Lol/Cyclotomic/Tensor/CTensor/Backend.hs b/Crypto/Lol/Cyclotomic/Tensor/CTensor/Backend.hs deleted file mode 100644 --- a/Crypto/Lol/Cyclotomic/Tensor/CTensor/Backend.hs +++ /dev/null @@ -1,333 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} -#if __GLASGOW_HASKELL__ >= 800 -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeOperators #-} -{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-} -#endif - --- | This module contains the functions to transform Haskell types into their --- C counterpart, and to transform polymorphic Haskell functions into C funtion --- calls in a type-safe way. - -module Crypto.Lol.Cyclotomic.Tensor.CTensor.Backend -( Dispatch -, dcrt, dcrtinv -, dgaussdec -, dl, dlinv -, dnorm -, dmulgpow, dmulgdec -, dginvpow, dginvdec -, dmul -, marshalFactors -, CPP -, withArray, withPtrArray -) where - -import Crypto.Lol.Prelude as LP (Complex, PP, Proxy (..), Tagged, - map, mapM_, proxy, tag) -import Crypto.Lol.Reflects -import Crypto.Lol.Types.RRq -import Crypto.Lol.Types.ZqBasic - -import Data.Int -import Data.Vector.Storable as SV (Vector, fromList, - unsafeToForeignPtr0) -import Data.Vector.Storable.Internal (getPtr) - -import Foreign.ForeignPtr (touchForeignPtr) -import Foreign.Marshal.Array (withArray) -import Foreign.Marshal.Utils (with) -import Foreign.Ptr (Ptr, castPtr, plusPtr) -import Foreign.Storable (Storable (..)) - -#if __GLASGOW_HASKELL__ >= 800 -import GHC.TypeLits -- for error message -#endif - --- | Convert a list of prime powers to a suitable C representation. -marshalFactors :: [PP] -> Vector CPP -marshalFactors = SV.fromList . LP.map (\(p,e) -> (fromIntegral p, fromIntegral e)) - --- http://stackoverflow.com/questions/6517387/vector-vector-foo-ptr-ptr-foo-io-a-io-a --- | Evaluates a C function that takes an "a** ptr" on a list of Vectors. -withPtrArray :: (Storable a) => [Vector a] -> (Ptr (Ptr a) -> IO b) -> IO b -withPtrArray v f = do - let vs = LP.map SV.unsafeToForeignPtr0 v - ptrV = LP.map (\(fp,_) -> getPtr fp) vs - res <- withArray ptrV f - LP.mapM_ (\(fp,_) -> touchForeignPtr fp) vs - return res - --- Note: These types need to be the same, otherwise something goes wrong on the C end... --- | C representation of a prime power. -type CPP = (Int16, Int16) - -instance (Storable a, Storable b) - => 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 -data RRqD - -type family CTypeOf x where - CTypeOf (a,b) = EqCType a b (CTypeOf a) (CTypeOf b) - CTypeOf (ZqBasic (q :: k) Int64) = ZqB64D - CTypeOf Double = DoubleD - CTypeOf Int64 = Int64D - CTypeOf (Complex Double) = ComplexD - CTypeOf (RRq (q :: k) Double) = RRqD -#if __GLASGOW_HASKELL__ >= 800 - -- EAC: See #12237 and #11990 - CTypeOf (ZqBasic (q :: k) i) = TypeError (Text "Unsupported C type: " :<>: ShowType (ZqBasic q i) :$$: Text "Use Int64 as the base ring") - CTypeOf (Complex i) = TypeError (Text "Unsupported C type: " :<>: ShowType (Complex i) :$$: Text "Use Double as the base ring") - CTypeOf (RRq (q :: k) i) = TypeError (Text "Unsupported C type: " :<>: ShowType (RRq q i) :$$: Text "Use Double as the base ring") - CTypeOf a = TypeError (Text "Unsupported C type: " :<>: ShowType a) -#endif - -type family EqCType a b c d where - EqCType a b ZqB64D ZqB64D = ZqB64D - EqCType a b RRqD RRqD = RRqD - EqCType a b ComplexD ComplexD = ComplexD -#if __GLASGOW_HASKELL__ >= 800 - EqCType a b c c = TypeError (Text "Cannot call C code on a tuple of type " :<>: ShowType a) - EqCType a b c d = TypeError (Text "You are trying to use CTensor on a tuple," :<>: - Text " but the tuple contains two different C types: " :$$: - ShowType a :<>: Text " and " :<>: ShowType b) -#endif - --- 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 (Reflects q r, RealFrac r) => ZqTuple (RRq q r) where - type ModPairs (RRq q r) = Int64 - getModuli = tag $ round (proxy value (Proxy::Proxy q) :: r) - -instance (ZqTuple a, ZqTuple b) => ZqTuple (a, b) where - type ModPairs (a,b) = (ModPairs a, ModPairs b) - getModuli = - 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) - --- | Single-argument synonym for @Dispatch'@. -type Dispatch r = (Dispatch' (CTypeOf r) r) - --- | Class to safely match Haskell types with the appropriate C function. -class (repr ~ CTypeOf r) => Dispatch' repr r where - -- | Equivalent to 'Tensor's @crt@. - dcrt :: Ptr (Ptr r) -> Ptr r -> Int64 -> Ptr CPP -> Int16 -> IO () - -- | Equivalent to 'Tensor's @crtInv@. - dcrtinv :: Ptr (Ptr r) -> Ptr r -> Ptr r -> Int64 -> Ptr CPP -> Int16 -> IO () - -- | Equivalent to 'Tensor's @tGaussianDec@. - dgaussdec :: Ptr (Ptr (Complex r)) -> Ptr r -> Int64 -> Ptr CPP -> Int16 -> IO () - -- | Equivalent to 'Tensor's @l@. - dl :: Ptr r -> Int64 -> Ptr CPP -> Int16 -> IO () - -- | Equivalent to 'Tensor's @lInv@. - dlinv :: Ptr r -> Int64 -> Ptr CPP -> Int16 -> IO () - -- | Equivalent to 'Tensor's @gSqNormDec@. - dnorm :: Ptr r -> Int64 -> Ptr CPP -> Int16 -> IO () - -- | Equivalent to 'Tensor's @mulGPow@. - dmulgpow :: Ptr r -> Int64 -> Ptr CPP -> Int16 -> IO () - -- | Equivalent to 'Tensor's @mulGDec@. - dmulgdec :: Ptr r -> Int64 -> Ptr CPP -> Int16 -> IO () - -- | Equivalent to 'Tensor's @divGPow@. - dginvpow :: Ptr r -> Int64 -> Ptr CPP -> Int16 -> IO Int16 - -- | Equivalent to 'Tensor's @divGDec@. - dginvdec :: Ptr r -> Int64 -> Ptr CPP -> Int16 -> IO Int16 - -- | Equivalent to @zipWith (*)@ - dmul :: Ptr r -> Ptr r -> Int64 -> IO () - -instance (ZqTuple r, Storable (ModPairs r), CTypeOf r ~ RRqD) - => Dispatch' RRqD r where - dcrt = error "cannot call CT CRT on type RRq" - dcrtinv = error "cannot call CT CRTInv on type RRq" - dl = error "cannot call CT L on type RRq (though you probably should be able to)" - dlinv = error "cannot call CT LInv on type RRq (though you probably should be able to)" - dnorm = error "cannto call CT normSq on type RRq" - dmulgpow = error "cannot call CT mulGPow on type RRq" - dmulgdec = error "cannot call CT mulGDec on type RRq" - dginvpow = error "cannot call CT divGPow on type RRq" - dginvdec = error "cannot call CT divGDec on type RRq" - dmul = error "cannot call CT mul on type RRq" - dgaussdec = error "cannot call CT gaussianDec on type RRq" - -instance (ZqTuple r, Storable (ModPairs r), CTypeOf r ~ ZqB64D) - => Dispatch' ZqB64D r where - dcrt ruptr pout totm pfac numFacts = - 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) - 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" - --- products of Complex correspond to CRTExt of a Zq product -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 pout = - tensorGDecC (proxy numComponents (Proxy::Proxy r)) (castPtr pout) - dginvpow pout = - tensorGInvPowC (proxy numComponents (Proxy::Proxy r)) (castPtr pout) - dginvdec pout = - tensorGInvDecC (proxy numComponents (Proxy::Proxy r)) (castPtr pout) - dmul aout bout = - mulC (proxy numComponents (Proxy::Proxy r)) (castPtr aout) (castPtr bout) - dgaussdec = error "cannot call CT gaussianDec on type Comple Double" - --- no support for products of Double -instance Dispatch' DoubleD Double where - dcrt = error "cannot call CT Crt on type Double" - dcrtinv = error "cannot call CT CrtInv on type Double" - dl pout = - tensorLDouble 1 (castPtr pout) - dlinv pout = - tensorLInvDouble 1 (castPtr pout) - dnorm pout = tensorNormSqD 1 (castPtr pout) - dmulgpow = error "cannot call CT mulGPow on type Double" - dmulgdec = error "cannot call CT mulGDec on type Double" - dginvpow = error "cannot call CT divGPow on type Double" - dginvdec = error "cannot call CT divGDec on type Double" - dmul = error "cannot call CT (*) on type Double" - dgaussdec ruptr pout totm pfac numFacts = - tensorGaussianDec 1 (castPtr pout) totm pfac numFacts (castPtr ruptr) - --- no support for products of Z -instance Dispatch' Int64D Int64 where - dcrt = error "cannot call CT Crt on type Int64" - dcrtinv = error "cannot call CT CrtInv on type Int64" - dl pout = - tensorLR 1 (castPtr pout) - dlinv pout = - tensorLInvR 1 (castPtr pout) - dnorm pout = - tensorNormSqR 1 (castPtr pout) - dmulgpow pout = - tensorGPowR 1 (castPtr pout) - dmulgdec pout = - tensorGDecR 1 (castPtr pout) - dginvpow pout = - tensorGInvPowR 1 (castPtr pout) - dginvdec pout = - tensorGInvDecR 1 (castPtr pout) - 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 "tensorNormSqD" tensorNormSqD :: Int16 -> Ptr Double -> Int64 -> Ptr CPP -> Int16 -> IO () - -foreign import ccall unsafe "tensorGPowR" tensorGPowR :: Int16 -> Ptr Int64 -> Int64 -> Ptr CPP -> Int16 -> IO () -foreign import ccall unsafe "tensorGPowRq" tensorGPowRq :: Int16 -> Ptr (ZqBasic q Int64) -> Int64 -> Ptr CPP -> Int16 -> Ptr Int64 -> IO () -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 "tensorGDecC" tensorGDecC :: Int16 -> Ptr (Complex Double) -> Int64 -> Ptr CPP -> Int16 -> IO () -foreign import ccall unsafe "tensorGInvPowR" tensorGInvPowR :: Int16 -> Ptr Int64 -> Int64 -> Ptr CPP -> Int16 -> IO Int16 -foreign import ccall unsafe "tensorGInvPowRq" tensorGInvPowRq :: Int16 -> Ptr (ZqBasic q Int64) -> Int64 -> Ptr CPP -> Int16 -> Ptr Int64 -> IO Int16 -foreign import ccall unsafe "tensorGInvPowC" tensorGInvPowC :: Int16 -> Ptr (Complex Double) -> Int64 -> Ptr CPP -> Int16 -> IO Int16 -foreign import ccall unsafe "tensorGInvDecR" tensorGInvDecR :: Int16 -> Ptr Int64 -> Int64 -> Ptr CPP -> Int16 -> IO Int16 -foreign import ccall unsafe "tensorGInvDecRq" tensorGInvDecRq :: Int16 -> Ptr (ZqBasic q Int64) -> Int64 -> Ptr CPP -> Int16 -> Ptr Int64 -> IO Int16 -foreign import ccall unsafe "tensorGInvDecC" tensorGInvDecC :: Int16 -> Ptr (Complex Double) -> Int64 -> Ptr CPP -> Int16 -> IO Int16 - -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 () diff --git a/Crypto/Lol/Cyclotomic/Tensor/CTensor/Extension.hs b/Crypto/Lol/Cyclotomic/Tensor/CTensor/Extension.hs deleted file mode 100644 --- a/Crypto/Lol/Cyclotomic/Tensor/CTensor/Extension.hs +++ /dev/null @@ -1,154 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RebindableSyntax #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE 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.Cyclotomic.Tensor as T -import Crypto.Lol.Prelude as LP hiding (lift, null) -import Crypto.Lol.Types.FiniteField -import Crypto.Lol.Types.ZmStar - - -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.Storable as SV -import qualified Data.Vector.Unboxed as U - - --- | /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' :: (Storable a) => - U.Vector Int -- ^ @is@ index vector (of length @n@) - -> Vector a -- ^ @xs@ value vector - -> Vector a -{-# INLINABLE backpermute' #-} -backpermute' is v = generate (U.length is) (\i -> v ! (is U.! i)) - -embedPow', embedDec' :: (Additive r, Storable r, m `Divides` m') - => Tagged '(m, m') (Vector r -> Vector r) -{-# INLINABLE embedPow' #-} -{-# INLINABLE embedDec' #-} --- | 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 U.! 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 mon m m' r . (CRTrans mon r, Storable r, m `Divides` m') - => TaggedT '(m, m') mon (Vector r -> Vector r) -embedCRT' = - (lift (proxyT crtInfo (Proxy::Proxy m') :: mon (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' :: (Storable r, m `Divides` m') - => Tagged '(m, m') (Vector r -> [Vector 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 . (Storable r, m `Divides` m') - => Tagged '(m, m') (Vector r -> Vector r) -{-# INLINABLE twacePowDec' #-} -twacePowDec' = backpermute' <$> extIndicesPowDec - -kronToVec :: forall mon m r . (Monad mon, Fact m, Ring r, Storable r) - => TaggedT m mon (Kron r) -> TaggedT m mon (Vector r) -kronToVec v = do - vmat <- v - let n = proxy totientFact (Proxy::Proxy m) - return $ generate n (flip (indexK vmat) 0) - -twaceCRT' :: forall mon m m' r . - (Storable r, CRTrans mon r, m `Divides` m') - => TaggedT '(m, m') mon (Vector r -> Vector r) -{-# INLINE twaceCRT' #-} -twaceCRT' = tagT $ do - g' <- proxyT (kronToVec gCRTK) (Proxy::Proxy m') - gInv <- proxyT (kronToVec gInvCRTK) (Proxy::Proxy m) - embed <- proxyT embedCRT' (Proxy::Proxy '(m,m')) - indices <- pure $ proxy extIndicesCRT (Proxy::Proxy '(m,m')) - (_, m'hatinv) <- proxyT crtInfo (Proxy::Proxy m') - let phi = proxy totientFact (Proxy::Proxy m) - phi' = proxy totientFact (Proxy::Proxy m') - mhat = fromIntegral $ proxy valueHatFact (Proxy::Proxy m) - 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 - --- | 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' :: Kron (GF fp d) - = fromMaybe (error "internal error: crtSetDec': twCRTs") $ proxyT twCRTs m'p - zmsToIdx = proxy T.zmsToIndexFact m'p - elt j i = indexK 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' - (LP.sum $ LP.map (elt j) is))) cosets diff --git a/Crypto/Lol/Cyclotomic/Tensor/CTensor/common.cpp b/Crypto/Lol/Cyclotomic/Tensor/CTensor/common.cpp deleted file mode 100644 --- a/Crypto/Lol/Cyclotomic/Tensor/CTensor/common.cpp +++ /dev/null @@ -1,18 +0,0 @@ -#include "types.h" - -hInt_t Zq::q; // should be in zq.cpp; here due to GHC #12152 - -hDim_t ipow(hDim_t base, hShort_t exp) -{ - hDim_t result = 1; - while (exp) { - if (exp & 1) { - result *= base; - } - exp >>= 1; - base *= base; - } - return result; -} - - diff --git a/Crypto/Lol/Cyclotomic/Tensor/CTensor/common.h b/Crypto/Lol/Cyclotomic/Tensor/CTensor/common.h deleted file mode 100644 --- a/Crypto/Lol/Cyclotomic/Tensor/CTensor/common.h +++ /dev/null @@ -1,9 +0,0 @@ -#ifndef COMMON_H_ -#define COMMON_H_ - -#include "types.h" - -// calculates base ** exp -hDim_t ipow(hDim_t base, hShort_t exp); - -#endif /* COMMON_H_ */ diff --git a/Crypto/Lol/Cyclotomic/Tensor/CTensor/crt.cpp b/Crypto/Lol/Cyclotomic/Tensor/CTensor/crt.cpp deleted file mode 100644 --- a/Crypto/Lol/Cyclotomic/Tensor/CTensor/crt.cpp +++ /dev/null @@ -1,585 +0,0 @@ -#include "types.h" -#include "tensor.h" -#include "common.h" - -// there should be a special cases that do NOT require temp space to be allocated for all primes *smaller* than DFTP_GENERIC_SIZE -#define DFTP_GENERIC_SIZE 11 - -hDim_t bitrev (PrimeExponent pe, hDim_t j) { - hShort_t e; - hDim_t p = pe.prime; - hDim_t tempj = j; - hDim_t acc = 0; - - for(e = pe.exponent-1; e >= 0; e--) { - div_t qr = div(tempj,p); - acc += qr.rem * ipow(p,e); - tempj = qr.quot; - } - return acc; -} - -template void crtTwiddle (ring* y, hShort_t tupSize, hDim_t lts, hDim_t rts, - PrimeExponent pe, ring* ru) -{ - hDim_t p = pe.prime; - hShort_t e = pe.exponent; - - pe.exponent -= 1; // used for an argument to bitrev - - if(p == 2) { - hDim_t mprime = 1<<(e-1); - hDim_t blockDim = rts*mprime; // size of block in block diagonal tensor matrix - - for(hDim_t i0 = 1; i0 < mprime; i0++) { // loops over i/(p-1) for i = 0..(m'-1), we can skip i0 = 0 - hDim_t temp2 = i0*rts; - ring twid = ru[bitrev(pe, i0)*tupSize]; - - for(hDim_t blockIdx = 0; blockIdx < lts; blockIdx++) { - hDim_t temp3 = blockIdx*blockDim + temp2; - for(hDim_t modOffset = 0; modOffset < rts; modOffset++) { - hDim_t idx = (temp3 + modOffset)*tupSize; - y[idx] *= twid; - } - } - } - } - else { // This loop is faster, probably due to the division in the loop above. - // cilk also slows it down - hDim_t mprime = ipow(p,e-1); - hDim_t blockDim = rts*(p-1)*mprime; // size of block in block diagonal tensor matrix - - for(hDim_t i0 = 1; i0 < mprime; i0++) { // loops over i/(p-1) for i = 0..(m'-1), we can skip i0 = 0 - hDim_t temp1 = i0*(p-1); - for(hDim_t i1 = 0; i1 < (p-1); i1++) { // loops over i%(p-1) for i = 0..(m'-1) - hDim_t temp2 = (temp1+i1)*rts; - ring twid = ru[bitrev(pe, i0)*(i1+1)*tupSize]; - - for(hDim_t blockIdx = 0; blockIdx < lts; blockIdx++) { - hDim_t temp3 = blockIdx*blockDim + temp2; - for(hDim_t modOffset = 0; modOffset < rts; modOffset++) { - hDim_t idx = (temp3 + modOffset)*tupSize; - y[idx] *= twid; - } - } - } - } - } -} - -// dim is power of p -template void dftTwiddle (ring* y, hShort_t tupSize, hDim_t lts, hDim_t rts, - PrimeExponent pe, hDim_t dim, hDim_t rustride, ring* ru) -{ - hDim_t idx; - hDim_t p = pe.prime; - - pe.exponent -= 1; // used for an argument to bitrev - - if(p == 2) { - hDim_t mprime = dim>>1; // divides evenly - hDim_t temp1 = rts*dim; // for use in computing [modified] tensorOffset - for(hDim_t i0 = 1; i0 < mprime; i0++) { // loops over i/p for i = 0..(dim-1), but we skip i0=0 - hDim_t temp3 = rts*(i0*p+1); - ring twid = ru[bitrev(pe,i0)*rustride*tupSize]; - - for(hDim_t blockOffset = 0; blockOffset < lts; blockOffset++) { - hDim_t temp2 = blockOffset*temp1 + temp3; - for(hDim_t modOffset = 0; modOffset < rts; modOffset++) { - idx = (temp2 + modOffset)*tupSize; - y[idx] *= twid; - } - } - } - } - else { - hDim_t mprime = dim/p; // divides evenly - hDim_t temp1 = rts*dim; // for use in computing [modified] tensorOffset - for(hDim_t i0 = 1; i0 < mprime; i0++) { // loops over i/p for i = 0..(dim-1), but we skip i0=0 - for(hDim_t i1 = 1; i1 < p; i1++) { // loops over i%p for i = 0..(dim-1), but we skip i1=0 - hDim_t temp3 = rts*(i0*p+i1); - ring twid = ru[bitrev(pe,i0)*i1*rustride*tupSize]; - - for(hDim_t blockOffset = 0; blockOffset < lts; blockOffset++) { - hDim_t temp2 = blockOffset*temp1 + temp3; - for(hDim_t modOffset = 0; modOffset < rts; modOffset++) { - idx = (temp2 + modOffset)*tupSize; - y[idx] *= twid; - } - } - } - } - } -} - -//implied length of ru is rustride*p -//implied length of tempSpace is p, if p is not a special case -// temp is allowed to be NULL if p < DFTP_GENERIC_SIZE -template void dftp (ring* y, hShort_t tupSize, hDim_t lts, hDim_t rts, - hDim_t p, hDim_t rustride, ring* ru, ring* tempSpace) -{ - hDim_t tensorOffset; - - if(p == 2) { - hDim_t temp1 = rts<<1; - - for(hDim_t blockOffset = 0; blockOffset < lts; blockOffset++) { - hDim_t temp2 = blockOffset*temp1; - for(hDim_t modOffset = 0; modOffset < rts; modOffset++) { - tensorOffset = temp2 + modOffset; - ring u = y[tensorOffset*tupSize]; - ring t = y[(tensorOffset+rts)*tupSize]; - y[tensorOffset*tupSize] = u + t; - y[(tensorOffset+rts)*tupSize] = u - t; - } - } - } - else if(p == 3) { - ring ru1 = ru[rustride*tupSize]; - ring ru2 = ru[(rustride<<1)*tupSize]; - hDim_t temp1 = rts*3; - - for(hDim_t blockOffset = 0; blockOffset < lts; blockOffset++) { - hDim_t temp2 = blockOffset*temp1; - for(hDim_t modOffset = 0; modOffset < rts; modOffset++) { - tensorOffset = temp2 + modOffset; - ring y1, y2, y3; - y1 = y[tensorOffset*tupSize]; - y2 = y[(tensorOffset+rts)*tupSize]; - y3 = y[(tensorOffset+(rts<<1))*tupSize]; - //q is <32 bits, so we can do 3 additions without overflow - y[tensorOffset*tupSize] += (y2 + y3); - y[(tensorOffset+rts)*tupSize] = y1 + (ru1*y2) + (ru2*y3); - y[(tensorOffset+(rts<<1))*tupSize] = y1 + (ru2*y2) + (ru1*y3); - } - } - } - else if(p == 5) { - hDim_t temp1 = rts*5; - ring ru1 = ru[rustride*tupSize]; - ring ru2 = ru[(rustride<<1)*tupSize]; - ring ru3 = ru[(rustride*3)*tupSize]; - ring ru4 = ru[(rustride<<2)*tupSize]; - - for(hDim_t blockOffset = 0; blockOffset < lts; blockOffset++) { - hDim_t temp2 = blockOffset*temp1; - for(hDim_t modOffset = 0; modOffset < rts; modOffset++) { - tensorOffset = temp2 + modOffset; - ring y1, y2, y3, y4, y5; - y1 = y[tensorOffset*tupSize]; - y2 = y[(tensorOffset+rts)*tupSize]; - y3 = y[(tensorOffset+(rts<<1))*tupSize]; - y4 = y[(tensorOffset+3*rts)*tupSize]; - y5 = y[(tensorOffset+(rts<<2))*tupSize]; - y[tensorOffset*tupSize] += y2 + y3 + y4 + y5; - y[(tensorOffset+rts)*tupSize] = y1 + (ru1*y2) + (ru2*y3) + (ru3*y4) + (ru4*y5); - y[(tensorOffset+(rts<<1))*tupSize] = y1 + (ru2*y2) + (ru4*y3) + (ru1*y4) + (ru3*y5); - y[(tensorOffset+rts*3)*tupSize] = y1 + (ru3*y2) + (ru1*y3) + (ru4*y4) + (ru2*y5); - y[(tensorOffset+(rts<<2))*tupSize] = y1 + (ru4*y2) + (ru3*y3) + (ru2*y4) + (ru1*y5); - } - } - } - else if(p == 7) { - hDim_t temp1 = rts*7; - ring ru1 = ru[rustride*tupSize]; - ring ru2 = ru[(rustride<<1)*tupSize]; - ring ru3 = ru[(rustride*3)*tupSize]; - ring ru4 = ru[(rustride<<2)*tupSize]; - ring ru5 = ru[(rustride*5)*tupSize]; - ring ru6 = ru[(rustride*6)*tupSize]; - - for(hDim_t blockOffset = 0; blockOffset < lts; blockOffset++) { - hDim_t temp2 = blockOffset*temp1; - for(hDim_t modOffset = 0; modOffset < rts; modOffset++) { - tensorOffset = temp2 + modOffset; - ring y1, y2, y3, y4, y5, y6, y7; - y1 = y[tensorOffset*tupSize]; - y2 = y[(tensorOffset+rts)*tupSize]; - y3 = y[(tensorOffset+(rts<<1))*tupSize]; - y4 = y[(tensorOffset+3*rts)*tupSize]; - y5 = y[(tensorOffset+(rts<<2))*tupSize]; - y6 = y[(tensorOffset+rts*5)*tupSize]; - y7 = y[(tensorOffset+rts*6)*tupSize]; - y[tensorOffset*tupSize] += y2 + y3 + y4 + y5 + y6 + y7; - y[(tensorOffset+rts)*tupSize] = y1 + (ru1*y2) + (ru2*y3) + (ru3*y4) + (ru4*y5) + (ru5*y6) + (ru6*y7); - y[(tensorOffset+(rts<<1))*tupSize] = y1 + (ru2*y2) + (ru4*y3) + (ru6*y4) + (ru1*y5) + (ru3*y6) + (ru5*y7); - y[(tensorOffset+rts*3)*tupSize] = y1 + (ru3*y2) + (ru6*y3) + (ru2*y4) + (ru5*y5) + (ru1*y6) + (ru4*y7); - y[(tensorOffset+(rts<<2))*tupSize] = y1 + (ru4*y2) + (ru1*y3) + (ru5*y4) + (ru2*y5) + (ru6*y6) + (ru3*y7); - y[(tensorOffset+rts*5)*tupSize] = y1 + (ru5*y2) + (ru3*y3) + (ru1*y4) + (ru6*y5) + (ru4*y6) + (ru2*y7); - y[(tensorOffset+rts*6)*tupSize] = y1 + (ru6*y2) + (ru5*y3) + (ru4*y4) + (ru3*y5) + (ru2*y6) + (ru1*y7); - } - } - } - else { - hDim_t temp1 = rts*p; - for(hDim_t blockOffset = 0; blockOffset < lts; blockOffset++) { - hDim_t temp2 = blockOffset*temp1; - for(hDim_t modOffset = 0; modOffset < rts; modOffset++) { - tensorOffset = temp2 + modOffset; - for(hDim_t row = 0; row < p; row++) { - tempSpace[row] = 0; - //p is small (<< 30 bits), so we can do p additions of mod-q values without overflow - for(hDim_t col = 0; col < p; col++) { - tempSpace[row] += (y[(tensorOffset+col*rts)*tupSize]*ru[((col*row) % p)*rustride*tupSize]); - } - } - - for(hDim_t row = 0; row < p; row++) { - y[(tensorOffset+rts*row)*tupSize] = tempSpace[row]; - } - } - } - } -} - -template void crtp (ring* y, hShort_t tupSize, hDim_t lts, hDim_t rts, - hDim_t p, hDim_t rustride, ring* ru) -{ - hDim_t tensorOffset; - if(p == 2) { - return; - } - else if(p == 3) { - hDim_t temp1 = rts*2; - ring ru1 = ru[rustride*tupSize]; - ring ru2 = ru[(rustride<<1)*tupSize]; - - for(hDim_t blockOffset = 0; blockOffset < lts; blockOffset++) { - hDim_t temp2 = blockOffset*temp1; - for(hDim_t modOffset = 0; modOffset < rts; modOffset++) { - tensorOffset = temp2 + modOffset; - ring y1, y2; - y1 = y[tensorOffset*tupSize]; - y2 = y[(tensorOffset+rts)*tupSize]; - y[tensorOffset*tupSize] += (ru1*y2); - y[(tensorOffset+rts)*tupSize] = y1 + (ru2*y2); - } - } - } - else if(p == 5) { - hDim_t temp1 = rts*4; - ring ru1 = ru[rustride*tupSize]; - ring ru2 = ru[(rustride<<1)*tupSize]; - ring ru3 = ru[(rustride*3)*tupSize]; - ring ru4 = ru[(rustride<<2)*tupSize]; - - for(hDim_t blockOffset = 0; blockOffset < lts; blockOffset++) { - hDim_t temp2 = blockOffset*temp1; - for(hDim_t modOffset = 0; modOffset < rts; modOffset++) { - tensorOffset = temp2 + modOffset; - ring y1, y2, y3, y4; - y1 = y[tensorOffset*tupSize]; - y2 = y[(tensorOffset+rts)*tupSize]; - y3 = y[(tensorOffset+(rts<<1))*tupSize]; - y4 = y[(tensorOffset+3*rts)*tupSize]; - - y[tensorOffset*tupSize] += ((ru1*y2) + (ru2*y3) + (ru3*y4)); - y[(tensorOffset+rts)*tupSize] = y1 + (ru2*y2) + (ru4*y3) + (ru1*y4); - y[(tensorOffset+(rts<<1))*tupSize] = y1 + (ru3*y2) + (ru1*y3) + (ru4*y4); - y[(tensorOffset+rts*3)*tupSize] = y1 + (ru4*y2) + (ru3*y3) + (ru2*y4); - } - } - } - else if(p == 7) { - hDim_t temp1 = rts*6; - ring ru1 = ru[rustride*tupSize]; - ring ru2 = ru[(rustride<<1)*tupSize]; - ring ru3 = ru[(rustride*3)*tupSize]; - ring ru4 = ru[(rustride<<2)*tupSize]; - ring ru5 = ru[(rustride*5)*tupSize]; - ring ru6 = ru[(rustride*6)*tupSize]; - for(hDim_t blockOffset = 0; blockOffset < lts; blockOffset++) { - hDim_t temp2 = blockOffset*temp1; - for(hDim_t modOffset = 0; modOffset < rts; modOffset++) { - tensorOffset = temp2 + modOffset; - ring y1, y2, y3, y4, y5, y6; - y1 = y[tensorOffset*tupSize]; - y2 = y[(tensorOffset+rts)*tupSize]; - y3 = y[(tensorOffset+(rts<<1))*tupSize]; - y4 = y[(tensorOffset+3*rts)*tupSize]; - y5 = y[(tensorOffset+(rts<<2))*tupSize]; - y6 = y[(tensorOffset+rts*5)*tupSize]; - y[tensorOffset*tupSize] += ((ru1*y2) + (ru2*y3) + (ru3*y4) + (ru4*y5) + (ru5*y6)); - y[(tensorOffset+rts)*tupSize] = y1 + (ru2*y2) + (ru4*y3) + (ru6*y4) + (ru1*y5) + (ru3*y6); - y[(tensorOffset+(rts<<1))*tupSize] = y1 + (ru3*y2) + (ru6*y3) + (ru2*y4) + (ru5*y5) + (ru1*y6); - y[(tensorOffset+rts*3)*tupSize] = y1 + (ru4*y2) + (ru1*y3) + (ru5*y4) + (ru2*y5) + (ru6*y6); - y[(tensorOffset+(rts<<2))*tupSize] = y1 + (ru5*y2) + (ru3*y3) + (ru1*y4) + (ru6*y5) + (ru4*y6); - y[(tensorOffset+rts*5)*tupSize] = y1 + (ru6*y2) + (ru5*y3) + (ru4*y4) + (ru3*y5) + (ru2*y6); - } - } - } - else { - ring* tempSpace = (ring*)malloc((p-1)*sizeof(ring)); - hDim_t temp1 = rts*(p-1); - for(hDim_t blockOffset = 0; blockOffset < lts; blockOffset++) { - hDim_t temp2 = blockOffset*temp1; - for(hDim_t modOffset = 0; modOffset < rts; modOffset++) { - tensorOffset = temp2 + modOffset; - - for(hDim_t row = 1; row < p; row++) { - tempSpace[row-1] = 0; - for(hDim_t col = 0; col < p-1; col++) { - tempSpace[row-1] += (y[(tensorOffset+col*rts)*tupSize]*ru[((col*row) % p)*rustride*tupSize]); - } - } - - for(hDim_t row = 0; row < p-1; row++) { - y[(tensorOffset+rts*row)*tupSize] = tempSpace[row]; - } - } - } - free(tempSpace); - } -} - -//takes inverse rus -template void crtpinv (ring* y, hShort_t tupSize, hDim_t lts, hDim_t rts, - hDim_t p, hDim_t rustride, ring* ruinv) -{ - hDim_t tensorOffset; - if(p == 2) { - return; - } - else if(p == 3) { - hDim_t temp1 = rts*2; - ring ru1 = ruinv[rustride*tupSize]; - ring ru2 = ruinv[(rustride<<1)*tupSize]; - - for(hDim_t blockOffset = 0; blockOffset < lts; blockOffset++) { - hDim_t temp2 = blockOffset*temp1; - for(hDim_t modOffset = 0; modOffset < rts; modOffset++) { - tensorOffset = temp2 + modOffset; - ring y1, y2, shift; - y1 = y[tensorOffset*tupSize]; - y2 = y[(tensorOffset+rts)*tupSize]; - - shift = (ru2*y1) + (ru1*y2); - - y[tensorOffset*tupSize] += y2 - shift; - y[(tensorOffset+rts)*tupSize] = (ru1*y1) + (ru2*y2) - shift; - } - } - } - else if(p == 5) { - hDim_t temp1 = rts*4; - ring ru1 = ruinv[rustride*tupSize]; - ring ru2 = ruinv[(rustride<<1)*tupSize]; - ring ru3 = ruinv[(rustride*3)*tupSize]; - ring ru4 = ruinv[(rustride<<2)*tupSize]; - - for(hDim_t blockOffset = 0; blockOffset < lts; blockOffset++) { - hDim_t temp2 = blockOffset*temp1; - for(hDim_t modOffset = 0; modOffset < rts; modOffset++) { - tensorOffset = temp2 + modOffset; - ring y1, y2, y3, y4, shift; - y1 = y[tensorOffset*tupSize]; - y2 = y[(tensorOffset+rts)*tupSize]; - y3 = y[(tensorOffset+(rts<<1))*tupSize]; - y4 = y[(tensorOffset+3*rts)*tupSize]; - - shift = (ru4*y1) + (ru3*y2) + (ru2*y3) + (ru1*y4); - - y[tensorOffset*tupSize] += y2 + y3 + y4 - shift; - y[(tensorOffset+rts)*tupSize] = (ru1*y1) + (ru2*y2) + (ru3*y3) + (ru4*y4) - shift; - y[(tensorOffset+(rts<<1))*tupSize] = (ru2*y1) + (ru4*y2) + (ru1*y3) + (ru3*y4) - shift; - y[(tensorOffset+rts*3)*tupSize] = (ru3*y1) + (ru1*y2) + (ru4*y3) + (ru2*y4) - shift; - } - } - } - else if(p == 7) { - hDim_t temp1 = rts*6; - ring ru1 = ruinv[rustride*tupSize]; - ring ru2 = ruinv[(rustride<<1)*tupSize]; - ring ru3 = ruinv[(rustride*3)*tupSize]; - ring ru4 = ruinv[(rustride<<2)*tupSize]; - ring ru5 = ruinv[(rustride*5)*tupSize]; - ring ru6 = ruinv[(rustride*6)*tupSize]; - for(hDim_t blockOffset = 0; blockOffset < lts; blockOffset++) { - hDim_t temp2 = blockOffset*temp1; - for(hDim_t modOffset = 0; modOffset < rts; modOffset++) { - tensorOffset = temp2 + modOffset; - ring y1, y2, y3, y4, y5, y6, shift; - 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]; - - shift = (ru6*y1) + (ru5*y2) + (ru4*y3) + (ru3*y4) + (ru2*y5) + (ru1*y6); - - y[tensorOffset*tupSize] += y2 + y3 + y4 + y5 + y6 - shift; - y[(tensorOffset+rts)*tupSize] = (ru1*y1) + (ru2*y2) + (ru3*y3) + (ru4*y4) + (ru5*y5) + (ru6*y6) - shift; - y[(tensorOffset+(rts<<1))*tupSize] = (ru2*y1) + (ru4*y2) + (ru6*y3) + (ru1*y4) + (ru3*y5) + (ru5*y6) - shift; - y[(tensorOffset+rts*3)*tupSize] = (ru3*y1) + (ru6*y2) + (ru2*y3) + (ru5*y4) + (ru1*y5) + (ru4*y6) - shift; - y[(tensorOffset+(rts<<2))*tupSize] = (ru4*y1) + (ru1*y2) + (ru5*y3) + (ru2*y4) + (ru6*y5) + (ru3*y6) - shift; - y[(tensorOffset+rts*5)*tupSize] = (ru5*y1) + (ru3*y2) + (ru1*y3) + (ru6*y4) + (ru4*y5) + (ru2*y6) - shift; - } - } - } - else { - ring* tempSpace = (ring*)malloc((p-1)*sizeof(ring)); - hDim_t temp1 = rts*(p-1); - for(hDim_t blockOffset = 0; blockOffset < lts; blockOffset++) { - hDim_t temp2 = blockOffset*temp1; - for(hDim_t modOffset = 0; modOffset < rts; modOffset++) { - tensorOffset = temp2 + modOffset; - ring shift; - shift = 0; - for(hDim_t row = 0; row < p-1; row++) { - shift += (y[(tensorOffset+row*rts)*tupSize]*ruinv[(p-row-1)*rustride*tupSize]); - tempSpace[row] = 0; - for(hDim_t col = 0; col < p-1; col++) { - tempSpace[row] += (y[(tensorOffset+col*rts)*tupSize]*ruinv[((row*(col+1)) % p)*rustride*tupSize]); - } - } - - for(hDim_t row = 0; row < p-1; row++) { - y[(tensorOffset+rts*row)*tupSize] = tempSpace[row] - shift; - } - } - } - free(tempSpace); - } -} - -template void ppDFT (ring* y, hShort_t tupSize, hDim_t lts, hDim_t rts, - PrimeExponent pe, hDim_t rustride, ring* ru, ring* temp) -{ - hDim_t p = pe.prime; - hShort_t e = pe.exponent; - - if(e == 0) { - return; - } - - hDim_t primeRuStride = rustride*ipow(p,e-1); - - hShort_t i; - - hDim_t ltsScale = ipow(p,e-1); - hDim_t rtsScale = 1; - hDim_t twidRuStride = rustride; - for(i = 0; i < e; i++) { - hDim_t rtsDim = rts*rtsScale; - dftp (y, tupSize, lts*ltsScale, rtsDim, p, primeRuStride, ru, temp); - dftTwiddle (y, tupSize, lts, rtsDim, pe, ltsScale*p, twidRuStride, ru); - - ltsScale /= p; - rtsScale *= p; - twidRuStride *= p; - pe.exponent -= 1; - } -} - -template void ppDFTInv (ring* y, hShort_t tupSize, hDim_t lts, hDim_t rts, - PrimeExponent pe, hDim_t rustride, ring* ru, ring* temp) -{ - hDim_t p = pe.prime; - hShort_t e = pe.exponent; - - if(e == 0) { - return; - } - hDim_t primeRuStride = rustride*ipow(p,e-1); - - hShort_t i; - - hDim_t ltsScale = 1; - hDim_t rtsScale = ipow(p,e-1); - hDim_t twidRuStride = primeRuStride; - pe.exponent = 1; - for(i = 0; i < e; i++) { - hDim_t rtsDim = rts*rtsScale; - hDim_t ltsScaleP = ltsScale*p; - dftTwiddle (y, tupSize, lts, rtsDim, pe, ltsScaleP, twidRuStride, ru); - dftp (y, tupSize, lts*ltsScale, rtsDim, p, primeRuStride, ru, temp); - - ltsScale = ltsScaleP; - rtsScale /= p; - twidRuStride /= p; - pe.exponent += 1; - } -} - -template void ppcrt (ring* y, hShort_t tupSize, hDim_t lts, hDim_t rts, - PrimeExponent pe, ring* ru) -{ - hDim_t p = pe.prime; - hDim_t e = pe.exponent; - hDim_t mprime = ipow(p,e-1); - ring* temp = 0; - if(p >= DFTP_GENERIC_SIZE) { - temp = (ring*)malloc(p*sizeof(ring)); - } - - crtp (y, tupSize, lts*mprime, rts, p, mprime, ru); - crtTwiddle (y, tupSize, lts, rts, pe, ru); - pe.exponent -= 1; - ppDFT (y, tupSize, lts, rts*(p-1), pe, p, ru, temp); - pe.exponent += 1; - - if(p >= DFTP_GENERIC_SIZE) { - free(temp); - } -} - -template void ppcrtinv (ring* y, hShort_t tupSize, hDim_t lts, hDim_t rts, - PrimeExponent pe, ring* ru) -{ - hDim_t p = pe.prime; - hDim_t e = pe.exponent; - hDim_t mprime = ipow(p,e-1); - ring* temp = 0; - if(p >= DFTP_GENERIC_SIZE) { - temp = (ring*)malloc(p*sizeof(ring)); - } - - pe.exponent -= 1; - ppDFTInv (y, tupSize, lts, rts*(p-1), pe, p, ru, temp); - pe.exponent += 1; - crtTwiddle (y, tupSize, lts, rts, pe, ru); - crtpinv (y, tupSize, lts*mprime, rts, p, mprime, ru); - - if(p >= DFTP_GENERIC_SIZE) { - free(temp); - } -} - -extern "C" void tensorCRTRq (hShort_t tupSize, Zq* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, Zq** ru, hInt_t* qs) -{ - tensorFuserCRT (y, tupSize, ppcrt, totm, peArr, sizeOfPE, ru, qs); - canonicalizeZq(y,tupSize,totm,qs); -} - -//takes inverse rus -extern "C" void tensorCRTInvRq (hShort_t tupSize, Zq* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, - Zq** ruinv, Zq* mhatInv, hInt_t* qs) -{ - tensorFuserCRT (y, tupSize, ppcrtinv, totm, peArr, sizeOfPE, ruinv, qs); - for (hShort_t i = 0; i < tupSize; i++) { - Zq::q = qs[i]; - for (hDim_t j = 0; j < totm; j++) { - //careful here! I'm not setting the global q, so I can't rely on Zq multiplication - y[j*tupSize+i] = y[j*tupSize+i]*mhatInv[i]; - } - } - canonicalizeZq(y,tupSize,totm,qs); -} - -extern "C" void tensorCRTC (hShort_t tupSize, Complex* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, Complex** ru) -{ - tensorFuserCRT (y, tupSize, ppcrt, totm, peArr, sizeOfPE, ru, (hInt_t*)0); -} - -//takes inverse rus -extern "C" void tensorCRTInvC (hShort_t tupSize, Complex* y, hDim_t totm, PrimeExponent* peArr, - hShort_t sizeOfPE, Complex** ruinv, Complex* mhatInv) -{ - tensorFuserCRT (y, tupSize, ppcrtinv, totm, peArr, sizeOfPE, ruinv, (hInt_t*)0); - for (hShort_t i = 0; i < tupSize; i++) { - for (hDim_t j = 0; j < totm; j++) { - y[j*tupSize+i] *= mhatInv[i]; - } - } -} diff --git a/Crypto/Lol/Cyclotomic/Tensor/CTensor/g.cpp b/Crypto/Lol/Cyclotomic/Tensor/CTensor/g.cpp deleted file mode 100644 --- a/Crypto/Lol/Cyclotomic/Tensor/CTensor/g.cpp +++ /dev/null @@ -1,262 +0,0 @@ -#include "types.h" -#include "tensor.h" -#include "common.h" - -template void gPow (ring* y, hShort_t tupSize, hDim_t lts, hDim_t rts, hDim_t p) -{ - if (p == 2) {return;} - hDim_t tmp1 = rts*(p-1); - hDim_t tmp2 = tmp1 - rts; - hDim_t blockOffset, modOffset; - hDim_t i; - for (blockOffset = 0; blockOffset < lts; ++blockOffset) { - hDim_t tmp3 = blockOffset * tmp1; - for (modOffset = 0; modOffset < rts; ++modOffset) { - hDim_t tensorOffset = tmp3 + modOffset; - ring last = y[(tensorOffset + tmp2)*tupSize]; - for (i = p-2; i != 0; --i) { - hDim_t idx = tensorOffset + i * rts; - y[idx*tupSize] += (last - y[(idx-rts)*tupSize]); - } - y[tensorOffset*tupSize] += last; - } - } -} - -template void gDec (ring* y, hShort_t tupSize, hDim_t lts, hDim_t rts, hDim_t p) -{ - if (p == 2) {return;} - hDim_t tmp1 = rts*(p-1); - hDim_t blockOffset; - hDim_t modOffset; - hDim_t i; - - for (blockOffset = 0; blockOffset < lts; ++blockOffset) { - hDim_t tmp2 = blockOffset * tmp1; - for (modOffset = 0; modOffset < rts; ++modOffset) { - hDim_t tensorOffset = tmp2 + modOffset; - ring acc = y[tensorOffset*tupSize]; - for (i = p-2; i != 0; --i) { - hDim_t idx = tensorOffset + i * rts; - acc += y[idx*tupSize]; - y[idx*tupSize] -= y[(idx-rts)*tupSize]; - } - y[tensorOffset*tupSize] += acc; - } - } -} - -template void gInvPow (ring* y, hShort_t tupSize, hDim_t lts, hDim_t rts, hDim_t p) -{ - if (p == 2) {return;} - hDim_t tmp1 = rts * (p-1); - hDim_t blockOffset, modOffset; - hDim_t i; - - for (blockOffset = 0; blockOffset < lts; ++blockOffset) { - hDim_t tmp2 = blockOffset * tmp1; - for (modOffset = 0; modOffset < rts; ++modOffset) { - hDim_t tensorOffset = tmp2 + modOffset; - ring lelts; - lelts = 0; - for (i = 0; i < p-1; ++i) { - lelts += y[(tensorOffset + i*rts)*tupSize]; - } - ring relts; - relts = 0; - for (i = p-2; i >= 0; --i) { - hDim_t idx = tensorOffset + i*rts; - ring z = y[idx*tupSize]; - ring lmul, rmul; - lmul = p-1-i; - rmul = i+1; - y[idx*tupSize] = lmul * lelts - rmul * relts; - lelts -= z; - relts += z; - } - } - } -} - -template void gInvDec (ring* y, hShort_t tupSize, hDim_t lts, hDim_t rts, hDim_t p) -{ - if (p == 2) {return;} - hDim_t blockOffset; - hDim_t modOffset; - hDim_t i; - hDim_t tmp1 = rts*(p-1); - - for (blockOffset = 0; blockOffset < lts; ++blockOffset) { - hDim_t tmp2 = blockOffset*tmp1; - for (modOffset = 0; modOffset < rts; ++modOffset) { - hDim_t tensorOffset = tmp2 + modOffset; - ring lastOut; - lastOut = 0; - for (i=1; i < p; ++i) { - ring ri; - ri = i; - lastOut += (ri * y[(tensorOffset + (i-1)*rts)*tupSize]); - } - ring rp; - rp = p; - ring acc = lastOut; - for (i = p-2; i > 0; --i) { - hDim_t idx = tensorOffset + i*rts; - ring tmp = acc; - acc -= y[idx*tupSize]*rp; - y[idx*tupSize] = tmp; - } - y[tensorOffset*tupSize] = acc; - } - } -} - -extern "C" void tensorGPowR (hShort_t tupSize, hInt_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE) -{ - tensorFuserPrime (y, tupSize, gPow, totm, peArr, sizeOfPE, (hInt_t*)0); -} - -extern "C" void tensorGPowRq (hShort_t tupSize, Zq* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, hInt_t* qs) -{ - tensorFuserPrime (y, tupSize, gPow, totm, peArr, sizeOfPE, qs); - canonicalizeZq(y,tupSize,totm,qs); -} - -extern "C" void tensorGPowC (hShort_t tupSize, Complex* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE) -{ - tensorFuserPrime (y, tupSize, gPow, totm, peArr, sizeOfPE, (hInt_t*)0); -} - -extern "C" void tensorGDecR (hShort_t tupSize, hInt_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE) -{ - tensorFuserPrime (y, tupSize, gDec, totm, peArr, sizeOfPE, (hInt_t*)0); -} - -extern "C" void tensorGDecRq (hShort_t tupSize, Zq* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, hInt_t* qs) -{ - tensorFuserPrime (y, tupSize, gDec, totm, peArr, sizeOfPE, qs); - canonicalizeZq(y,tupSize,totm,qs); -} - -extern "C" void tensorGDecC (hShort_t tupSize, Complex* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE) -{ - tensorFuserPrime (y, tupSize, gDec, totm, peArr, sizeOfPE, (hInt_t*)0); -} - -hInt_t oddRad(PrimeExponent* peArr, hShort_t sizeOfPE) { - hInt_t oddrad; - oddrad = 1; - for(int i = 0; i < sizeOfPE; i++) { - hShort_t p = peArr[i].prime; - if (p != 2) { - oddrad *= peArr[i].prime; - } - } - return oddrad; -} - -extern "C" hShort_t tensorGInvPowR (hShort_t tupSize, hInt_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE) -{ - tensorFuserPrime (y, tupSize, gInvPow, totm, peArr, sizeOfPE, (hInt_t*)0); - - hInt_t oddrad = oddRad(peArr, sizeOfPE); - - for(int i = 0; i < tupSize*totm; i++) { - if (y[i] % oddrad) { - y[i] /= oddrad; - } - else { - return 0; - } - } - return 1; -} - -extern "C" hShort_t tensorGInvPowRq (hShort_t tupSize, Zq* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, hInt_t* qs) -{ - tensorFuserPrime (y, tupSize, gInvPow, totm, peArr, sizeOfPE, qs); - - hInt_t oddrad = oddRad(peArr, sizeOfPE); - - for(int i = 0; i < tupSize; i++) { - Zq::q = qs[i]; // global update - hInt_t ori = reciprocal(Zq::q, oddrad); - Zq oddradInv; - oddradInv = ori; - if (ori == 0) { - return 0; // error condition - } - for(hDim_t j = 0; j < totm; j++) { - y[j*tupSize+i] *= oddradInv; - } - } - - canonicalizeZq(y,tupSize,totm,qs); - return 1; -} - -extern "C" hShort_t tensorGInvPowC (hShort_t tupSize, Complex* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE) -{ - tensorFuserPrime (y, tupSize, gInvPow, totm, peArr, sizeOfPE, (hInt_t*)0); - - hInt_t oddrad = oddRad(peArr, sizeOfPE); - Complex oddradInv; - oddradInv = 1 / oddrad; - for(int i = 0; i < tupSize*totm; i++) { - y[i] *= oddradInv; - } - return 1; -} - -extern "C" hShort_t tensorGInvDecR (hShort_t tupSize, hInt_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE) -{ - tensorFuserPrime (y, tupSize, gInvDec, totm, peArr, sizeOfPE, (hInt_t*)0); - - hInt_t oddrad = oddRad(peArr, sizeOfPE); - - for(int i = 0; i < tupSize*totm; i++) { - if (y[i] % oddrad) { - y[i] /= oddrad; - } - else { - return 0; - } - } - return 1; -} - -extern "C" hShort_t tensorGInvDecRq (hShort_t tupSize, Zq* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, hInt_t* qs) -{ - tensorFuserPrime (y, tupSize, gInvDec, totm, peArr, sizeOfPE, qs); - - hInt_t oddrad = oddRad(peArr, sizeOfPE); - - for(int i = 0; i < tupSize; i++) { - Zq::q = qs[i]; // global update - hInt_t ori = reciprocal(Zq::q, oddrad); - Zq oddradInv; - oddradInv = ori; - if (ori == 0) { - return 0; // error condition - } - for(hDim_t j = 0; j < totm; j++) { - y[j*tupSize+i] *= oddradInv; - } - } - - canonicalizeZq(y,tupSize,totm,qs); - return 1; -} - -extern "C" hShort_t tensorGInvDecC (hShort_t tupSize, Complex* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE) -{ - tensorFuserPrime (y, tupSize, gInvDec, totm, peArr, sizeOfPE, (hInt_t*)0); - - hInt_t oddrad = oddRad(peArr, sizeOfPE); - Complex oddradInv; - oddradInv = 1 / oddrad; - for(int i = 0; i < tupSize*totm; i++) { - y[i] *= oddradInv; - } - return 1; -} diff --git a/Crypto/Lol/Cyclotomic/Tensor/CTensor/l.cpp b/Crypto/Lol/Cyclotomic/Tensor/CTensor/l.cpp deleted file mode 100644 --- a/Crypto/Lol/Cyclotomic/Tensor/CTensor/l.cpp +++ /dev/null @@ -1,87 +0,0 @@ -#include "types.h" -#include "tensor.h" - -template void lp (ring* y, hShort_t tupSize, hDim_t lts, hDim_t rts, hDim_t p) -{ - hDim_t blockOffset; - hDim_t modOffset; - int i; - - if(p == 2) {return;} - - hDim_t tmp1 = rts*(p-1); - for (blockOffset = 0; blockOffset < lts; ++blockOffset) { - hDim_t tmp2 = blockOffset*tmp1; - for (modOffset = 0; modOffset < rts; ++modOffset) { - hDim_t idx = tmp2 + modOffset + rts; - for (i = 1; i < p-1; ++i) { - y[idx*tupSize] += y[(idx-rts)*tupSize]; - idx += rts; - } - } - } -} - -template void lpInv (ring* y, hShort_t tupSize, hDim_t lts, hDim_t rts, hDim_t p) -{ - hDim_t blockOffset; - hDim_t modOffset; - int i; - - if(p == 2) {return;} - - hDim_t tmp1 = rts*(p-1); - for (blockOffset = 0; blockOffset < lts; ++blockOffset) { - hDim_t tmp2 = blockOffset*tmp1; - for (modOffset = 0; modOffset < rts; ++ modOffset) { - hDim_t tensorOffset = tmp2 + modOffset; - hDim_t idx = tensorOffset + (p-2) * rts; - for (i = p-2; i != 0; --i) { - y[idx*tupSize] -= y[(idx-rts)*tupSize] ; - idx -= rts; - } - } - } -} - -extern "C" void tensorLRq (hShort_t tupSize, Zq* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, hInt_t* qs) -{ - tensorFuserPrime (y, tupSize, lp, totm, peArr, sizeOfPE, qs); - canonicalizeZq(y,tupSize,totm,qs); -} - -extern "C" void tensorLR (hShort_t tupSize, hInt_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE) -{ - tensorFuserPrime (y, tupSize, lp, totm, peArr, sizeOfPE, (hInt_t*)0); -} - -extern "C" void tensorLDouble (hShort_t tupSize, double* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE) -{ - tensorFuserPrime (y, tupSize, lp, totm, peArr, sizeOfPE, (hInt_t*)0); -} - -extern "C" void tensorLC (hShort_t tupSize, Complex* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE) -{ - tensorFuserPrime (y, tupSize, lp, totm, peArr, sizeOfPE, (hInt_t*)0); -} - -extern "C" void tensorLInvRq (hShort_t tupSize, Zq* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, hInt_t* qs) -{ - tensorFuserPrime (y, tupSize, lpInv, totm, peArr, sizeOfPE, qs); - canonicalizeZq(y,tupSize,totm,qs); -} - -extern "C" void tensorLInvR (hShort_t tupSize, hInt_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE) -{ - tensorFuserPrime (y, tupSize, lpInv, totm, peArr, sizeOfPE, (hInt_t*)0); -} - -extern "C" void tensorLInvDouble (hShort_t tupSize, double* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE) -{ - tensorFuserPrime (y, tupSize, lpInv, totm, peArr, sizeOfPE, (hInt_t*)0); -} - -extern "C" void tensorLInvC (hShort_t tupSize, Complex* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE) -{ - tensorFuserPrime (y, tupSize, lpInv, totm, peArr, sizeOfPE, (hInt_t*)0); -} diff --git a/Crypto/Lol/Cyclotomic/Tensor/CTensor/mul.cpp b/Crypto/Lol/Cyclotomic/Tensor/CTensor/mul.cpp deleted file mode 100644 --- a/Crypto/Lol/Cyclotomic/Tensor/CTensor/mul.cpp +++ /dev/null @@ -1,24 +0,0 @@ -#include "types.h" - -template void zipWithStar (ring* a, ring* b, hShort_t tupSize, hDim_t totm, hInt_t* qs) -{ - for(int tupIdx = 0; tupIdx < tupSize; tupIdx++) { - if(qs) { - Zq::q = qs[tupIdx]; - } - for(int i = 0; i < totm; i++) { - a[i*tupSize+tupIdx] *= b[i*tupSize+tupIdx]; - } - } -} - -//a = zipWith (*) a b -extern "C" void mulRq (hShort_t tupSize, Zq* a, Zq* b, hDim_t totm, hInt_t* qs) -{ - zipWithStar(a, b, tupSize, totm, qs); -} - -extern "C" void mulC (hShort_t tupSize, Complex* a, Complex* b, hDim_t totm) -{ - zipWithStar(a, b, tupSize, totm, (hInt_t*)0); -} diff --git a/Crypto/Lol/Cyclotomic/Tensor/CTensor/norm.cpp b/Crypto/Lol/Cyclotomic/Tensor/CTensor/norm.cpp deleted file mode 100644 --- a/Crypto/Lol/Cyclotomic/Tensor/CTensor/norm.cpp +++ /dev/null @@ -1,69 +0,0 @@ -#include "types.h" -#include "tensor.h" - -template void pNormSq (ring* y, hShort_t tupSize, hDim_t lts, hDim_t rts, hDim_t p) -{ - hDim_t blockOffset; - hDim_t modOffset; - hDim_t i; - - if(p==2) {return;} - - hDim_t tmp1 = rts*(p-1); - for (blockOffset = 0; blockOffset < lts; ++blockOffset) { - hDim_t tmp2 = blockOffset*tmp1; - for (modOffset = 0; modOffset < rts; ++modOffset) { - hDim_t tensorOffset = tmp2 + modOffset; - ring sum = 0; - for (i = 0; i < p-1; ++i) { - sum += y[(tensorOffset + i*rts)*tupSize]; - } - for (i = 0; i < p-1; ++i) { - y[(tensorOffset + i*rts)*tupSize] += sum; - } - } - } -} - -extern "C" void tensorNormSqR (hShort_t tupSize, hInt_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE) -{ - hInt_t* tempSpace = (hInt_t*)malloc(totm*tupSize*sizeof(hInt_t)); - for(hDim_t i = 0; i < totm*tupSize; i++) { - tempSpace[i]=y[i]; - } - - tensorFuserPrime(y, tupSize, pNormSq, totm, peArr, sizeOfPE, (hInt_t*)0); - - //do dot product and return in index 0 - for(int tupIdx = 0; tupIdx < tupSize; tupIdx++) { - hInt_t dotprod = 0; - for(hDim_t i = 0; i < totm; i++) { - dotprod += (tempSpace[i*tupSize+tupIdx]*y[i*tupSize+tupIdx]); - } - - y[tupIdx] = dotprod; - } - - free(tempSpace); -} - -extern "C" void tensorNormSqD (hShort_t tupSize, double* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE) -{ - double* tempSpace = (double*)malloc(totm*tupSize*sizeof(double)); - for(hDim_t i = 0; i < totm*tupSize; i++) { - tempSpace[i]=y[i]; - } - tensorFuserPrime(y, tupSize, pNormSq, totm, peArr, sizeOfPE, (hInt_t*)0); - - //do dot product and return in index 0 - for(int tupIdx = 0; tupIdx < tupSize; tupIdx++) { - double dotprod = 0; - for(hDim_t i = 0; i < totm; i++) { - dotprod += (tempSpace[i*tupSize+tupIdx]*y[i*tupSize+tupIdx]); - } - - y[tupIdx] = dotprod; - } - - free(tempSpace); -} diff --git a/Crypto/Lol/Cyclotomic/Tensor/CTensor/random.cpp b/Crypto/Lol/Cyclotomic/Tensor/CTensor/random.cpp deleted file mode 100644 --- a/Crypto/Lol/Cyclotomic/Tensor/CTensor/random.cpp +++ /dev/null @@ -1,53 +0,0 @@ -#include "types.h" -#include "tensor.h" -#include "common.h" -#include - -// I had been negating the ru-idx, but this was causing a *negative* mod, resulting in a hard-to-find bug -// current behavior (taking rus, rather than ruInv) matches RT -void primeD (double *y, hShort_t tupSize, hDim_t lts, hDim_t rts, hDim_t p, hDim_t rustride, Complex* ru) -{ - 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 * ru[((row*col) % p)*rustride*tupSize].real * y[(tensorOffset+rts*(col-1))*tupSize]; - } - for(col = (p>>1)+1; col <= p-1; col++) { - acc += 2 * ru[((row*col) % p)*rustride*tupSize].imag * y[(tensorOffset+rts*(col-1))*tupSize]; - } - tempSpace[row] = acc/sqrt(2); - } - - for(row = 0; row < p-1; row++) { - y[(tensorOffset+rts*row)*tupSize] = tempSpace[row]; - } - } - } - free(tempSpace); -} - -void ppD (double *y, hShort_t tupSize, hDim_t lts, hDim_t rts, PrimeExponent pe, Complex *ru) -{ - hDim_t p = pe.prime; - hDim_t e = pe.exponent; - hDim_t mprime = ipow(p,e-1); - primeD (y, tupSize, lts*mprime, rts, p, mprime, ru); -} - -//the contents of y will be destroyed, but should be initialized in Haskell-land to independent Guassians over the reals -extern "C" void tensorGaussianDec (hShort_t tupSize, double *y, hDim_t totm, PrimeExponent *peArr, hShort_t sizeOfPE, Complex** ru) -{ - tensorFuserCRT (y, tupSize, ppD, totm, peArr, sizeOfPE, ru, (hInt_t*)0); -} diff --git a/Crypto/Lol/Cyclotomic/Tensor/CTensor/tensor.h b/Crypto/Lol/Cyclotomic/Tensor/CTensor/tensor.h deleted file mode 100644 --- a/Crypto/Lol/Cyclotomic/Tensor/CTensor/tensor.h +++ /dev/null @@ -1,56 +0,0 @@ -#ifndef TENSOR_CPP_ -#define TENSOR_CPP_ - -#include "types.h" -#include "common.h" -#ifdef __cplusplus -template -using primeFunc = void (*) (ring*, hShort_t, hDim_t, hDim_t, hDim_t); - -template -using primeCRTFunc = void (*) (ringy*, hShort_t, hDim_t, hDim_t, PrimeExponent, ringru*); - -//for square transforms -template void tensorFuserPrime (ring* y, hShort_t tupSize, primeFunc f, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, hInt_t* qs) -{ - hDim_t lts = totm; - hDim_t rts = 1; - hShort_t i; - - for (i = 0; i < sizeOfPE; ++i) { - PrimeExponent pe = peArr[i]; - hDim_t ipow_pe = ipow(pe.prime, (pe.exponent-1)); - hDim_t dim = (pe.prime-1) * ipow_pe; // the totient of pe - lts /= dim; - for(int tupIdx = 0; tupIdx < tupSize; tupIdx++) { - if(qs) { - Zq::q = qs[tupIdx]; // global update - } - (*f) (y+tupIdx, tupSize, lts*ipow_pe, rts, pe.prime); - } - rts *= dim; - } -} - -template void tensorFuserCRT (ringy* y, hShort_t tupSize, primeCRTFunc f, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, ringru** ru, hInt_t* qs) -{ - hDim_t lts = totm; - hDim_t rts = 1; - hShort_t i; - - for (i = 0; i < sizeOfPE; ++i) { - PrimeExponent pe = peArr[i]; - hDim_t ipow_pe = ipow(pe.prime, (pe.exponent-1)); - hDim_t dim = (pe.prime-1) * ipow_pe; // the totient of pe - lts /= dim; - for(int tupIdx = 0; tupIdx < tupSize; tupIdx++) { - if(qs) { - Zq::q = qs[tupIdx]; // global update - } - (*f) (y+tupIdx, tupSize, lts, rts, pe, ru[i]+tupIdx); - } - rts *= dim; - } -} -#endif /* __cplusplus */ -#endif /* TENSOR_CPP_ */ diff --git a/Crypto/Lol/Cyclotomic/Tensor/CTensor/types.h b/Crypto/Lol/Cyclotomic/Tensor/CTensor/types.h deleted file mode 100644 --- a/Crypto/Lol/Cyclotomic/Tensor/CTensor/types.h +++ /dev/null @@ -1,160 +0,0 @@ - -#ifndef TENSORTYPES_H_ -#define TENSORTYPES_H_ - -#include -#include -#include - -typedef int64_t hInt_t ; -typedef int32_t hDim_t ; -typedef int16_t hShort_t ; -typedef int8_t hByte_t ; - -typedef struct -{ - hShort_t prime; - hShort_t exponent; -} PrimeExponent; - - -hInt_t reciprocal (hInt_t a, hInt_t b); - -#define ASSERT(EXP) { \ - if (!(EXP)) { \ - fprintf (stderr, "Assertion in file '%s' line %d : " #EXP " is false\n", __FILE__, __LINE__); \ - exit(-1); \ - } \ -} - -//http://stackoverflow.com/questions/37572628 -#ifdef __cplusplus -//http://stackoverflow.com/a/4421719 -class Zq -{ -public: - hInt_t x; - - static hInt_t q; // declared here, defined in generalfuncs.cpp - - Zq& operator=(const hInt_t& c) - { - this->x = c % q; - return *this; - } - Zq& operator+=(const Zq& b) - { - this->x += b.x; - this->x %= q; - return *this; - } - Zq& operator-=(const Zq& b) - { - this->x -= b.x; - this->x %= q; - return *this; - } - Zq& operator*=(const Zq& b) - { - this->x *= b.x; - this->x %= q; - return *this; - } - Zq& operator/=(const Zq& b) - { - Zq binv; - binv = reciprocal(q,b.x); - ASSERT (binv.x); // binv == 0 indicates that x is not invertible mod q - *this *= binv; - return *this; - } -}; -inline Zq operator+(Zq a, const Zq& b) -{ - a += b; - return a; -} -inline Zq operator-(Zq a, const Zq& b) -{ - a -= b; - return a; -} -inline Zq operator*(Zq a, const Zq& b) -{ - a *= b; - return a; -} -inline Zq operator/(Zq a, const Zq& b) -{ - a /= b; - return a; -} - -void canonicalizeZq (Zq* y, hShort_t tupSize, hDim_t totm, hInt_t* qs); - -class Complex -{ -public: - double real; - double imag; - - Complex& operator=(const hInt_t& c) - { - this->real = c; - this->imag = 0; - return *this; - } - Complex& operator+=(const Complex& b) - { - this->real = this->real+b.real; - this->imag = this->imag+b.imag; - return *this; - } - Complex& operator-=(const Complex& b) - { - this->real = this->real-b.real; - this->imag = this->imag-b.imag; - return *this; - } - Complex& operator*=(const Complex& b) - { - double a = this->real; - this->real = (a*b.real)-(this->imag*b.imag); - this->imag = (a*b.imag)+(this->imag*b.real); - return *this; - } - Complex& operator/=(const Complex& b) - { - Complex bconj; - bconj.real = b.real; - bconj.imag = -b.imag; - *this *= bconj; - double den = (b.real*b.real+b.imag*b.imag); - this->real /= den; - this->imag /= den; - return *this; - } -}; -inline Complex operator+(Complex a, const Complex& b) -{ - a += b; - return a; -} -inline Complex operator-(Complex a, const Complex& b) -{ - a -= b; - return a; -} -inline Complex operator*(Complex a, const Complex& b) -{ - a *= b; - return a; -} -inline Complex operator/(Complex a, const Complex& b) -{ - a /= b; - return a; -} - -#endif /* __cplusplus */ -#endif /* TENSORTYPES_H_ */ diff --git a/Crypto/Lol/Cyclotomic/Tensor/CTensor/zq.cpp b/Crypto/Lol/Cyclotomic/Tensor/CTensor/zq.cpp deleted file mode 100644 --- a/Crypto/Lol/Cyclotomic/Tensor/CTensor/zq.cpp +++ /dev/null @@ -1,39 +0,0 @@ -#include "types.h" -#include "common.h" - -// a is the field size. we are looking for reciprocal of b -hInt_t reciprocal (hInt_t a, hInt_t b) -{ - hInt_t fieldSize = a; - - hInt_t y = 1; - hInt_t lasty = 0; - while (b != 0) { - hInt_t quotient = a / b; - hInt_t tmp = a % b; - a = b; - b = tmp; - tmp = y; - y = lasty - quotient*y; - lasty = tmp; - } - // if a!=1, then b is not invertible mod a - if(a!=1) { - return 0; - } - - // this actually returns EITHER the reciprocal OR reciprocal + fieldSize - hInt_t res = lasty + fieldSize; - return res; -} - -void canonicalizeZq (Zq* y, hShort_t tupSize, hDim_t totm, hInt_t* qs) { - for(int tupIdx = 0; tupIdx)) -import Control.Arrow hiding (arr) -import Control.DeepSeq (NFData (rnf)) -import Control.Monad.Except (throwError) -import Control.Monad.Random -import Data.Coerce -import Data.Constraint hiding ((***)) -import Data.Foldable as F -import Data.Maybe -import Data.Sequence as S (fromList) -import Data.Traversable as T -import Data.Vector as V hiding (force, (++)) -import Data.Vector.Unboxed as U hiding (force, (++)) - -import 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 (Fact m, Reflects q Int64) => Protoable (RT m (ZqBasic q Int64)) where - type ProtoType (RT m (ZqBasic q Int64)) = Rq - - toProto (RT (Arr xs)) = - let m = fromIntegral $ proxy valueFact (Proxy::Proxy m) - q = proxy value (Proxy::Proxy q) :: Int64 - in Rq m (fromIntegral q) $ S.fromList $ RT.toList $ RT.map lift xs - toProto x@(ZV _) = toProto $ toRT x - - fromProto (Rq m' q' xs) = - let m = proxy valueFact (Proxy::Proxy m) :: Int - q = proxy value (Proxy::Proxy q) :: Int64 - n = proxy totientFact (Proxy::Proxy m) - xs' = RT.fromList (Z:.n) $ LP.map reduce $ F.toList xs - len = F.length xs - in if m == fromIntegral m' && len == n && fromIntegral q == q' - then return $ RT $ Arr xs' - else throwError $ - "An error occurred while reading the proto type for RT.\n\ - \Expected m=" ++ show m ++ ", got " ++ show m' ++ "\n\ - \Expected n=" ++ show n ++ ", got " ++ show len ++ "\n\ - \Expected q=" ++ show q ++ ", got " ++ show q' ++ "." - -instance (Fact m, Reflects q Double) => Protoable (RT m (RRq q Double)) where - type ProtoType (RT m (RRq q Double)) = Kq - - toProto (RT (Arr xs)) = - let m = fromIntegral $ proxy valueFact (Proxy::Proxy m) - q = round (proxy value (Proxy::Proxy q) :: Double) - in Kq m q $ S.fromList $ RT.toList $ RT.map lift xs - toProto x@(ZV _) = toProto $ toRT x - - fromProto (Kq m' q' xs) = - let m = proxy valueFact (Proxy::Proxy m) :: Int - q = round (proxy value (Proxy::Proxy q) :: Double) - n = proxy totientFact (Proxy::Proxy m) - xs' = RT.fromList (Z:.n) $ LP.map reduce $ F.toList xs - len = F.length xs - in if m == fromIntegral m' && len == n && q == q' - then return $ RT $ Arr xs' - else throwError $ - "An error occurred while reading the proto type for RT.\n\ - \Expected m=" ++ show m ++ ", got " ++ show m' ++ "\n\ - \Expected n=" ++ show n ++ ", got " ++ show len ++ "\n\ - \Expected q=" ++ show q ++ ", got " ++ show q' ++ "." - -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 - 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 - - 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) - - 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 zipWithT #-} - {-# 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 deleted file mode 100644 --- a/Crypto/Lol/Cyclotomic/Tensor/RepaTensor/CRT.hs +++ /dev/null @@ -1,222 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE 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.RTCommon as RT -import Crypto.Lol.Prelude as LP - -import Control.Applicative -import Data.Coerce -import Data.Singletons.Prelude - --- | Embeds a scalar into the CRT basis (when it exists). -scalarCRT' :: forall mon m r . (Fact m, CRTrans mon r, Unbox r) - => mon (r -> Arr m r) -{-# INLINABLE scalarCRT' #-} -scalarCRT' - = let n = proxy totientFact (Proxy::Proxy m) - sz = Z :. n - in pure $ Arr . force . fromFunction sz . const - --- | Multiply by @g_m@ in the CRT basis (when it exists). -mulGCRT' :: (Fact m, CRTrans mon r, Unbox r) - => mon (Arr m r -> Arr m r) -{-# INLINABLE mulGCRT' #-} -mulGCRT' = (coerce (\x -> force . RT.zipWith (*) x) `asTypeOf` asTypeOf) <$> gCRT - --- | Divide by @g@ in the CRT basis (when it exists). -divGCRT' :: (Fact m, CRTrans mon r, Unbox r) => mon (Arr m r -> Arr m r) -{-# INLINABLE divGCRT' #-} -divGCRT' = (coerce (\x -> force . RT.zipWith (*) x) `asTypeOf` asTypeOf) <$> gInvCRT - -wrapVector :: forall mon m r . (Monad mon, Fact m, Ring r, Unbox r) - => TaggedT m mon (Kron r) -> mon (Arr m r) -wrapVector v = do - vmat <- proxyT v (Proxy::Proxy m) - let n = proxy totientFact (Proxy::Proxy m) - return $ coerce $ force $ RT.fromFunction (Z:.n) - (\(Z:.i) -> indexK vmat i 0) - -gCRT, gInvCRT :: (Fact m, CRTrans mon r, Unbox r) => mon (Arr m r) -{-# INLINABLE gCRT #-} -{-# INLINABLE gInvCRT #-} - --- | The coefficient vector of @g@ in the CRT basis (when it exists). -gCRT = wrapVector gCRTK --- | The coefficient vector of @g^{ -1 }@ in the CRT basis (when it exists). -gInvCRT = wrapVector gInvCRTK - -fCRT, fCRTInv :: - forall mon m r . (Fact m, CRTrans mon r, Unbox r, Elt r) - => mon (Arr m r -> Arr m r) - -{-# INLINABLE fCRT #-} -{-# INLINABLE fCRTInv #-} - --- | The Chinese Remainder Transform. --- Exists if and only if CRT exists for all prime powers. -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 - (_, mhatInv) :: (CRTInfo r) <- proxyT crtInfo (Proxy :: Proxy m) - let totm = proxy totientFact (Proxy :: Proxy m) - divMhat = trans totm $ RT.map (*mhatInv) - evalM $ (divMhat .*) <$> fTensor ppCRTInv' - -ppDFT, ppDFTInv', ppCRT, ppCRTInv' :: - forall mon pp r . (PPow pp, CRTrans mon r, Unbox r, Elt r) - => TaggedT pp mon (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) => 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 mon p r . (Prime p, CRTrans mon r, Unbox r, Elt r) - => TaggedT p mon (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, _) <- crtInfo - 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, _) <- crtInfo - 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, _) <- crtInfo - 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, _) <- crtInfo - 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 mon pp r . (PPow pp, CRTrans mon r, Unbox r) - => Bool -> TaggedT pp mon (Trans r) - -{-# INLINABLE ppTwid #-} -{-# INLINABLE ppTwidHat #-} - -ppTwid inv = - let pp@(p,e) = proxy ppPPow (Proxy :: Proxy pp) - ppval = valuePP pp - in do - (omegaPPPow, _) <- crtInfo - 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, _) <- crtInfo - 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 deleted file mode 100644 --- a/Crypto/Lol/Cyclotomic/Tensor/RepaTensor/Dec.hs +++ /dev/null @@ -1,74 +0,0 @@ -{-# 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.Prelude - -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 . (Prime p, Transcendental r, Unbox r, Elt r) - => Tagged p (Trans r) -pE = let pval = proxy valuePrime (Proxy::Proxy p) - in tag $ if pval==2 then Id 1 - 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 . (Prime p, Ring r, Unbox r, Elt r) => Tagged p (Trans r) -pGramDec = - let pval = proxy valuePrime (Proxy::Proxy p) - in tag $ if pval==2 then Id 1 - 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 deleted file mode 100644 --- a/Crypto/Lol/Cyclotomic/Tensor/RepaTensor/Extension.hs +++ /dev/null @@ -1,200 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE 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.CRTrans -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.Prelude as LP - -import Crypto.Lol.Types.FiniteField -import Crypto.Lol.Types.ZmStar - -import Control.Applicative -import Control.Arrow (first, second) - -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 mon m m' r . - (m `Divides` m', CRTrans mon r, Unbox r, Elt r) - => mon (Arr m' r -> Arr m r) -twaceCRT' = do - g' :: Arr m' r <- gCRT - gInv <- gInvCRT - embed :: Arr m r -> Arr m' r <- embedCRT' - (_, m'hatinv) <- proxyT crtInfo (Proxy::Proxy m') - let hatRatioInv = m'hatinv * fromIntegral (proxy valueHatFact (Proxy::Proxy m)) - -- tweak = mhat * g' / (m'hat * g) - tweak = (coerce $ \x -> force . RT.map (* hatRatioInv) . RT.zipWith (*) x) (embed gInv) g' :: Arr m' r - indices = proxy extIndicesCRT (Proxy::Proxy '(m, m')) - return $ - -- 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 mon m m' r . (m `Divides` m', CRTrans mon r, Unbox r) - => mon (Arr m r -> Arr m' r) -embedCRT' = do - -- first check existence of CRT transform of index m' - _ <- proxyT crtInfo (Proxy::Proxy m') :: mon (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.Kron (GF fp d) - = fromMaybe (error "internal error: crtSetDec': twCRTs") $ proxyT T.twCRTs m'p - zmsToIdx = proxy T.zmsToIndexFact m'p - elt j i = T.indexK 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 (second (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 deleted file mode 100644 --- a/Crypto/Lol/Cyclotomic/Tensor/RepaTensor/GL.hs +++ /dev/null @@ -1,135 +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.Prelude as LP -import Data.Coerce - -fLInv, fGPow :: (Fact m, Additive r, Unbox r) - => Arr m r -> Arr m r -fL, 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) - => (forall p . Prime 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 . Prime p - => (forall rep . Source rep r => Int -> Array rep DIM2 r -> Array D DIM2 r) - -> Tagged p (Trans r) -pWrap f = let pval = proxy valuePrime (Proxy::Proxy p) - -- special case: return identity function for p=2 - in return $ if pval > 2 - then trans (pval-1) $ f pval - else Id 1 -{-# INLINABLE pWrap #-} - - -pLInv, pGPow :: (Prime p, Additive r) => Tagged p (Trans r) -pL, pGDec :: (Prime p, Additive r, Elt r, Unbox r) => Tagged p (Trans r) -pGInvPow', pGInvDec' :: (Prime 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 deleted file mode 100644 --- a/Crypto/Lol/Cyclotomic/Tensor/RepaTensor/RTCommon.hs +++ /dev/null @@ -1,274 +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.Prelude 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 Data.Vector.Unboxed as U (replicate, replicateM) -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, 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 fmap (Arr . fromUnboxed (Z:.n)) . U.replicateM n -{-# INLINABLE replM #-} - -instance (Fact m, Additive r, Unbox 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) => 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 (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) - => (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 . (Prime 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 = fmap (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) - => 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) => 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) - => 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 --- a/Crypto/Lol/Cyclotomic/UCyc.hs +++ b/Crypto/Lol/Cyclotomic/UCyc.hs @@ -1,3 +1,30 @@ +{-| +Module : Crypto.Lol.Cyclotomic.UCyc +Description : A low-level implementation of cyclotomic rings. +Copyright : (c) Eric Crockett, 2011-2017 + Chris Peikert, 2011-2017 +License : GPL-2 +Maintainer : ecrockett0@email.com +Stability : experimental +Portability : POSIX + + \( \def\Z{\mathbb{Z}} \) + \( \def\F{\mathbb{F}} \) + \( \def\Q{\mathbb{Q}} \) + \( \def\O{\mathcal{O}} \) + +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. +-} + {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} @@ -5,7 +32,6 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RebindableSyntax #-} @@ -14,22 +40,6 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} --- | \( \def\Z{\mathbb{Z}} \) --- \( \def\F{\mathbb{F}} \) --- \( \def\Q{\mathbb{Q}} \) --- \( \def\O{\mathcal{O}} \) --- --- 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 @@ -68,12 +78,11 @@ import Control.Applicative as A import Control.Arrow import Control.DeepSeq -import Control.Monad.Identity -import Control.Monad.Random +import Control.Monad.Identity (Identity(..)) +import Control.Monad.Random hiding (lift) import Data.Foldable as F import Data.Maybe import Data.Traversable -import Test.QuickCheck import Crypto.Lol.Types.Proto @@ -679,16 +688,6 @@ 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 - --- no Arbitrary for C or E due to invariant - instance (Tensor t, Fact m, NFElt r, TElt t r, TElt t (CRTExt r)) => NFData (UCyc t m rep r) where rnf (Pow x) = rnf x \\ witness entailNFDataT x @@ -700,3 +699,16 @@ type ProtoType (UCyc t m D r) = ProtoType (t m r) toProto (Dec t) = toProto t fromProto t = Dec <$> fromProto t + +instance (Show r, Fact m, TElt t r, Tensor t) => Show (UCyc t m P r) where + show (Pow x) = "UPow " ++ show x \\ witness entailShowT x + +instance (Show r, Fact m, TElt t r, Tensor t) => Show (UCyc t m D r) where + show (Dec x) = "UDec " ++ show x \\ witness entailShowT x + +instance (Show r, Fact m, TElt t r, Tensor t) => Show (UCyc t m C r) where + show (CRTC _ x) = "UCRTC " ++ show x \\ witness entailShowT x + +instance (Show (CRTExt r), Fact m, TElt t (CRTExt r), Tensor t) + => Show (UCyc t m E r) where + show (CRTE _ x) = "UCRTE " ++ show x \\ witness entailShowT x diff --git a/Crypto/Lol/Factored.hs b/Crypto/Lol/Factored.hs --- a/Crypto/Lol/Factored.hs +++ b/Crypto/Lol/Factored.hs @@ -1,12 +1,25 @@ -{-# LANGUAGE DataKinds, TemplateHaskell, TupleSections #-} +{-| +Module : Crypto.Lol.Factored +Description : Type-level factored naturals. +Copyright : (c) Eric Crockett, 2011-2017 + Chris Peikert, 2011-2017 +License : GPL-2 +Maintainer : ecrockett0@email.com +Stability : experimental +Portability : POSIX --- | \( \def\lcm{\text{lcm}} \) --- --- 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. + \( \def\lcm{\text{lcm}} \) + +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. +-} + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} module Crypto.Lol.Factored ( module Crypto.Lol.FactoredDefs diff --git a/Crypto/Lol/FactoredDefs.hs b/Crypto/Lol/FactoredDefs.hs --- a/Crypto/Lol/FactoredDefs.hs +++ b/Crypto/Lol/FactoredDefs.hs @@ -1,15 +1,33 @@ -{-# LANGUAGE ConstraintKinds, CPP, DataKinds, ExplicitNamespaces, GADTs, - InstanceSigs, KindSignatures, PolyKinds, ScopedTypeVariables, - RankNTypes, TemplateHaskell, TypeFamilies, TypeOperators, - UndecidableInstances #-} -{-# OPTIONS_GHC -fno-warn-unused-binds #-} -#if __GLASGOW_HASKELL__ >= 800 -{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} -#endif +{-| +Module : Crypto.Lol.FactoredDefs +Description : Internal module. +Copyright : (c) Eric Crockett, 2011-2017 + Chris Peikert, 2011-2017 +License : GPL-2 +Maintainer : ecrockett0@email.com +Stability : experimental +Portability : POSIX --- | This sub-module exists only because we can't define and use --- template Haskell splices in the same module. +This sub-module exists only because we can't define and use +template Haskell splices in the same module. +-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_GHC -fno-warn-unused-binds #-} +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} + module Crypto.Lol.FactoredDefs ( -- * Factored natural numbers @@ -418,7 +436,7 @@ -- | The odd radical of a prime power. oddRadicalPP (2,_) = 1 oddRadicalPP (p,_) = p - +-- | Value of a 'PrimeBin'. valueP :: PrimeBin -> Int valueP (P p) = binToInt p @@ -471,6 +489,7 @@ fDec :: Int -> DecQ fDec n = tySynD (mkName $ 'F' : show n) [] $ fType n +-- | Converts input to its data-level 'Factored' representation. intToFact :: Int -> Factored intToFact m = let fcts = factorize m diff --git a/Crypto/Lol/Gadget.hs b/Crypto/Lol/Gadget.hs --- a/Crypto/Lol/Gadget.hs +++ b/Crypto/Lol/Gadget.hs @@ -1,3 +1,16 @@ +{-| +Module : Crypto.Lol.Gadget +Description : Interfaces for "gadgets," decomposition, and error correction. +Copyright : (c) Eric Crockett, 2011-2017 + Chris Peikert, 2011-2017 +License : GPL-2 +Maintainer : ecrockett0@email.com +Stability : experimental +Portability : POSIX + +Interfaces for "gadgets," decomposition, and error correction. +-} + {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} @@ -9,8 +22,6 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} - --- | Interfaces for "gadgets," decomposition, and error correction. module Crypto.Lol.Gadget ( Gadget(..), Decompose(..), Correct(..) diff --git a/Crypto/Lol/GaussRandom.hs b/Crypto/Lol/GaussRandom.hs --- a/Crypto/Lol/GaussRandom.hs +++ b/Crypto/Lol/GaussRandom.hs @@ -1,7 +1,19 @@ -{-# LANGUAGE NoImplicitPrelude, RebindableSyntax, ScopedTypeVariables #-} +{-| +Module : Crypto.Lol.GaussRandom +Description : Gaussian sampling. +Copyright : (c) Eric Crockett, 2011-2017 + Chris Peikert, 2011-2017 +License : GPL-2 +Maintainer : ecrockett0@email.com +Stability : experimental +Portability : POSIX --- | Functions for sampling from a continuous Gaussian distribution +Functions for sampling from a continuous Gaussian distribution. +-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} + module Crypto.Lol.GaussRandom ( realGaussian, realGaussians ) where @@ -27,15 +39,9 @@ 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*com,v*com) + where getUV = do u <- getRandomR (-one,one) + v <- getRandomR (-one,one) return (u,v) uvGuard (u,v) = (u*u+v*v >= one) || (u*u+v*v == zero) @@ -50,45 +56,11 @@ | otherwise = (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 {-# INLINE iterateWhile #-} -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 -{-# INLINE iterateUntilM #-} -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 --} +iterateWhile p x = go + where go = do + y <- x + if p y then go else return y diff --git a/Crypto/Lol/PosBin.hs b/Crypto/Lol/PosBin.hs --- a/Crypto/Lol/PosBin.hs +++ b/Crypto/Lol/PosBin.hs @@ -1,9 +1,23 @@ -{-# LANGUAGE DataKinds, TemplateHaskell #-} +{-| +Module : Crypto.Lol.PosBin +Description : Type-level positive naturals in Peano and binary. +Copyright : (c) Eric Crockett, 2011-2017 + Chris Peikert, 2011-2017 +License : GPL-2 +Maintainer : ecrockett0@email.com +Stability : experimental +Portability : POSIX --- | 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. +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. +-} + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TemplateHaskell #-} + + module Crypto.Lol.PosBin ( module Crypto.Lol.PosBinDefs diff --git a/Crypto/Lol/PosBinDefs.hs b/Crypto/Lol/PosBinDefs.hs --- a/Crypto/Lol/PosBinDefs.hs +++ b/Crypto/Lol/PosBinDefs.hs @@ -1,14 +1,35 @@ -{-# LANGUAGE ConstraintKinds, CPP, DataKinds, GADTs, InstanceSigs, - KindSignatures, NoImplicitPrelude, PolyKinds, RankNTypes, - RebindableSyntax, ScopedTypeVariables, TemplateHaskell, - TypeFamilies, UndecidableInstances #-} -{-# OPTIONS_GHC -fno-warn-duplicate-exports #-} -#if __GLASGOW_HASKELL__ >= 800 -{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} -#endif +{-| +Module : Crypto.Lol.PosBinDefs +Description : Internal module. +Copyright : (c) Eric Crockett, 2011-2017 + Chris Peikert, 2011-2017 +License : GPL-2 +Maintainer : ecrockett0@email.com +Stability : experimental +Portability : POSIX --- | This sub-module exists only because we can't define and use --- template Haskell splices in the same module. + \( \def\Z{\mathbb{Z}} \) + \( \def\C{\mathbb{C}} \) + +This sub-module exists only because we can't define and use +template Haskell splices in the same module. +-} + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_GHC -fno-warn-duplicate-exports #-} +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} module Crypto.Lol.PosBinDefs ( -- * Positive naturals in Peano representation diff --git a/Crypto/Lol/Prelude.hs b/Crypto/Lol/Prelude.hs --- a/Crypto/Lol/Prelude.hs +++ b/Crypto/Lol/Prelude.hs @@ -1,12 +1,29 @@ +{-| +Module : Crypto.Lol.Prelude +Description : Alternate Prelude. +Copyright : (c) Eric Crockett, 2011-2017 + Chris Peikert, 2011-2017 +License : GPL-2 +Maintainer : ecrockett0@email.com +Stability : experimental +Portability : POSIX + + \( \def\Z{\mathbb{Z}} \) + \( \def\C{\mathbb{C}} \) + +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. +-} + {-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RebindableSyntax #-} @@ -17,14 +34,6 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} --- | \( \def\Z{\mathbb{Z}} \) --- \( \def\C{\mathbb{C}} \) --- --- A substitute for the Prelude that is more suitable for Lol. This --- module exports most of the Numeric Prelude and other frequently --- used modules, plus some low-level classes, missing instances, and --- assorted utility functions. - module Crypto.Lol.Prelude ( -- * Classes and families @@ -36,7 +45,7 @@ -- * Numeric , module Crypto.Lol.Types.Numeric -- * Complex -, module Crypto.Lol.Types.Complex +, module Crypto.Lol.Types.Unsafe.Complex -- * Factored , module Crypto.Lol.Factored -- * Miscellaneous @@ -47,7 +56,7 @@ ) where import Crypto.Lol.Factored -import Crypto.Lol.Types.Complex +import Crypto.Lol.Types.Unsafe.Complex (Complex(), roundComplex, cis, real, imag, fromReal) import Crypto.Lol.Types.Numeric import Algebra.Field as Field (C) @@ -58,7 +67,7 @@ import Control.Arrow import Control.DeepSeq import Control.Monad.Identity -import Control.Monad.Random +import Control.Monad.Random hiding (lift) import Data.Coerce import Data.Default import Data.Functor.Trans.Tagged @@ -70,9 +79,6 @@ import qualified Data.Vector.Unboxed as U import Data.Vector.Unboxed.Deriving -#if __GLASGOW_HASKELL__ < 800 -instance NFData (Proxy (a :: k)) where rnf Proxy = () -#endif deriving instance NFData (m a) => NFData (TaggedT s m a) deriving instance (MonadRandom m) => MonadRandom (TaggedT (tag :: k) m) diff --git a/Crypto/Lol/RLWE/Continuous.hs b/Crypto/Lol/RLWE/Continuous.hs --- a/Crypto/Lol/RLWE/Continuous.hs +++ b/Crypto/Lol/RLWE/Continuous.hs @@ -1,10 +1,25 @@ -{-# LANGUAGE ConstraintKinds, FlexibleContexts, MultiParamTypeClasses, - NoImplicitPrelude, RebindableSyntax, ScopedTypeVariables #-} +{-| +Module : Crypto.Lol.RLWE.Continuous +Description : Functions and types for working with continuous ring-LWE samples. +Copyright : (c) Eric Crockett, 2011-2017 + Chris Peikert, 2011-2017 +License : GPL-2 +Maintainer : ecrockett0@email.com +Stability : experimental +Portability : POSIX --- | \( \def\Z{\mathbb{Z}} \) --- \( \def\R{\mathbb{R}} \) --- Functions and types for working with continuous ring-LWE samples. + \( \def\Z{\mathbb{Z}} \) + \( \def\R{\mathbb{R}} \) +Functions and types for working with continuous ring-LWE samples. +-} + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} + module Crypto.Lol.RLWE.Continuous where import Crypto.Lol.Cyclotomic.Cyc as C @@ -13,7 +28,7 @@ import Crypto.Lol.Prelude import Control.Applicative -import Control.Monad.Random +import Control.Monad.Random hiding (lift) -- | A continuous RLWE sample \( (a,b) \in R_q \times K/(qR)\). (The -- second component is a 'UCyc' because the base type @rrq@ diff --git a/Crypto/Lol/RLWE/Discrete.hs b/Crypto/Lol/RLWE/Discrete.hs --- a/Crypto/Lol/RLWE/Discrete.hs +++ b/Crypto/Lol/RLWE/Discrete.hs @@ -1,7 +1,21 @@ -{-# LANGUAGE ConstraintKinds, FlexibleContexts, MultiParamTypeClasses, - NoImplicitPrelude, RebindableSyntax, ScopedTypeVariables #-} +{-| +Module : Crypto.Lol.RLWE.Discrete +Description : Functions and types for working with discretized ring-LWE samples. +Copyright : (c) Eric Crockett, 2011-2017 + Chris Peikert, 2011-2017 +License : GPL-2 +Maintainer : ecrockett0@email.com +Stability : experimental +Portability : POSIX --- | Functions and types for working with discretized ring-LWE samples. +Functions and types for working with discretized ring-LWE samples. +-} + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} module Crypto.Lol.RLWE.Discrete where diff --git a/Crypto/Lol/RLWE/RLWR.hs b/Crypto/Lol/RLWE/RLWR.hs --- a/Crypto/Lol/RLWE/RLWR.hs +++ b/Crypto/Lol/RLWE/RLWR.hs @@ -1,7 +1,21 @@ -{-# LANGUAGE ConstraintKinds, FlexibleContexts, MultiParamTypeClasses, - NoImplicitPrelude, ScopedTypeVariables #-} +{-| +Module : Crypto.Lol.RLWE.RLWR +Description : Functions and types for working with ring-LWR samples. +Copyright : (c) Eric Crockett, 2011-2017 + Chris Peikert, 2011-2017 +License : GPL-2 +Maintainer : ecrockett0@email.com +Stability : experimental +Portability : POSIX --- | Functions and types for working with ring-LWR samples. +Functions and types for working with ring-LWR samples. +-} + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ScopedTypeVariables #-} module Crypto.Lol.RLWE.RLWR where diff --git a/Crypto/Lol/Reflects.hs b/Crypto/Lol/Reflects.hs --- a/Crypto/Lol/Reflects.hs +++ b/Crypto/Lol/Reflects.hs @@ -1,9 +1,26 @@ -{-# LANGUAGE DataKinds, FlexibleContexts, FlexibleInstances, - KindSignatures, MultiParamTypeClasses, NoImplicitPrelude, - PolyKinds, ScopedTypeVariables, UndecidableInstances #-} +{-| +Module : Crypto.Lol.Reflects +Description : Generic interface for reflecting types to values. +Copyright : (c) Eric Crockett, 2011-2017 + Chris Peikert, 2011-2017 +License : GPL-2 +Maintainer : ecrockett0@email.com +Stability : experimental +Portability : POSIX --- | Generic interface for reflecting types to values. +Generic interface for reflecting types to values. +-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} + module Crypto.Lol.Reflects ( Reflects(..), ) where @@ -28,7 +45,7 @@ -- | Reflect the value assiated with the type @a@. value :: Tagged a i -instance (KnownNat a, ToInteger.C i) => Reflects (a :: TL.Nat) i where +instance (KnownNat a, Ring.C i) => Reflects (a :: TL.Nat) i where value = tag $ fromIntegral $ natVal (Proxy::Proxy a) {- diff --git a/Crypto/Lol/Types.hs b/Crypto/Lol/Types.hs --- a/Crypto/Lol/Types.hs +++ b/Crypto/Lol/Types.hs @@ -1,19 +1,27 @@ +{-| +Module : Crypto.Lol.Types +Description : Concrete types needed to instantiate cryptographic applications. +Copyright : (c) Eric Crockett, 2011-2017 + Chris Peikert, 2011-2017 +License : GPL-2 +Maintainer : ecrockett0@email.com +Stability : experimental +Portability : POSIX --- | Exports concrete types needed to instantiate cryptographic applications. --- Specifically: --- --- * "Crypto.Lol.Cyclotomic.Tensor.CTensor" --- * "Crypto.Lol.Cyclotomic.Tensor.RepaTensor" --- * "Crypto.Lol.Types.IrreducibleChar2" --- * "Crypto.Lol.Types.Random" --- * "Crypto.Lol.Types.RRq" --- * "Crypto.Lol.Types.ZqBasic" +Exports concrete types needed to instantiate cryptographic applications. +Specifically: + * "Crypto.Lol.Types.Complex" + * "Crypto.Lol.Types.IrreducibleChar2" + * "Crypto.Lol.Types.Random" + * "Crypto.Lol.Types.RRq" + * "Crypto.Lol.Types.ZqBasic" +-} + module Crypto.Lol.Types ( module X ) where -import Crypto.Lol.Cyclotomic.Tensor.CTensor as X -import Crypto.Lol.Cyclotomic.Tensor.RepaTensor as X -import Crypto.Lol.Types.IrreducibleChar2 as X () -import Crypto.Lol.Types.Random as X -import Crypto.Lol.Types.RRq as X -import Crypto.Lol.Types.ZqBasic as X +import Crypto.Lol.Types.Unsafe.Complex as X hiding (Complex) +import Crypto.Lol.Types.IrreducibleChar2 as X () +import Crypto.Lol.Types.Random as X +import Crypto.Lol.Types.Unsafe.RRq as X hiding (RRq') +import Crypto.Lol.Types.Unsafe.ZqBasic as X hiding (ZqB) diff --git a/Crypto/Lol/Types/Complex.hs b/Crypto/Lol/Types/Complex.hs deleted file mode 100644 --- a/Crypto/Lol/Types/Complex.hs +++ /dev/null @@ -1,95 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE RebindableSyntax #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} - --- | Data type, functions, and instances for complex numbers. - -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 --- @Number.Complex@. -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 |] - --- | Custom instance replacing the one provided by numeric prelude: it --- always returns 0 as the remainder of a division. (The NP instance --- sometimes has precision issues, because it yields nonzero --- remainders, which is a problem for 'divG' methods.) -instance (Field a) => IntegralDomain.C (Complex a) where - (Complex a) `divMod` (Complex b) = (Complex $ a / b, LP.zero) - --- 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 \bmod 2\cdot\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 --- a/Crypto/Lol/Types/FiniteField.hs +++ b/Crypto/Lol/Types/FiniteField.hs @@ -1,10 +1,24 @@ +{-| +Module : Crypto.Lol.Types.FiniteField +Description : Basic (unoptimized) finite field arithmetic. +Copyright : (c) Eric Crockett, 2011-2017 + Chris Peikert, 2011-2017 +License : GPL-2 +Maintainer : ecrockett0@email.com +Stability : experimental +Portability : POSIX + + \( \def\F{\mathbb{F}} \) + +Basic (unoptimized) finite field arithmetic. +-} + {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE RoleAnnotations #-} @@ -13,9 +27,6 @@ {-# LANGUAGE UndecidableInstances #-} -- CJP: need PolyKinds to allow d to have non-* kind - --- | \( \def\F{\mathbb{F}} \) --- Basic (unoptimized) finite field arithmetic. module Crypto.Lol.Types.FiniteField ( GF -- export type but not constructor diff --git a/Crypto/Lol/Types/IZipVector.hs b/Crypto/Lol/Types/IZipVector.hs --- a/Crypto/Lol/Types/IZipVector.hs +++ b/Crypto/Lol/Types/IZipVector.hs @@ -1,25 +1,63 @@ -{-# LANGUAGE ConstraintKinds, DataKinds, DeriveTraversable, - FlexibleContexts, GeneralizedNewtypeDeriving, KindSignatures, - MultiParamTypeClasses, RoleAnnotations, ScopedTypeVariables, - TypeFamilies, UndecidableInstances #-} +{-| +Module : Crypto.Lol.Types.IZipVector +Description : Provides applicative-like functions for indexed vectors. +Copyright : (c) Eric Crockett, 2011-2017 + Chris Peikert, 2011-2017 +License : GPL-2 +Maintainer : ecrockett0@email.com +Stability : experimental +Portability : POSIX --- | Provides applicative-like functions for indexed vectors +Provides applicative-like functions for indexed vectors. +-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + module Crypto.Lol.Types.IZipVector ( IZipVector, iZipVector, unIZipVector, unzipIZV ) where -import Crypto.Lol.Factored +import Crypto.Lol.Prelude as LP +import Crypto.Lol.Reflects +import Crypto.Lol.Types.Proto +import Crypto.Lol.Types.Unsafe.RRq +import Crypto.Lol.Types.Unsafe.ZqBasic +import Crypto.Proto.Lol.Kq1 +import Crypto.Proto.Lol.KqProduct +import Crypto.Proto.Lol.R +import Crypto.Proto.Lol.Rq1 +import Crypto.Proto.Lol.RqProduct + import Algebra.ZeroTestable as ZeroTestable +import Control.Applicative import Control.DeepSeq -import Data.Data -import Data.Functor.Trans.Tagged +import Control.Monad +import Control.Monad.Except -import Data.Vector as V +import Data.Foldable as F +import Data.Sequence as S +import Data.Traversable +import Data.Vector (Vector) +import qualified 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 @@ -48,6 +86,9 @@ unzipIZV (IZipVector v) = let (va,vb) = V.unzip v in (IZipVector va, IZipVector vb) +zipIZV :: IZipVector m a -> IZipVector m b -> IZipVector m (a,b) +zipIZV (IZipVector a) (IZipVector b) = IZipVector $ V.zip a b + -- don't export repl :: forall m a . (Fact m) => a -> IZipVector m a repl = let n = proxy totientFact (Proxy::Proxy m) @@ -61,3 +102,135 @@ -- no ZeroTestable instance for Vectors, so define here instance (ZeroTestable.C a) => ZeroTestable.C (Vector a) where isZero = V.all isZero + +instance (Fact m) => Protoable (IZipVector m Int64) where + type ProtoType (IZipVector m Int64) = R + + toProto (IZipVector xs') = + let m = fromIntegral $ proxy valueFact (Proxy::Proxy m) + xs = S.fromList $ V.toList xs' + in R{..} + + fromProto R{..} = do + let m' = proxy valueFact (Proxy::Proxy m) :: Int + n = proxy totientFact (Proxy::Proxy m) + ys' = V.fromList $ F.toList xs + len = F.length xs + unless (m' == fromIntegral m) $ throwError $ + "An error occurred while reading the proto type for CT.\n\ + \Expected m=" ++ show m' ++ ", got " ++ show m + unless (len == n) $ throwError $ + "An error occurred while reading the proto type for CT.\n\ + \Expected n=" ++ show n ++ ", got " ++ show len + return $ IZipVector ys' + +instance (Fact m, Reflects q Int64) => Protoable (IZipVector m (ZqBasic q Int64)) where + type ProtoType (IZipVector m (ZqBasic q Int64)) = RqProduct + + toProto (IZipVector xs') = + let m = fromIntegral $ proxy valueFact (Proxy::Proxy m) + q = fromIntegral (proxy value (Proxy::Proxy q) :: Int64) + xs = S.fromList $ V.toList $ V.map LP.lift xs' + in RqProduct $ S.singleton Rq1{..} + + fromProto (RqProduct xs') = do + let rqlist = F.toList xs' + m' = proxy valueFact (Proxy::Proxy m) :: Int + q' = proxy value (Proxy::Proxy q) :: Int64 + n = proxy totientFact (Proxy::Proxy m) + unless (F.length rqlist == 1) $ throwError $ + "An error occurred while reading the proto type for CT.\n\ + \Expected a list of one Rq, but list has length " ++ show (F.length rqlist) + let [Rq1{..}] = rqlist + ys' = V.fromList $ F.toList xs + len = F.length xs + unless (m' == fromIntegral m) $ throwError $ + "An error occurred while reading the proto type for CT.\n\ + \Expected m=" ++ show m' ++ ", got " ++ show m + unless (len == n) $ throwError $ + "An error occurred while reading the proto type for CT.\n\ + \Expected n=" ++ show n ++ ", got " ++ show len + unless (fromIntegral q' == q) $ throwError $ + "An error occurred while reading the proto type for CT.\n\ + \Expected q=" ++ show q' ++ ", got " ++ show q + return $ IZipVector $ V.map reduce ys' + +instance (Fact m, Reflects q Double) => Protoable (IZipVector m (RRq q Double)) where + type ProtoType (IZipVector m (RRq q Double)) = KqProduct + + toProto (IZipVector xs') = + let m = fromIntegral $ proxy valueFact (Proxy::Proxy m) + q = round (proxy value (Proxy::Proxy q) :: Double) + xs = S.fromList $ V.toList $ V.map LP.lift xs' + in KqProduct $ S.singleton Kq1{..} + + fromProto (KqProduct xs') = do + let rqlist = F.toList xs' + m' = proxy valueFact (Proxy::Proxy m) :: Int + q' = round (proxy value (Proxy::Proxy q) :: Double) + n = proxy totientFact (Proxy::Proxy m) + unless (F.length rqlist == 1) $ throwError $ + "An error occurred while reading the proto type for CT.\n\ + \Expected a list of one Rq, but list has length " ++ show (F.length rqlist) + let [Kq1{..}] = rqlist + ys' = V.fromList $ F.toList xs + len = F.length xs + unless (m' == fromIntegral m) $ throwError $ + "An error occurred while reading the proto type for CT.\n\ + \Expected m=" ++ show m' ++ ", got " ++ show m + unless (len == n) $ throwError $ + "An error occurred while reading the proto type for CT.\n\ + \Expected n=" ++ show n ++ ", got " ++ show len + unless (q' == q) $ throwError $ + "An error occurred while reading the proto type for CT.\n\ + \Expected q=" ++ show q' ++ ", got " ++ show q + return $ IZipVector $ V.map reduce ys' + +instance (Protoable (IZipVector m (ZqBasic q Int64)), + ProtoType (IZipVector m (ZqBasic q Int64)) ~ RqProduct, + Protoable (IZipVector m b), ProtoType (IZipVector m b) ~ RqProduct) + => Protoable (IZipVector m (ZqBasic q Int64,b)) where + type ProtoType (IZipVector m (ZqBasic q Int64, b)) = RqProduct + + toProto = toProtoProduct RqProduct rqlist + fromProto = fromProtoNestRight RqProduct rqlist + +instance (Protoable (IZipVector m (RRq q Double)), + ProtoType (IZipVector m (RRq q Double)) ~ KqProduct, + Protoable (IZipVector m b), ProtoType (IZipVector m b) ~ KqProduct) + => Protoable (IZipVector m (RRq q Double,b)) where + type ProtoType (IZipVector m (RRq q Double, b)) = KqProduct + + toProto = toProtoProduct KqProduct kqlist + fromProto = fromProtoNestRight KqProduct kqlist + +toProtoProduct :: forall m a b c . + (Protoable (IZipVector m a), Protoable (IZipVector m b), + ProtoType (IZipVector m a) ~ ProtoType (IZipVector m b)) + => (Seq c -> ProtoType (IZipVector m a)) + -> (ProtoType (IZipVector m a) -> Seq c) + -> IZipVector m (a,b) + -> ProtoType (IZipVector m a) +toProtoProduct box unbox xs = + let (as,bs) = unzipIZV xs + as' = unbox $ toProto as + bs' = unbox $ toProto bs + in box $ as' >< bs' + +-- for tuples like (a, (b, c)) +fromProtoNestRight :: + (MonadError String mon, + Protoable (IZipVector m a), Protoable (IZipVector m b), + ProtoType (IZipVector m a) ~ ProtoType (IZipVector m b)) + => (Seq c -> ProtoType (IZipVector m a)) + -> (ProtoType (IZipVector m a)-> Seq c) + -> ProtoType (IZipVector m a) + -> mon (IZipVector m (a,b)) +fromProtoNestRight box unbox xs = do + let ys = unbox xs + unless (F.length ys >= 2) $ throwError $ + "Expected list of length >= 2, received list of length " ++ show (F.length ys) + let (a :< bs) = viewl ys + a' <- fromProto $ box $ singleton a + bs' <- fromProto $ box bs + return $ zipIZV a' bs' diff --git a/Crypto/Lol/Types/IrreducibleChar2.hs b/Crypto/Lol/Types/IrreducibleChar2.hs --- a/Crypto/Lol/Types/IrreducibleChar2.hs +++ b/Crypto/Lol/Types/IrreducibleChar2.hs @@ -1,9 +1,23 @@ -{-# LANGUAGE FlexibleInstances, NoImplicitPrelude, PolyKinds, - RebindableSyntax, ScopedTypeVariables, TypeFamilies, - UndecidableInstances #-} +{-| +Module : Crypto.Lol.Types.IrreducibleChar2 +Description : Orphan instance of 'IrreduciblePoly' for characteristic-2 fields. +Copyright : (c) Eric Crockett, 2011-2017 + Chris Peikert, 2011-2017 +License : GPL-2 +Maintainer : ecrockett0@email.com +Stability : experimental +Portability : POSIX --- | Orphan instance of 'IrreduciblePoly' for characteristic-2 fields. +Orphan instance of 'IrreduciblePoly' for characteristic-2 fields. +-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + module Crypto.Lol.Types.IrreducibleChar2 () where import Crypto.Lol.Prelude hiding (lookup) @@ -16,13 +30,12 @@ instance (CharOf a ~ Prime2, Field a) => IrreduciblePoly a where irreduciblePoly = do n <- value - return $ flip fromMaybe (lookup n polyMap) $ - error $ - "The IrreduciblePoly instance for N2 included with the library " ++ - "(and exported by Crypto.Lol) only contains irreducible polynomials " ++ - "for characteristic-2 fields up to GF(2^^32). You need a polynomial " ++ - "for GF(2^^" ++ show n ++ "). Define your own instance of " ++ - "IrreduciblePoly and do not import Crypto.Lol." + return $ flip fromMaybe (lookup n polyMap) $ error $ + "The IrreduciblePoly instance for N2 included with the library " ++ + "(and exported by Crypto.Lol) only contains irreducible polynomials " ++ + "for characteristic-2 fields up to GF(2^^128). You need a polynomial " ++ + "for GF(2^^" ++ show n ++ "). Define your own instance of " ++ + "IrreduciblePoly and do not import Crypto.Lol." polyMap :: (Ring fp) => Map Int (Polynomial fp) polyMap = fromList $ map (\xs -> (head xs, coeffsToPoly xs)) coeffs @@ -38,7 +51,7 @@ -- [a,b,c,d] is the irreducible pentanomial X^a + X^b + X^c + X^d + 1 coeffs :: [[Int]] coeffs = [ - [1,1], + [1,0], [2,1], [3,1], [4,1], diff --git a/Crypto/Lol/Types/Numeric.hs b/Crypto/Lol/Types/Numeric.hs --- a/Crypto/Lol/Types/Numeric.hs +++ b/Crypto/Lol/Types/Numeric.hs @@ -1,9 +1,23 @@ +{-| +Module : Crypto.Lol.Types.Numeric +Description : Modifications to NumericPrelude for Lol. +Copyright : (c) Eric Crockett, 2011-2017 + Chris Peikert, 2011-2017 +License : GPL-2 +Maintainer : ecrockett0@email.com +Stability : experimental +Portability : POSIX + +This module imports NumericPrelude and defines constraint +synonyms for NumericPrelude classes to help with code readability, +and defines saner versions of some NumericPrelude functions. +-} + {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} @@ -12,10 +26,6 @@ -- 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 @@ -141,15 +151,19 @@ -- | Sane synonym for 'MathObj.Matrix.T'. type Matrix a = MathObj.Matrix.T a --- 'IntegralDomain' instance for 'Double' +-- | 'IntegralDomain' instance for 'Double' instance Algebra.IntegralDomain.C Double where _ `div` 0 = error "cannot divide Double by 0\n" a `div` b = a / b _ `mod` _ = 0 --- 'NFData' instance for 'Polynomial', missing from NP +-- | 'NFData' instance for 'Polynomial', missing from NP instance (NFData r) => NFData (Polynomial r) where rnf = rnf . coeffs + +-- | 'NFData' instance for 'Matrix', missing from NP +instance (NFData r) => NFData (Matrix r) where + rnf = rnf . rows -- | Our custom exponentiation, overriding NP's version that -- requires 'Integer' exponent. diff --git a/Crypto/Lol/Types/Proto.hs b/Crypto/Lol/Types/Proto.hs --- a/Crypto/Lol/Types/Proto.hs +++ b/Crypto/Lol/Types/Proto.hs @@ -1,21 +1,52 @@ -{-# LANGUAGE FlexibleContexts, FlexibleInstances, PolyKinds, - ScopedTypeVariables, TypeFamilies #-} +{-| +Module : Crypto.Lol.Types.Proto +Description : Convenient interfaces for serialization with protocol buffers. +Copyright : (c) Eric Crockett, 2011-2017 + Chris Peikert, 2011-2017 +License : GPL-2 +Maintainer : ecrockett0@email.com +Stability : experimental +Portability : POSIX --- | Convenient interfaces for serialization with protocol buffers. +Convenient interfaces for serialization with protocol buffers. +-} -module Crypto.Lol.Types.Proto where +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +module Crypto.Lol.Types.Proto +(Protoable(..), msgPut, msgGet +,uToString, uFromString +,readProtoType, parseProtoFile +,writeProtoType, writeProtoFile +,ProtoReadable +) where + +import Crypto.Proto.Lol.TypeRep (TypeRep(TypeRep)) + import Control.Monad.Except -import Data.ByteString.Lazy hiding (map) +import qualified Data.ByteString.Lazy as BS import Data.Foldable (toList) -import Data.Sequence (fromList) +import Data.Sequence +import GHC.Fingerprint +import Prelude hiding (length) +import System.Directory + import Text.ProtocolBuffers (messageGet, messagePut) +import Text.ProtocolBuffers.Basic (uToString, uFromString) import Text.ProtocolBuffers.Header +-- | Constraint synonym for end-to-end reading/parsing/writing of 'Protoable' types. +type ProtoReadable a = (Protoable a, Wire (ProtoType a), ReflectDescriptor (ProtoType a)) + -- | Conversion between Haskell types and their protocol buffer representations. class Protoable a where - -- | The protocol buffer type for @a@. + type ProtoType a -- | Convert from a type to its protocol buffer representation. @@ -48,3 +79,38 @@ (msg, bs') <- messageGet bs p <- fromProto msg return (p, bs') + +-- | Read a serialized protobuffer from a file. +readProtoType :: (ReflectDescriptor a, Wire a, MonadIO m, MonadError String m) + => FilePath -> m a +readProtoType file = do + fileExists <- liftIO $ doesFileExist file + unless fileExists $ throwError $ + "Error reading " ++ file ++ ": file does not exist." + bs <- liftIO $ BS.readFile file + case messageGet bs of + (Left str) -> throwError $ + "Error when reading from protocol buffer. Got string " ++ str + (Right (a,bs')) -> do + unless (BS.null bs') $ throwError + "Error when reading from protocol buffer. There were leftover bits!" + return a + +-- | Writes any auto-gen'd proto object to path/filename. +writeProtoType :: (ReflectDescriptor a, Wire a) => FilePath -> a -> IO () +writeProtoType fileName = BS.writeFile fileName . messagePut + +-- | Read a protocol buffer stream at the given path and convert it to typed +-- Haskell data. +parseProtoFile :: (ProtoReadable a, MonadIO m, MonadError String m) + => FilePath -> m a +parseProtoFile file = fromProto =<< readProtoType file + +-- | Write a protocol buffer stream for Haskell data to the given path. +writeProtoFile :: (ProtoReadable a, MonadIO m) => FilePath -> a -> m () +writeProtoFile file = liftIO . writeProtoType file . toProto + +instance Protoable Fingerprint where + type ProtoType Fingerprint = TypeRep + toProto (Fingerprint a b) = TypeRep a b + fromProto (TypeRep a b) = return $ Fingerprint a b diff --git a/Crypto/Lol/Types/RRq.hs b/Crypto/Lol/Types/RRq.hs deleted file mode 100644 --- a/Crypto/Lol/Types/RRq.hs +++ /dev/null @@ -1,113 +0,0 @@ -{-# LANGUAGE ConstraintKinds, FlexibleContexts, FlexibleInstances, - GeneralizedNewtypeDeriving, MultiParamTypeClasses, - NoImplicitPrelude, PolyKinds, RebindableSyntax, - ScopedTypeVariables, TypeFamilies, UndecidableInstances #-} - --- | \( \def\Z{\mathbb{Z}} \) --- \( \def\R{\mathbb{R}} \) --- An implementation of the additive quotient group \(\R/(q\Z)\). - -module Crypto.Lol.Types.RRq -( RRq -) where - -import Algebra.Additive as Additive (C) -import Algebra.ZeroTestable as ZeroTestable (C) - -import Control.Applicative -import Control.DeepSeq - -import Crypto.Lol.Prelude -import Crypto.Lol.Reflects -import Crypto.Lol.Types.ZqBasic - --- for the Elt instance -import qualified Data.Array.Repa.Eval as E - --- for the Unbox instances -import qualified Data.Vector.Generic as G -import qualified Data.Vector.Generic.Mutable as M -import qualified Data.Vector.Unboxed as U - -import Foreign.Storable - --- invariant: 0 <= x < q --- | The ring \(\R/(q\Z)\) of reals modulo 'q', using --- underlying floating type 'r'. -newtype RRq q r = RRq r - deriving (Eq, Ord, ZeroTestable.C, E.Elt, Show, NFData, Storable) - -{-# INLINABLE reduce' #-} -reduce' :: forall q r . (Reflects q r, RealField r) => r -> RRq q r -reduce' = let q = proxy value (Proxy::Proxy q) - in \x -> RRq $ x - q * floor (x / q) - --- puts value in range [-q/2, q/2) -decode' :: forall q r . (Reflects q r, Ord r, Ring r) - => RRq q r -> r -decode' = let qval = proxy value (Proxy::Proxy q) - in \(RRq x) -> if x + x < qval then x else x - qval - -instance (Reflects q r, RealField r, Additive (RRq q r)) - => Reduce r (RRq q r) where - reduce = reduce' - -type instance LiftOf (RRq q r) = r - -instance (Reflects q r, Reduce r (RRq q r), Ord r, Ring r) - => Lift' (RRq q r) where - lift = decode' - --- instance of Additive -instance (Reflects q r, RealField r, Ord r) => Additive.C (RRq q r) where - - {-# INLINABLE zero #-} - zero = RRq zero - - {-# INLINABLE (+) #-} - (+) = let qval = proxy value (Proxy::Proxy q) - in \ (RRq x) (RRq y) -> - let z = x + y - in RRq (if z >= qval then z - qval else z) - - {-# INLINABLE negate #-} - negate (RRq x) = reduce' $ negate x - -instance (ToInteger i, RealField r, Reflects q i, Reflects q r) - => Subgroup (ZqBasic q i) (RRq q r) where - fromSubgroup = reduce' . fromIntegral . lift - --- CJP: restored manual Unbox instances, until we have a better way --- (NewtypeDeriving or TH) - -newtype instance U.MVector s (RRq q r) = MV_RRq (U.MVector s r) -newtype instance U.Vector (RRq q r) = V_RRq (U.Vector r) - --- Unbox, when underlying representation is -instance U.Unbox r => U.Unbox (RRq q r) - -{- purloined and tweaked from code in `vector` package that defines -types as unboxed -} -instance U.Unbox r => M.MVector U.MVector (RRq q r) where - basicLength (MV_RRq v) = M.basicLength v - basicUnsafeSlice z n (MV_RRq v) = MV_RRq $ M.basicUnsafeSlice z n v - basicOverlaps (MV_RRq v1) (MV_RRq v2) = M.basicOverlaps v1 v2 - basicInitialize (MV_RRq v) = M.basicInitialize v - basicUnsafeNew n = MV_RRq <$> M.basicUnsafeNew n - basicUnsafeReplicate n (RRq x) = MV_RRq <$> M.basicUnsafeReplicate n x - basicUnsafeRead (MV_RRq v) z = RRq <$> M.basicUnsafeRead v z - basicUnsafeWrite (MV_RRq v) z (RRq x) = M.basicUnsafeWrite v z x - basicClear (MV_RRq v) = M.basicClear v - basicSet (MV_RRq v) (RRq x) = M.basicSet v x - basicUnsafeCopy (MV_RRq v1) (MV_RRq v2) = M.basicUnsafeCopy v1 v2 - basicUnsafeMove (MV_RRq v1) (MV_RRq v2) = M.basicUnsafeMove v1 v2 - basicUnsafeGrow (MV_RRq v) n = MV_RRq <$> M.basicUnsafeGrow v n - -instance U.Unbox r => G.Vector U.Vector (RRq q r) where - basicUnsafeFreeze (MV_RRq v) = V_RRq <$> G.basicUnsafeFreeze v - basicUnsafeThaw (V_RRq v) = MV_RRq <$> G.basicUnsafeThaw v - basicLength (V_RRq v) = G.basicLength v - basicUnsafeSlice z n (V_RRq v) = V_RRq $ G.basicUnsafeSlice z n v - basicUnsafeIndexM (V_RRq v) z = RRq <$> G.basicUnsafeIndexM v z - basicUnsafeCopy (MV_RRq mv) (V_RRq v) = G.basicUnsafeCopy mv v - elemseq _ = seq diff --git a/Crypto/Lol/Types/Random.hs b/Crypto/Lol/Types/Random.hs --- a/Crypto/Lol/Types/Random.hs +++ b/Crypto/Lol/Types/Random.hs @@ -1,10 +1,21 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-| +Module : Crypto.Lol.Types.Random +Description : Types for using crypto-api with MonadCryptoRandom. +Copyright : (c) Eric Crockett, 2011-2017 + Chris Peikert, 2011-2017 +License : GPL-2 +Maintainer : ecrockett0@email.com +Stability : experimental +Portability : POSIX --- | Defines a newtype wrapper 'CryptoRand' for crypto-api's --- 'CryptoRandomGen', and a corresponding 'RandomGen' wrapper --- instance. These are needed because 'CryptoRandomGen' generators --- can only be used to get "Data.ByteString"s; the 'RandomGen' wrapper --- instance allows them to be used to generate any 'Random' type. +Defines a newtype wrapper 'CryptoRand' for crypto-api's +'CryptoRandomGen', and a corresponding 'RandomGen' wrapper +instance. These are needed because 'CryptoRandomGen' generators +can only be used to get "Data.ByteString"s; the 'RandomGen' wrapper +instance allows them to be used to generate any 'Random' type. +-} + +{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Crypto.Lol.Types.Random (CryptoRand, evalCryptoRandIO) where diff --git a/Crypto/Lol/Types/Unsafe/Complex.hs b/Crypto/Lol/Types/Unsafe/Complex.hs new file mode 100644 --- /dev/null +++ b/Crypto/Lol/Types/Unsafe/Complex.hs @@ -0,0 +1,90 @@ +{-| +Module : Crypto.Lol.Types.Unsafe.Complex +Description : Data type, functions, and instances for complex numbers. +Copyright : (c) Eric Crockett, 2011-2017 + Chris Peikert, 2011-2017 +License : GPL-2 +Maintainer : ecrockett0@email.com +Stability : experimental +Portability : POSIX + +Data type, functions, and instances for complex numbers. +This module is "unsafe" because it exports the 'Complex' constructor. +This module should only be used to make tensor-specific instances for 'Complex'. +The safe way to use this type is to import "Crypto.Lol.Types". +-} + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} + +module Crypto.Lol.Types.Unsafe.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 System.Random + +-- | Newtype wrapper (with slightly different instances) for +-- @Number.Complex@. +newtype Complex a = Complex (C.T a) + deriving (Additive.C, Ring.C, ZeroTestable.C, Field.C, Eq, Show) + +-- | Custom instance replacing the one provided by numeric prelude: it +-- always returns 0 as the remainder of a division. (The NP instance +-- sometimes has precision issues, because it yields nonzero +-- remainders, which is a problem for 'divG' methods.) +instance (Field a) => IntegralDomain.C (Complex a) where + (Complex a) `divMod` (Complex b) = (Complex $ a / b, LP.zero) + +-- 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)" + +-- | 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 \bmod 2\cdot\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/Unsafe/RRq.hs b/Crypto/Lol/Types/Unsafe/RRq.hs new file mode 100644 --- /dev/null +++ b/Crypto/Lol/Types/Unsafe/RRq.hs @@ -0,0 +1,88 @@ +{-| +Module : Crypto.Lol.Types.Unsafe.RRq +Description : An implementation of modular arithmetic over the reals. +Copyright : (c) Eric Crockett, 2011-2017 + Chris Peikert, 2011-2017 +License : GPL-2 +Maintainer : ecrockett0@email.com +Stability : experimental +Portability : POSIX + + \( \def\Z{\mathbb{Z}} \) + \( \def\R{\mathbb{R}} \) + +An implementation of the additive quotient group \(\R/(q\Z)\). +This module is "unsafe" because it exports the 'RRq' constructor. +This module should only be used to make tensor-specific instances for 'RRq'. +The safe way to use this type is to import "Crypto.Lol.Types". +-} + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Crypto.Lol.Types.Unsafe.RRq +( RRq(..) +) where + +import Algebra.Additive as Additive (C) +import Algebra.ZeroTestable as ZeroTestable (C) + +import Control.DeepSeq + +import Crypto.Lol.Prelude +import Crypto.Lol.Reflects +import Crypto.Lol.Types.Unsafe.ZqBasic hiding (ZqB) + +-- invariant: 0 <= x < q +-- | The ring \(\R/(q\Z)\) of reals modulo 'q', using +-- underlying floating type 'r'. +newtype RRq q r = RRq' r + deriving (Eq, Ord, ZeroTestable.C, Show, NFData) + +{-# INLINABLE reduce' #-} +reduce' :: forall q r . (Reflects q r, RealField r) => r -> RRq q r +reduce' = let q = proxy value (Proxy::Proxy q) + in \x -> RRq' $ x - q * floor (x / q) + +-- puts value in range [-q/2, q/2) +decode' :: forall q r . (Reflects q r, Ord r, Ring r) + => RRq q r -> r +decode' = let qval = proxy value (Proxy::Proxy q) + in \(RRq' x) -> if x + x < qval then x else x - qval + +instance (Reflects q r, RealField r, Additive (RRq q r)) + => Reduce r (RRq q r) where + reduce = reduce' + +type instance LiftOf (RRq q r) = r + +instance (Reflects q r, Reduce r (RRq q r), Ord r, Ring r) + => Lift' (RRq q r) where + lift = decode' + +-- instance of Additive +instance (Reflects q r, RealField r, Ord r) => Additive.C (RRq q r) where + + {-# INLINABLE zero #-} + zero = RRq' zero + + {-# INLINABLE (+) #-} + (+) = let qval = proxy value (Proxy::Proxy q) + in \ (RRq' x) (RRq' y) -> + let z = x + y + in RRq' (if z >= qval then z - qval else z) + + {-# INLINABLE negate #-} + negate (RRq' x) = reduce' $ negate x + +instance (ToInteger i, RealField r, Reflects q i, Reflects q r) + => Subgroup (ZqBasic q i) (RRq q r) where + fromSubgroup = reduce' . fromIntegral . lift diff --git a/Crypto/Lol/Types/Unsafe/ZqBasic.hs b/Crypto/Lol/Types/Unsafe/ZqBasic.hs new file mode 100644 --- /dev/null +++ b/Crypto/Lol/Types/Unsafe/ZqBasic.hs @@ -0,0 +1,323 @@ +{-| +Module : Crypto.Lol.Types.Unsafe.ZqBasic +Description : An implementation of modular arithmetic over the integers. +Copyright : (c) Eric Crockett, 2011-2017 + Chris Peikert, 2011-2017 +License : GPL-2 +Maintainer : ecrockett0@email.com +Stability : experimental +Portability : POSIX + + \( \def\Z{\mathbb{Z}} \) + \( \def\C{\mathbb{C}} \) + +An implementation of the quotient ring \(\Z_q = \Z/(q\Z)\). +This module is "unsafe" because it exports the 'ZqBasic' constructor. +This module should only be used to make tensor-specific instances for 'ZqBasic'. +The safe way to use this type is to import "Crypto.Lol.Types". + +EAC: It may help GHC do specialization at higher levels of the library +if we "simplify" constraints in this module. For example, replace the +(Additive (ZqBasic q z)) constraint on the Reduce instance with +(Additive z) +-} + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Crypto.Lol.Types.Unsafe.ZqBasic +( ZqBasic(..) -- export the type, but not the constructor (for safety) +, goodQs +) where + +import Crypto.Lol.CRTrans +import Crypto.Lol.Gadget +import Crypto.Lol.Prelude 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 qualified Data.Vector as V + +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) + +-- an infinite list of primes greater than the input and congruent to +-- 1 mod m +goodQs :: (IntegralDomain a, ToInteger a) => a -> a -> [a] +goodQs m lower = filter (isPrime . toInteger) $ + iterate (+m) $ lower + ((m-lower) `mod` m) + 1 + +-- | The ring \(\Z_q\) of integers modulo 'q', using underlying integer +-- type 'z'. +newtype ZqBasic q z = ZqB z + deriving (Eq, Ord, ZeroTestable.C, Show, NFData) + +-- 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) + +{-# INLINABLE reduce' #-} +reduce' :: forall q z . (Reflects q z, ToInteger z) => z -> ZqBasic q z +reduce' = ZqB . (`mod` proxy value (Proxy::Proxy q)) + +-- puts value in range [-q/2, q/2) +decode' :: forall q z . (Reflects q z, ToInteger z) => ZqBasic q z -> z +decode' = let qval = proxy value (Proxy::Proxy q) + in \(ZqB x) -> if 2 * x < qval then x else x - qval + +instance (Reflects q z, ToInteger z, Enum z) => Enumerable (ZqBasic q z) where + values = let qval :: z = proxy value (Proxy::Proxy q) + in coerce [0..(qval-1)] + +instance (Reflects q z, ToInteger 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) + => ZPP (ZqBasic (pp :: PrimePower) z) where + + type ZpOf (ZqBasic pp z) = ZqBasic (PrimePP pp) z + + modulusZPP = retag (ppPPow :: Tagged pp PP) + liftZp = coerce + +instance (Reflects q z, ToInteger z) => Reduce z (ZqBasic q z) where + reduce = reduce' + +instance (Reflects q z, ToInteger z, Additive (ZqBasic q z)) => Reduce Integer (ZqBasic q z) where + reduce = fromInteger + +type instance LiftOf (ZqBasic q z) = z + +instance (Reflects q z, ToInteger z) => Lift' (ZqBasic q z) where + lift = decode' + +instance (Reflects q z, ToInteger z, Reflects q' z, Ring z) + => Rescale (ZqBasic q z) (ZqBasic q' z) where + + rescale = rescaleMod + +instance (Reflects p z, Reflects q z, ToInteger z, Field (ZqBasic q z), Field (ZqBasic p z)) + => Encode (ZqBasic p z) (ZqBasic q z) where + + lsdToMSD = let pval :: z = proxy value (Proxy::Proxy p) + negqval :: z = negate $ proxy value (Proxy::Proxy q) + in (reduce' negqval, recip $ reduce' pval) + +-- | 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 m q z . (Reflects m Int, Reflects q z, ToInteger z, Enumerable (ZqBasic q z)) + => TaggedT m Maybe (Int -> ZqBasic q z) +principalRootUnity = -- use Integers for all intermediate calcs + let qval = fromIntegral (proxy value (Proxy::Proxy q) :: z) + mval = proxy value (Proxy::Proxy m) + -- order of Zq^* (assuming q prime) + order = qval-1 + -- the primes dividing the order of Zq^* + pfactors = fst <$> factorise order + -- the powers we need to check + exps = div order <$> pfactors + -- whether an element is a generator of Zq^* + isGen x = (x^order == one) && all (\e -> x^e /= one) exps + in tagT $ if isPrime qval -- for simplicity, require q to be prime + then let (mq,mr) = order `divMod` fromIntegral mval + in if mr == 0 + then let omega = head (filter isGen values) ^ mq + omegaPows = V.iterateN mval (*omega) one + in Just $ (omegaPows V.!) . (`mod` mval) + else Nothing + else Nothing -- fail if q composite + +mhatInv :: forall m q z . (Reflects m Int, Reflects q z, ToInteger z, PID z) + => TaggedT m Maybe (ZqBasic q z) +mhatInv = let qval = proxy value (Proxy::Proxy q) + in peelT $ (fmap reduce' . (`modinv` qval) . fromIntegral) <$> + valueHat <$> (value :: Tagged m Int) + +-- instance of CRTrans +instance (Reflects q z, ToInteger z, PID z, Enumerable (ZqBasic q z)) + => CRTrans Maybe (ZqBasic q z) where + + crtInfo = (,) <$> principalRootUnity <*> mhatInv + +-- | Embeds into the complex numbers \( \C \). +instance (Reflects q z, ToInteger z, Ring (ZqBasic q z)) => CRTEmbed (ZqBasic q z) where + type CRTExt (ZqBasic q z) = Complex Double + + toExt (ZqB x) = fromReal $ fromIntegral x + fromExt x = reduce' $ NP.round $ real x + +-- instance of Additive +instance (Reflects q z, ToInteger 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 (Reflects q z, ToInteger z, Ring z) => Ring.C (ZqBasic q z) where + {-# INLINABLE (*) #-} + (ZqB x) * (ZqB y) = reduce' $ x * y + + {-# INLINABLE fromInteger #-} + fromInteger = + let qval = toInteger (proxy value (Proxy::Proxy q) :: z) + -- 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 (Reflects q z, ToInteger z, PID z, Show z) => Field.C (ZqBasic q z) where + + {-# INLINABLE recip #-} + recip = let qval = proxy value (Proxy::Proxy q) + -- 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 (Reflects q z, ToInteger z, Field (ZqBasic q z)) => IntegralDomain.C (ZqBasic q z) where + divMod a b = (a/b, zero) + +-- Gadget-related instances +instance (Reflects q z, ToInteger z) => Gadget TrivGad (ZqBasic q z) where + gadget = tag [one] + +instance (Reflects q z, ToInteger z) => Decompose TrivGad (ZqBasic q z) where + type DecompOf (ZqBasic q z) = z + decompose x = tag [lift x] + +instance (Reflects q z, ToInteger z, Ring z) => Correct TrivGad (ZqBasic q z) where + correct a = case untag a of + [b] -> (b, [zero]) + _ -> error "Correct TrivGad: wrong length" + +-- 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 (Reflects q z, ToInteger z, RealIntegral z, Reflects b z) + => Gadget (BaseBGad b) (ZqBasic q z) where + + gadget = let qval = proxy value (Proxy :: Proxy q) + bval = proxy value (Proxy :: Proxy b) + in tag $ reduce' <$> gadgetZ bval qval + +instance (Reflects q z, ToInteger 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 (Reflects q z, ToInteger 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 (Reflects q z, ToInteger z, Random z) => Random (ZqBasic q z) where + random = let high = proxy value (Proxy::Proxy q) - 1 + in \g -> let (x,g') = randomR (0,high) g + in (ZqB x, g') + + randomR _ = error "randomR non-sensical for Zq types" + {-# INLINABLE random #-} diff --git a/Crypto/Lol/Types/ZPP.hs b/Crypto/Lol/Types/ZPP.hs --- a/Crypto/Lol/Types/ZPP.hs +++ b/Crypto/Lol/Types/ZPP.hs @@ -1,7 +1,20 @@ -{-# LANGUAGE FlexibleContexts, TypeFamilies #-} +{-| +Module : Crypto.Lol.Types.ZPP +Description : A class for integers mod a prime power. +Copyright : (c) Eric Crockett, 2011-2017 + Chris Peikert, 2011-2017 +License : GPL-2 +Maintainer : ecrockett0@email.com +Stability : experimental +Portability : POSIX --- | \( \def\Z{\mathbb{Z}} \) --- A class for integers mod a prime power. + \( \def\Z{\mathbb{Z}} \) + +A class for integers mod a prime power. +-} + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} module Crypto.Lol.Types.ZPP ( ZPP(..) diff --git a/Crypto/Lol/Types/ZmStar.hs b/Crypto/Lol/Types/ZmStar.hs --- a/Crypto/Lol/Types/ZmStar.hs +++ b/Crypto/Lol/Types/ZmStar.hs @@ -1,11 +1,29 @@ -{-# LANGUAGE ConstraintKinds, DataKinds, FlexibleContexts, - MultiParamTypeClasses, NoImplicitPrelude, PolyKinds, - RebindableSyntax, ScopedTypeVariables, TypeFamilies, - TypeOperators, UndecidableInstances #-} +{-| +Module : Crypto.Lol.Types.ZmStar +Description : Multiplicative groups mod q. +Copyright : (c) Eric Crockett, 2011-2017 + Chris Peikert, 2011-2017 +License : GPL-2 +Maintainer : ecrockett0@email.com +Stability : experimental +Portability : POSIX --- | \( \def\Z{\mathbb{Z}} \) --- A collection of helper functions for working with \(\Z_m^*\). + \( \def\Z{\mathbb{Z}} \) +A collection of helper functions for working with \(\Z_m^*\). +-} + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + module Crypto.Lol.Types.ZmStar ( order, partitionCosets ) where @@ -13,7 +31,7 @@ import Crypto.Lol.Factored import Crypto.Lol.Prelude as LP hiding (null) import Crypto.Lol.Reflects -import Crypto.Lol.Types.ZqBasic +import Crypto.Lol.Types.Unsafe.ZqBasic hiding (ZqB) import Data.List as L (foldl', transpose) import Data.Map (Map, elems, empty, insertWith') diff --git a/Crypto/Lol/Types/ZqBasic.hs b/Crypto/Lol/Types/ZqBasic.hs deleted file mode 100644 --- a/Crypto/Lol/Types/ZqBasic.hs +++ /dev/null @@ -1,354 +0,0 @@ -{-# LANGUAGE ConstraintKinds, DataKinds, FlexibleContexts, - FlexibleInstances, GeneralizedNewtypeDeriving, - MultiParamTypeClasses, NoImplicitPrelude, PolyKinds, - RebindableSyntax, RoleAnnotations, ScopedTypeVariables, - TypeFamilies, UndecidableInstances #-} - --- | \( \def\Z{\mathbb{Z}} \) --- \( \def\C{\mathbb{C}} \) --- An implementation of the quotient ring \(\Z_q = \Z/(q\Z)\). - --- EAC: It may help GHC do specialization at higher levels of the library --- if we "simplify" constraints in this module. For example, replace the --- (Additive (ZqBasic q z)) constraint on the Reduce instance with --- (Additive z) - -module Crypto.Lol.Types.ZqBasic -( ZqBasic -- export the type, but not the constructor (for safety) -, goodQs -) where - -import Crypto.Lol.CRTrans -import Crypto.Lol.Gadget -import Crypto.Lol.Prelude 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) - --- an infinite list of primes greater than the input and congruent to --- 1 mod m -goodQs :: (IntegralDomain a, ToInteger a) => a -> a -> [a] -goodQs m lower = filter (isPrime . toInteger) $ - iterate (+m) $ lower + ((m-lower) `mod` m) + 1 - --- | 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) - -{-# INLINABLE reduce' #-} -reduce' :: forall q z . (Reflects q z, ToInteger z) => z -> ZqBasic q z -reduce' = ZqB . (`mod` proxy value (Proxy::Proxy q)) - --- puts value in range [-q/2, q/2) -decode' :: forall q z . (Reflects q z, ToInteger z) => ZqBasic q z -> z -decode' = let qval = proxy value (Proxy::Proxy q) - in \(ZqB x) -> if 2 * x < qval then x else x - qval - -instance (Reflects q z, ToInteger z, Enum z) => Enumerable (ZqBasic q z) where - values = let qval :: z = proxy value (Proxy::Proxy q) - in coerce [0..(qval-1)] - -instance (Reflects q z, ToInteger 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) - => ZPP (ZqBasic (pp :: PrimePower) z) where - - type ZpOf (ZqBasic pp z) = ZqBasic (PrimePP pp) z - - modulusZPP = retag (ppPPow :: Tagged pp PP) - liftZp = coerce - -instance (Reflects q z, ToInteger z) => Reduce z (ZqBasic q z) where - reduce = reduce' - -instance (Reflects q z, ToInteger z, Additive (ZqBasic q z)) => Reduce Integer (ZqBasic q z) where - reduce = fromInteger - -type instance LiftOf (ZqBasic q z) = z - -instance (Reflects q z, ToInteger z) => Lift' (ZqBasic q z) where - lift = decode' - -instance (Reflects q z, ToInteger z, Reflects q' z, Ring z) - => Rescale (ZqBasic q z) (ZqBasic q' z) where - - rescale = rescaleMod - -instance (Reflects p z, Reflects q z, ToInteger z, Field (ZqBasic q z), Field (ZqBasic p z)) - => Encode (ZqBasic p z) (ZqBasic q z) where - - lsdToMSD = let pval :: z = proxy value (Proxy::Proxy p) - negqval :: z = negate $ proxy value (Proxy::Proxy q) - in (reduce' negqval, recip $ reduce' pval) - --- | 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 m q z . (Reflects m Int, Reflects q z, ToInteger z, Enumerable (ZqBasic q z)) - => TaggedT m Maybe (Int -> ZqBasic q z) -principalRootUnity = -- use Integers for all intermediate calcs - let qval = fromIntegral (proxy value (Proxy::Proxy q) :: z) - mval = proxy value (Proxy::Proxy m) - -- order of Zq^* (assuming q prime) - order = qval-1 - -- the primes dividing the order of Zq^* - pfactors = fst <$> factorise order - -- the powers we need to check - exps = div order <$> pfactors - -- whether an element is a generator of Zq^* - isGen x = (x^order == one) && all (\e -> x^e /= one) exps - in tagT $ if isPrime qval -- for simplicity, require q to be prime - then let (mq,mr) = order `divMod` fromIntegral mval - in if mr == 0 - then let omega = head (filter isGen values) ^ mq - omegaPows = V.iterateN mval (*omega) one - in Just $ (omegaPows V.!) . (`mod` mval) - else Nothing - else Nothing -- fail if q composite - -mhatInv :: forall m q z . (Reflects m Int, Reflects q z, ToInteger z, PID z) - => TaggedT m Maybe (ZqBasic q z) -mhatInv = let qval = proxy value (Proxy::Proxy q) - in peelT $ (fmap reduce' . (`modinv` qval) . fromIntegral) <$> - valueHat <$> (value :: Tagged m Int) - --- instance of CRTrans -instance (Reflects q z, ToInteger z, PID z, Enumerable (ZqBasic q z)) - => CRTrans Maybe (ZqBasic q z) where - - crtInfo = (,) <$> principalRootUnity <*> mhatInv - --- | Embeds into the complex numbers \( \C \). -instance (Reflects q z, ToInteger z, Ring (ZqBasic q z)) => CRTEmbed (ZqBasic q z) where - type CRTExt (ZqBasic q z) = Complex Double - - toExt (ZqB x) = fromReal $ fromIntegral x - fromExt x = reduce' $ NP.round $ real x - --- instance of Additive -instance (Reflects q z, ToInteger 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 (Reflects q z, ToInteger z, Ring z) => Ring.C (ZqBasic q z) where - {-# INLINABLE (*) #-} - (ZqB x) * (ZqB y) = reduce' $ x * y - - {-# INLINABLE fromInteger #-} - fromInteger = - let qval = toInteger (proxy value (Proxy::Proxy q) :: z) - -- 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 (Reflects q z, ToInteger z, PID z, Show z) => Field.C (ZqBasic q z) where - - {-# INLINABLE recip #-} - recip = let qval = proxy value (Proxy::Proxy q) - -- 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 (Reflects q z, ToInteger z, Field (ZqBasic q z)) => IntegralDomain.C (ZqBasic q z) where - divMod a b = (a/b, zero) - --- Gadget-related instances -instance (Reflects q z, ToInteger z) => Gadget TrivGad (ZqBasic q z) where - gadget = tag [one] - -instance (Reflects q z, ToInteger z) => Decompose TrivGad (ZqBasic q z) where - type DecompOf (ZqBasic q z) = z - decompose x = tag [lift x] - -instance (Reflects q z, ToInteger z, Ring z) => Correct TrivGad (ZqBasic q z) where - correct a = case untag a of - [b] -> (b, [zero]) - _ -> error "Correct TrivGad: wrong length" - --- 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 (Reflects q z, ToInteger z, RealIntegral z, Reflects b z) - => Gadget (BaseBGad b) (ZqBasic q z) where - - gadget = let qval = proxy value (Proxy :: Proxy q) - bval = proxy value (Proxy :: Proxy b) - in tag $ reduce' <$> gadgetZ bval qval - -instance (Reflects q z, ToInteger 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 (Reflects q z, ToInteger 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 (Reflects q z, ToInteger z, Random z) => Random (ZqBasic q z) where - random = let high = proxy value (Proxy::Proxy q) - 1 - in \g -> let (x,g') = randomR (0,high) g - in (ZqB x, g') - - randomR _ = error "randomR non-sensical for Zq types" - {-# INLINABLE random #-} - --- instance of Arbitrary -instance (Reflects q z, ToInteger z, Random z) => Arbitrary (ZqBasic q z) where - arbitrary = - let qval :: z = proxy value (Proxy::Proxy q) - in fromIntegral <$> choose (0, qval-1) - - 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/Crypto/Lol/Utils/GenArgs.hs b/Crypto/Lol/Utils/GenArgs.hs new file mode 100644 --- /dev/null +++ b/Crypto/Lol/Utils/GenArgs.hs @@ -0,0 +1,37 @@ +{-| +Module : Crypto.Lol.Utils.GenArgs +Description : Generate arguments for tests and benchmarks. +Copyright : (c) Eric Crockett, 2011-2017 + Chris Peikert, 2011-2017 +License : GPL-2 +Maintainer : ecrockett0@email.com +Stability : experimental +Portability : POSIX + + \( \def\C{\mathbb{C}} \) + +Classes used to generate arguments for tests and benchmarks. +This is analagous to 'Arbitrary' in quickcheck, except it can also be used +with criterion. +-} + +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} + +module Crypto.Lol.Utils.GenArgs where + +import Control.Monad.Random + +-- | Type of the output of a fully-applied function. +type family ResultOf a where + ResultOf (a -> b) = ResultOf b + ResultOf a = a + +-- | Generalization of 'Testable' from QuickCheck: generates function inputs +class GenArgs fun where + genArgs :: (MonadRandom rnd) => fun -> rnd (ResultOf fun) + +-- | Generate arguments to a function. +instance (Random a, GenArgs b) => GenArgs (a -> b) where + genArgs f = getRandom >>= (genArgs . f) diff --git a/Crypto/Lol/Utils/ShowType.hs b/Crypto/Lol/Utils/ShowType.hs new file mode 100644 --- /dev/null +++ b/Crypto/Lol/Utils/ShowType.hs @@ -0,0 +1,130 @@ +{-| +Module : Crypto.Lol.Utils.ShowType +Description : Pretty print type parameters. +Copyright : (c) Eric Crockett, 2011-2017 + Chris Peikert, 2011-2017 +License : GPL-2 +Maintainer : ecrockett0@email.com +Stability : experimental +Portability : POSIX + + \( \def\C{\mathbb{C}} \) + +Class for pretty-printing type parameters to tests and benchmarks +-} + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module Crypto.Lol.Utils.ShowType +(ArgType +,showType +,ShowType) where + +import Crypto.Lol (Int64,Fact,valueFact,Mod(..), Proxy(..), proxy, TrivGad, BaseBGad) +import Crypto.Lol.Reflects +import Crypto.Lol.Types.Unsafe.ZqBasic hiding (ZqB) + +import GHC.TypeLits + +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) + + +-- | Wrapper type for printing test/benchmark names +data ArgType (a :: k) = AT + +-- | Constraint synonym for printing test parameters +type ShowType a = Show (ArgType a) + +-- | Print a showable type argument +showType :: forall a . (Show (ArgType a)) => Proxy a -> String +showType _ = show (AT :: ArgType a) + +instance (KnownNat n) => Show (ArgType n) where + show _ = show $ natVal (Proxy::Proxy n) + +instance (Fact m) => Show (ArgType m) where + show _ = "F" ++ show (proxy valueFact (Proxy::Proxy m)) + +instance (Show (ArgType a), Show (ArgType b)) => Show (ArgType '(a,b)) where + show _ = "(" ++ show (AT :: ArgType a) ++ "," ++ show (AT :: ArgType b) ++ ")" + +data InternalList a + +instance (Show (ArgType (InternalList xs))) => Show (ArgType (xs :: [k])) where + show _ = "[" ++ show (AT :: ArgType (InternalList xs)) ++ "]" + +instance (Show (ArgType a), Show (ArgType (InternalList as))) => Show (ArgType (InternalList (a ': as))) where + show _ = show (AT :: ArgType a) ++ "," ++ show (AT :: ArgType (InternalList as)) + +instance Show (ArgType (InternalList '[])) where + show _ = "" + +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 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) + +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)) diff --git a/Crypto/Proto/Lol.hs b/Crypto/Proto/Lol.hs new file mode 100644 --- /dev/null +++ b/Crypto/Proto/Lol.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE BangPatterns, DeriveDataTypeable, DeriveGeneric, FlexibleInstances, MultiParamTypeClasses #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +module Crypto.Proto.Lol (protoInfo, fileDescriptorProto) where +import Prelude ((+), (/)) +import qualified Prelude as Prelude' +import qualified Data.Typeable as Prelude' +import qualified GHC.Generics as Prelude' +import qualified Data.Data as Prelude' +import qualified Text.ProtocolBuffers.Header as P' +import Text.DescriptorProtos.FileDescriptorProto (FileDescriptorProto) +import Text.ProtocolBuffers.Reflections (ProtoInfo) +import qualified Text.ProtocolBuffers.WireMessage as P' (wireGet,getFromBS) + +protoInfo :: ProtoInfo +protoInfo + = Prelude'.read + "ProtoInfo {protoMod = ProtoName {protobufName = FIName \".Lol\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [], baseName = MName \"Lol\"}, protoFilePath = [\"Crypto\",\"Proto\",\"Lol.hs\"], protoSource = \"Lol.proto\", extensionKeys = fromList [], messages = [DescriptorInfo {descName = ProtoName {protobufName = FIName \".Lol.LinearRq\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"Lol\"], baseName = MName \"LinearRq\"}, descFilePath = [\"Crypto\",\"Proto\",\"Lol\",\"LinearRq.hs\"], isGroup = False, fields = fromList [FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".Lol.LinearRq.e\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"Lol\",MName \"LinearRq\"], baseName' = FName \"e\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 1}, wireTag = WireTag {getWireTag = 8}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 13}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".Lol.LinearRq.r\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"Lol\",MName \"LinearRq\"], baseName' = FName \"r\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 2}, wireTag = WireTag {getWireTag = 16}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 13}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".Lol.LinearRq.coeffs\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"Lol\",MName \"LinearRq\"], baseName' = FName \"coeffs\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 3}, wireTag = WireTag {getWireTag = 26}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = True, mightPack = False, typeCode = FieldType {getFieldType = 11}, typeName = Just (ProtoName {protobufName = FIName \".Lol.RqProduct\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"Lol\"], baseName = MName \"RqProduct\"}), hsRawDefault = Nothing, hsDefault = Nothing}], descOneofs = fromList [], keys = fromList [], extRanges = [], knownKeys = fromList [], storeUnknown = False, lazyFields = False, makeLenses = False},DescriptorInfo {descName = ProtoName {protobufName = FIName \".Lol.R\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"Lol\"], baseName = MName \"R\"}, descFilePath = [\"Crypto\",\"Proto\",\"Lol\",\"R.hs\"], isGroup = False, fields = fromList [FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".Lol.R.m\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"Lol\",MName \"R\"], baseName' = FName \"m\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 1}, wireTag = WireTag {getWireTag = 8}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 13}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".Lol.R.xs\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"Lol\",MName \"R\"], baseName' = FName \"xs\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 2}, wireTag = WireTag {getWireTag = 16}, packedTag = Just (WireTag {getWireTag = 16},WireTag {getWireTag = 18}), wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = True, mightPack = True, typeCode = FieldType {getFieldType = 18}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing}], descOneofs = fromList [], keys = fromList [], extRanges = [], knownKeys = fromList [], storeUnknown = False, lazyFields = False, makeLenses = False},DescriptorInfo {descName = ProtoName {protobufName = FIName \".Lol.Rq1\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"Lol\"], baseName = MName \"Rq1\"}, descFilePath = [\"Crypto\",\"Proto\",\"Lol\",\"Rq1.hs\"], isGroup = False, fields = fromList [FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".Lol.Rq1.m\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"Lol\",MName \"Rq1\"], baseName' = FName \"m\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 1}, wireTag = WireTag {getWireTag = 8}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 13}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".Lol.Rq1.q\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"Lol\",MName \"Rq1\"], baseName' = FName \"q\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 2}, wireTag = WireTag {getWireTag = 16}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 4}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".Lol.Rq1.xs\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"Lol\",MName \"Rq1\"], baseName' = FName \"xs\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 3}, wireTag = WireTag {getWireTag = 24}, packedTag = Just (WireTag {getWireTag = 24},WireTag {getWireTag = 26}), wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = True, mightPack = True, typeCode = FieldType {getFieldType = 18}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing}], descOneofs = fromList [], keys = fromList [], extRanges = [], knownKeys = fromList [], storeUnknown = False, lazyFields = False, makeLenses = False},DescriptorInfo {descName = ProtoName {protobufName = FIName \".Lol.Kq1\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"Lol\"], baseName = MName \"Kq1\"}, descFilePath = [\"Crypto\",\"Proto\",\"Lol\",\"Kq1.hs\"], isGroup = False, fields = fromList [FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".Lol.Kq1.m\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"Lol\",MName \"Kq1\"], baseName' = FName \"m\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 1}, wireTag = WireTag {getWireTag = 8}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 13}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".Lol.Kq1.q\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"Lol\",MName \"Kq1\"], baseName' = FName \"q\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 2}, wireTag = WireTag {getWireTag = 16}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 4}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".Lol.Kq1.xs\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"Lol\",MName \"Kq1\"], baseName' = FName \"xs\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 3}, wireTag = WireTag {getWireTag = 25}, packedTag = Just (WireTag {getWireTag = 25},WireTag {getWireTag = 26}), wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = True, mightPack = True, typeCode = FieldType {getFieldType = 1}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing}], descOneofs = fromList [], keys = fromList [], extRanges = [], knownKeys = fromList [], storeUnknown = False, lazyFields = False, makeLenses = False},DescriptorInfo {descName = ProtoName {protobufName = FIName \".Lol.RqProduct\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"Lol\"], baseName = MName \"RqProduct\"}, descFilePath = [\"Crypto\",\"Proto\",\"Lol\",\"RqProduct.hs\"], isGroup = False, fields = fromList [FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".Lol.RqProduct.rqlist\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"Lol\",MName \"RqProduct\"], baseName' = FName \"rqlist\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 1}, wireTag = WireTag {getWireTag = 10}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = True, mightPack = False, typeCode = FieldType {getFieldType = 11}, typeName = Just (ProtoName {protobufName = FIName \".Lol.Rq1\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"Lol\"], baseName = MName \"Rq1\"}), hsRawDefault = Nothing, hsDefault = Nothing}], descOneofs = fromList [], keys = fromList [], extRanges = [], knownKeys = fromList [], storeUnknown = False, lazyFields = False, makeLenses = False},DescriptorInfo {descName = ProtoName {protobufName = FIName \".Lol.KqProduct\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"Lol\"], baseName = MName \"KqProduct\"}, descFilePath = [\"Crypto\",\"Proto\",\"Lol\",\"KqProduct.hs\"], isGroup = False, fields = fromList [FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".Lol.KqProduct.kqlist\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"Lol\",MName \"KqProduct\"], baseName' = FName \"kqlist\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 1}, wireTag = WireTag {getWireTag = 10}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = True, mightPack = False, typeCode = FieldType {getFieldType = 11}, typeName = Just (ProtoName {protobufName = FIName \".Lol.Kq1\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"Lol\"], baseName = MName \"Kq1\"}), hsRawDefault = Nothing, hsDefault = Nothing}], descOneofs = fromList [], keys = fromList [], extRanges = [], knownKeys = fromList [], storeUnknown = False, lazyFields = False, makeLenses = False},DescriptorInfo {descName = ProtoName {protobufName = FIName \".Lol.TypeRep\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"Lol\"], baseName = MName \"TypeRep\"}, descFilePath = [\"Crypto\",\"Proto\",\"Lol\",\"TypeRep.hs\"], isGroup = False, fields = fromList [FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".Lol.TypeRep.a\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"Lol\",MName \"TypeRep\"], baseName' = FName \"a\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 1}, wireTag = WireTag {getWireTag = 8}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 4}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".Lol.TypeRep.b\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"Lol\",MName \"TypeRep\"], baseName' = FName \"b\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 2}, wireTag = WireTag {getWireTag = 16}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 4}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing}], descOneofs = fromList [], keys = fromList [], extRanges = [], knownKeys = fromList [], storeUnknown = False, lazyFields = False, makeLenses = False}], enums = [], oneofs = [], knownKeyMap = fromList []}" + +fileDescriptorProto :: FileDescriptorProto +fileDescriptorProto + = P'.getFromBS (P'.wireGet 11) + (P'.pack + "\170\STX\n\tLol.proto\"@\n\bLinearRq\DC2\t\n\SOHe\CAN\SOH \STX(\r\DC2\t\n\SOHr\CAN\STX \STX(\r\DC2\RS\n\ACKcoeffs\CAN\ETX \ETX(\v2\SO.Lol.RqProduct\"\SUB\n\SOHR\DC2\t\n\SOHm\CAN\SOH \STX(\r\DC2\n\n\STXxs\CAN\STX \ETX(\DC2\"'\n\ETXRq1\DC2\t\n\SOHm\CAN\SOH \STX(\r\DC2\t\n\SOHq\CAN\STX \STX(\EOT\DC2\n\n\STXxs\CAN\ETX \ETX(\DC2\"'\n\ETXKq1\DC2\t\n\SOHm\CAN\SOH \STX(\r\DC2\t\n\SOHq\CAN\STX \STX(\EOT\DC2\n\n\STXxs\CAN\ETX \ETX(\SOH\"%\n\tRqProduct\DC2\CAN\n\ACKrqlist\CAN\SOH \ETX(\v2\b.Lol.Rq1\"%\n\tKqProduct\DC2\CAN\n\ACKkqlist\CAN\SOH \ETX(\v2\b.Lol.Kq1\"\US\n\aTypeRep\DC2\t\n\SOHa\CAN\SOH \STX(\EOT\DC2\t\n\SOHb\CAN\STX \STX(\EOT") diff --git a/Crypto/Proto/Lol/Kq1.hs b/Crypto/Proto/Lol/Kq1.hs new file mode 100644 --- /dev/null +++ b/Crypto/Proto/Lol/Kq1.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE BangPatterns, DeriveDataTypeable, DeriveGeneric, FlexibleInstances, MultiParamTypeClasses #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +module Crypto.Proto.Lol.Kq1 (Kq1(..)) where +import Prelude ((+), (/)) +import qualified Prelude as Prelude' +import qualified Data.Typeable as Prelude' +import qualified GHC.Generics as Prelude' +import qualified Data.Data as Prelude' +import qualified Text.ProtocolBuffers.Header as P' + +data Kq1 = Kq1{m :: !(P'.Word32), q :: !(P'.Word64), xs :: !(P'.Seq P'.Double)} + deriving (Prelude'.Show, Prelude'.Eq, Prelude'.Ord, Prelude'.Typeable, Prelude'.Data, Prelude'.Generic) + +instance P'.Mergeable Kq1 where + mergeAppend (Kq1 x'1 x'2 x'3) (Kq1 y'1 y'2 y'3) = Kq1 (P'.mergeAppend x'1 y'1) (P'.mergeAppend x'2 y'2) (P'.mergeAppend x'3 y'3) + +instance P'.Default Kq1 where + defaultValue = Kq1 P'.defaultValue P'.defaultValue P'.defaultValue + +instance P'.Wire Kq1 where + wireSize ft' self'@(Kq1 x'1 x'2 x'3) + = case ft' of + 10 -> calc'Size + 11 -> P'.prependMessageSize calc'Size + _ -> P'.wireSizeErr ft' self' + where + calc'Size = (P'.wireSizeReq 1 13 x'1 + P'.wireSizeReq 1 4 x'2 + P'.wireSizeRep 1 1 x'3) + wirePut ft' self'@(Kq1 x'1 x'2 x'3) + = case ft' of + 10 -> put'Fields + 11 -> do + P'.putSize (P'.wireSize 10 self') + put'Fields + _ -> P'.wirePutErr ft' self' + where + put'Fields + = do + P'.wirePutReq 8 13 x'1 + P'.wirePutReq 16 4 x'2 + P'.wirePutRep 25 1 x'3 + wireGet ft' + = case ft' of + 10 -> P'.getBareMessageWith update'Self + 11 -> P'.getMessageWith update'Self + _ -> P'.wireGetErr ft' + where + update'Self wire'Tag old'Self + = case wire'Tag of + 8 -> Prelude'.fmap (\ !new'Field -> old'Self{m = new'Field}) (P'.wireGet 13) + 16 -> Prelude'.fmap (\ !new'Field -> old'Self{q = new'Field}) (P'.wireGet 4) + 25 -> Prelude'.fmap (\ !new'Field -> old'Self{xs = P'.append (xs old'Self) new'Field}) (P'.wireGet 1) + 26 -> Prelude'.fmap (\ !new'Field -> old'Self{xs = P'.mergeAppend (xs old'Self) new'Field}) (P'.wireGetPacked 1) + _ -> let (field'Number, wire'Type) = P'.splitWireTag wire'Tag in P'.unknown field'Number wire'Type old'Self + +instance P'.MessageAPI msg' (msg' -> Kq1) Kq1 where + getVal m' f' = f' m' + +instance P'.GPB Kq1 + +instance P'.ReflectDescriptor Kq1 where + getMessageInfo _ = P'.GetMessageInfo (P'.fromDistinctAscList [8, 16]) (P'.fromDistinctAscList [8, 16, 25, 26]) + reflectDescriptorInfo _ + = Prelude'.read + "DescriptorInfo {descName = ProtoName {protobufName = FIName \".Lol.Kq1\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"Lol\"], baseName = MName \"Kq1\"}, descFilePath = [\"Crypto\",\"Proto\",\"Lol\",\"Kq1.hs\"], isGroup = False, fields = fromList [FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".Lol.Kq1.m\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"Lol\",MName \"Kq1\"], baseName' = FName \"m\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 1}, wireTag = WireTag {getWireTag = 8}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 13}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".Lol.Kq1.q\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"Lol\",MName \"Kq1\"], baseName' = FName \"q\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 2}, wireTag = WireTag {getWireTag = 16}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 4}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".Lol.Kq1.xs\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"Lol\",MName \"Kq1\"], baseName' = FName \"xs\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 3}, wireTag = WireTag {getWireTag = 25}, packedTag = Just (WireTag {getWireTag = 25},WireTag {getWireTag = 26}), wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = True, mightPack = True, typeCode = FieldType {getFieldType = 1}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing}], descOneofs = fromList [], keys = fromList [], extRanges = [], knownKeys = fromList [], storeUnknown = False, lazyFields = False, makeLenses = False}" + +instance P'.TextType Kq1 where + tellT = P'.tellSubMessage + getT = P'.getSubMessage + +instance P'.TextMsg Kq1 where + textPut msg + = do + P'.tellT "m" (m msg) + P'.tellT "q" (q msg) + P'.tellT "xs" (xs msg) + textGet + = do + mods <- P'.sepEndBy (P'.choice [parse'm, parse'q, parse'xs]) P'.spaces + Prelude'.return (Prelude'.foldl (\ v f -> f v) P'.defaultValue mods) + where + parse'm + = P'.try + (do + v <- P'.getT "m" + Prelude'.return (\ o -> o{m = v})) + parse'q + = P'.try + (do + v <- P'.getT "q" + Prelude'.return (\ o -> o{q = v})) + parse'xs + = P'.try + (do + v <- P'.getT "xs" + Prelude'.return (\ o -> o{xs = P'.append (xs o) v})) diff --git a/Crypto/Proto/Lol/KqProduct.hs b/Crypto/Proto/Lol/KqProduct.hs new file mode 100644 --- /dev/null +++ b/Crypto/Proto/Lol/KqProduct.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE BangPatterns, DeriveDataTypeable, DeriveGeneric, FlexibleInstances, MultiParamTypeClasses #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +module Crypto.Proto.Lol.KqProduct (KqProduct(..)) where +import Prelude ((+), (/)) +import qualified Prelude as Prelude' +import qualified Data.Typeable as Prelude' +import qualified GHC.Generics as Prelude' +import qualified Data.Data as Prelude' +import qualified Text.ProtocolBuffers.Header as P' +import qualified Crypto.Proto.Lol.Kq1 as Lol (Kq1) + +data KqProduct = KqProduct{kqlist :: !(P'.Seq Lol.Kq1)} + deriving (Prelude'.Show, Prelude'.Eq, Prelude'.Ord, Prelude'.Typeable, Prelude'.Data, Prelude'.Generic) + +instance P'.Mergeable KqProduct where + mergeAppend (KqProduct x'1) (KqProduct y'1) = KqProduct (P'.mergeAppend x'1 y'1) + +instance P'.Default KqProduct where + defaultValue = KqProduct P'.defaultValue + +instance P'.Wire KqProduct where + wireSize ft' self'@(KqProduct x'1) + = case ft' of + 10 -> calc'Size + 11 -> P'.prependMessageSize calc'Size + _ -> P'.wireSizeErr ft' self' + where + calc'Size = (P'.wireSizeRep 1 11 x'1) + wirePut ft' self'@(KqProduct x'1) + = case ft' of + 10 -> put'Fields + 11 -> do + P'.putSize (P'.wireSize 10 self') + put'Fields + _ -> P'.wirePutErr ft' self' + where + put'Fields + = do + P'.wirePutRep 10 11 x'1 + wireGet ft' + = case ft' of + 10 -> P'.getBareMessageWith update'Self + 11 -> P'.getMessageWith update'Self + _ -> P'.wireGetErr ft' + where + update'Self wire'Tag old'Self + = case wire'Tag of + 10 -> Prelude'.fmap (\ !new'Field -> old'Self{kqlist = P'.append (kqlist old'Self) new'Field}) (P'.wireGet 11) + _ -> let (field'Number, wire'Type) = P'.splitWireTag wire'Tag in P'.unknown field'Number wire'Type old'Self + +instance P'.MessageAPI msg' (msg' -> KqProduct) KqProduct where + getVal m' f' = f' m' + +instance P'.GPB KqProduct + +instance P'.ReflectDescriptor KqProduct where + getMessageInfo _ = P'.GetMessageInfo (P'.fromDistinctAscList []) (P'.fromDistinctAscList [10]) + reflectDescriptorInfo _ + = Prelude'.read + "DescriptorInfo {descName = ProtoName {protobufName = FIName \".Lol.KqProduct\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"Lol\"], baseName = MName \"KqProduct\"}, descFilePath = [\"Crypto\",\"Proto\",\"Lol\",\"KqProduct.hs\"], isGroup = False, fields = fromList [FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".Lol.KqProduct.kqlist\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"Lol\",MName \"KqProduct\"], baseName' = FName \"kqlist\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 1}, wireTag = WireTag {getWireTag = 10}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = True, mightPack = False, typeCode = FieldType {getFieldType = 11}, typeName = Just (ProtoName {protobufName = FIName \".Lol.Kq1\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"Lol\"], baseName = MName \"Kq1\"}), hsRawDefault = Nothing, hsDefault = Nothing}], descOneofs = fromList [], keys = fromList [], extRanges = [], knownKeys = fromList [], storeUnknown = False, lazyFields = False, makeLenses = False}" + +instance P'.TextType KqProduct where + tellT = P'.tellSubMessage + getT = P'.getSubMessage + +instance P'.TextMsg KqProduct where + textPut msg + = do + P'.tellT "kqlist" (kqlist msg) + textGet + = do + mods <- P'.sepEndBy (P'.choice [parse'kqlist]) P'.spaces + Prelude'.return (Prelude'.foldl (\ v f -> f v) P'.defaultValue mods) + where + parse'kqlist + = P'.try + (do + v <- P'.getT "kqlist" + Prelude'.return (\ o -> o{kqlist = P'.append (kqlist o) v})) diff --git a/Crypto/Proto/Lol/LinearRq.hs b/Crypto/Proto/Lol/LinearRq.hs new file mode 100644 --- /dev/null +++ b/Crypto/Proto/Lol/LinearRq.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE BangPatterns, DeriveDataTypeable, DeriveGeneric, FlexibleInstances, MultiParamTypeClasses #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +module Crypto.Proto.Lol.LinearRq (LinearRq(..)) where +import Prelude ((+), (/)) +import qualified Prelude as Prelude' +import qualified Data.Typeable as Prelude' +import qualified GHC.Generics as Prelude' +import qualified Data.Data as Prelude' +import qualified Text.ProtocolBuffers.Header as P' +import qualified Crypto.Proto.Lol.RqProduct as Lol (RqProduct) + +data LinearRq = LinearRq{e :: !(P'.Word32), r :: !(P'.Word32), coeffs :: !(P'.Seq Lol.RqProduct)} + deriving (Prelude'.Show, Prelude'.Eq, Prelude'.Ord, Prelude'.Typeable, Prelude'.Data, Prelude'.Generic) + +instance P'.Mergeable LinearRq where + mergeAppend (LinearRq x'1 x'2 x'3) (LinearRq y'1 y'2 y'3) + = LinearRq (P'.mergeAppend x'1 y'1) (P'.mergeAppend x'2 y'2) (P'.mergeAppend x'3 y'3) + +instance P'.Default LinearRq where + defaultValue = LinearRq P'.defaultValue P'.defaultValue P'.defaultValue + +instance P'.Wire LinearRq where + wireSize ft' self'@(LinearRq x'1 x'2 x'3) + = case ft' of + 10 -> calc'Size + 11 -> P'.prependMessageSize calc'Size + _ -> P'.wireSizeErr ft' self' + where + calc'Size = (P'.wireSizeReq 1 13 x'1 + P'.wireSizeReq 1 13 x'2 + P'.wireSizeRep 1 11 x'3) + wirePut ft' self'@(LinearRq x'1 x'2 x'3) + = case ft' of + 10 -> put'Fields + 11 -> do + P'.putSize (P'.wireSize 10 self') + put'Fields + _ -> P'.wirePutErr ft' self' + where + put'Fields + = do + P'.wirePutReq 8 13 x'1 + P'.wirePutReq 16 13 x'2 + P'.wirePutRep 26 11 x'3 + wireGet ft' + = case ft' of + 10 -> P'.getBareMessageWith update'Self + 11 -> P'.getMessageWith update'Self + _ -> P'.wireGetErr ft' + where + update'Self wire'Tag old'Self + = case wire'Tag of + 8 -> Prelude'.fmap (\ !new'Field -> old'Self{e = new'Field}) (P'.wireGet 13) + 16 -> Prelude'.fmap (\ !new'Field -> old'Self{r = new'Field}) (P'.wireGet 13) + 26 -> Prelude'.fmap (\ !new'Field -> old'Self{coeffs = P'.append (coeffs old'Self) new'Field}) (P'.wireGet 11) + _ -> let (field'Number, wire'Type) = P'.splitWireTag wire'Tag in P'.unknown field'Number wire'Type old'Self + +instance P'.MessageAPI msg' (msg' -> LinearRq) LinearRq where + getVal m' f' = f' m' + +instance P'.GPB LinearRq + +instance P'.ReflectDescriptor LinearRq where + getMessageInfo _ = P'.GetMessageInfo (P'.fromDistinctAscList [8, 16]) (P'.fromDistinctAscList [8, 16, 26]) + reflectDescriptorInfo _ + = Prelude'.read + "DescriptorInfo {descName = ProtoName {protobufName = FIName \".Lol.LinearRq\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"Lol\"], baseName = MName \"LinearRq\"}, descFilePath = [\"Crypto\",\"Proto\",\"Lol\",\"LinearRq.hs\"], isGroup = False, fields = fromList [FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".Lol.LinearRq.e\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"Lol\",MName \"LinearRq\"], baseName' = FName \"e\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 1}, wireTag = WireTag {getWireTag = 8}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 13}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".Lol.LinearRq.r\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"Lol\",MName \"LinearRq\"], baseName' = FName \"r\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 2}, wireTag = WireTag {getWireTag = 16}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 13}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".Lol.LinearRq.coeffs\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"Lol\",MName \"LinearRq\"], baseName' = FName \"coeffs\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 3}, wireTag = WireTag {getWireTag = 26}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = True, mightPack = False, typeCode = FieldType {getFieldType = 11}, typeName = Just (ProtoName {protobufName = FIName \".Lol.RqProduct\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"Lol\"], baseName = MName \"RqProduct\"}), hsRawDefault = Nothing, hsDefault = Nothing}], descOneofs = fromList [], keys = fromList [], extRanges = [], knownKeys = fromList [], storeUnknown = False, lazyFields = False, makeLenses = False}" + +instance P'.TextType LinearRq where + tellT = P'.tellSubMessage + getT = P'.getSubMessage + +instance P'.TextMsg LinearRq where + textPut msg + = do + P'.tellT "e" (e msg) + P'.tellT "r" (r msg) + P'.tellT "coeffs" (coeffs msg) + textGet + = do + mods <- P'.sepEndBy (P'.choice [parse'e, parse'r, parse'coeffs]) P'.spaces + Prelude'.return (Prelude'.foldl (\ v f -> f v) P'.defaultValue mods) + where + parse'e + = P'.try + (do + v <- P'.getT "e" + Prelude'.return (\ o -> o{e = v})) + parse'r + = P'.try + (do + v <- P'.getT "r" + Prelude'.return (\ o -> o{r = v})) + parse'coeffs + = P'.try + (do + v <- P'.getT "coeffs" + Prelude'.return (\ o -> o{coeffs = P'.append (coeffs o) v})) diff --git a/Crypto/Proto/Lol/R.hs b/Crypto/Proto/Lol/R.hs new file mode 100644 --- /dev/null +++ b/Crypto/Proto/Lol/R.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE BangPatterns, DeriveDataTypeable, DeriveGeneric, FlexibleInstances, MultiParamTypeClasses #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +module Crypto.Proto.Lol.R (R(..)) where +import Prelude ((+), (/)) +import qualified Prelude as Prelude' +import qualified Data.Typeable as Prelude' +import qualified GHC.Generics as Prelude' +import qualified Data.Data as Prelude' +import qualified Text.ProtocolBuffers.Header as P' + +data R = R{m :: !(P'.Word32), xs :: !(P'.Seq P'.Int64)} + deriving (Prelude'.Show, Prelude'.Eq, Prelude'.Ord, Prelude'.Typeable, Prelude'.Data, Prelude'.Generic) + +instance P'.Mergeable R where + mergeAppend (R x'1 x'2) (R y'1 y'2) = R (P'.mergeAppend x'1 y'1) (P'.mergeAppend x'2 y'2) + +instance P'.Default R where + defaultValue = R P'.defaultValue P'.defaultValue + +instance P'.Wire R where + wireSize ft' self'@(R x'1 x'2) + = case ft' of + 10 -> calc'Size + 11 -> P'.prependMessageSize calc'Size + _ -> P'.wireSizeErr ft' self' + where + calc'Size = (P'.wireSizeReq 1 13 x'1 + P'.wireSizeRep 1 18 x'2) + wirePut ft' self'@(R x'1 x'2) + = case ft' of + 10 -> put'Fields + 11 -> do + P'.putSize (P'.wireSize 10 self') + put'Fields + _ -> P'.wirePutErr ft' self' + where + put'Fields + = do + P'.wirePutReq 8 13 x'1 + P'.wirePutRep 16 18 x'2 + wireGet ft' + = case ft' of + 10 -> P'.getBareMessageWith update'Self + 11 -> P'.getMessageWith update'Self + _ -> P'.wireGetErr ft' + where + update'Self wire'Tag old'Self + = case wire'Tag of + 8 -> Prelude'.fmap (\ !new'Field -> old'Self{m = new'Field}) (P'.wireGet 13) + 16 -> Prelude'.fmap (\ !new'Field -> old'Self{xs = P'.append (xs old'Self) new'Field}) (P'.wireGet 18) + 18 -> Prelude'.fmap (\ !new'Field -> old'Self{xs = P'.mergeAppend (xs old'Self) new'Field}) (P'.wireGetPacked 18) + _ -> let (field'Number, wire'Type) = P'.splitWireTag wire'Tag in P'.unknown field'Number wire'Type old'Self + +instance P'.MessageAPI msg' (msg' -> R) R where + getVal m' f' = f' m' + +instance P'.GPB R + +instance P'.ReflectDescriptor R where + getMessageInfo _ = P'.GetMessageInfo (P'.fromDistinctAscList [8]) (P'.fromDistinctAscList [8, 16, 18]) + reflectDescriptorInfo _ + = Prelude'.read + "DescriptorInfo {descName = ProtoName {protobufName = FIName \".Lol.R\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"Lol\"], baseName = MName \"R\"}, descFilePath = [\"Crypto\",\"Proto\",\"Lol\",\"R.hs\"], isGroup = False, fields = fromList [FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".Lol.R.m\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"Lol\",MName \"R\"], baseName' = FName \"m\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 1}, wireTag = WireTag {getWireTag = 8}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 13}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".Lol.R.xs\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"Lol\",MName \"R\"], baseName' = FName \"xs\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 2}, wireTag = WireTag {getWireTag = 16}, packedTag = Just (WireTag {getWireTag = 16},WireTag {getWireTag = 18}), wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = True, mightPack = True, typeCode = FieldType {getFieldType = 18}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing}], descOneofs = fromList [], keys = fromList [], extRanges = [], knownKeys = fromList [], storeUnknown = False, lazyFields = False, makeLenses = False}" + +instance P'.TextType R where + tellT = P'.tellSubMessage + getT = P'.getSubMessage + +instance P'.TextMsg R where + textPut msg + = do + P'.tellT "m" (m msg) + P'.tellT "xs" (xs msg) + textGet + = do + mods <- P'.sepEndBy (P'.choice [parse'm, parse'xs]) P'.spaces + Prelude'.return (Prelude'.foldl (\ v f -> f v) P'.defaultValue mods) + where + parse'm + = P'.try + (do + v <- P'.getT "m" + Prelude'.return (\ o -> o{m = v})) + parse'xs + = P'.try + (do + v <- P'.getT "xs" + Prelude'.return (\ o -> o{xs = P'.append (xs o) v})) diff --git a/Crypto/Proto/Lol/Rq1.hs b/Crypto/Proto/Lol/Rq1.hs new file mode 100644 --- /dev/null +++ b/Crypto/Proto/Lol/Rq1.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE BangPatterns, DeriveDataTypeable, DeriveGeneric, FlexibleInstances, MultiParamTypeClasses #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +module Crypto.Proto.Lol.Rq1 (Rq1(..)) where +import Prelude ((+), (/)) +import qualified Prelude as Prelude' +import qualified Data.Typeable as Prelude' +import qualified GHC.Generics as Prelude' +import qualified Data.Data as Prelude' +import qualified Text.ProtocolBuffers.Header as P' + +data Rq1 = Rq1{m :: !(P'.Word32), q :: !(P'.Word64), xs :: !(P'.Seq P'.Int64)} + deriving (Prelude'.Show, Prelude'.Eq, Prelude'.Ord, Prelude'.Typeable, Prelude'.Data, Prelude'.Generic) + +instance P'.Mergeable Rq1 where + mergeAppend (Rq1 x'1 x'2 x'3) (Rq1 y'1 y'2 y'3) = Rq1 (P'.mergeAppend x'1 y'1) (P'.mergeAppend x'2 y'2) (P'.mergeAppend x'3 y'3) + +instance P'.Default Rq1 where + defaultValue = Rq1 P'.defaultValue P'.defaultValue P'.defaultValue + +instance P'.Wire Rq1 where + wireSize ft' self'@(Rq1 x'1 x'2 x'3) + = case ft' of + 10 -> calc'Size + 11 -> P'.prependMessageSize calc'Size + _ -> P'.wireSizeErr ft' self' + where + calc'Size = (P'.wireSizeReq 1 13 x'1 + P'.wireSizeReq 1 4 x'2 + P'.wireSizeRep 1 18 x'3) + wirePut ft' self'@(Rq1 x'1 x'2 x'3) + = case ft' of + 10 -> put'Fields + 11 -> do + P'.putSize (P'.wireSize 10 self') + put'Fields + _ -> P'.wirePutErr ft' self' + where + put'Fields + = do + P'.wirePutReq 8 13 x'1 + P'.wirePutReq 16 4 x'2 + P'.wirePutRep 24 18 x'3 + wireGet ft' + = case ft' of + 10 -> P'.getBareMessageWith update'Self + 11 -> P'.getMessageWith update'Self + _ -> P'.wireGetErr ft' + where + update'Self wire'Tag old'Self + = case wire'Tag of + 8 -> Prelude'.fmap (\ !new'Field -> old'Self{m = new'Field}) (P'.wireGet 13) + 16 -> Prelude'.fmap (\ !new'Field -> old'Self{q = new'Field}) (P'.wireGet 4) + 24 -> Prelude'.fmap (\ !new'Field -> old'Self{xs = P'.append (xs old'Self) new'Field}) (P'.wireGet 18) + 26 -> Prelude'.fmap (\ !new'Field -> old'Self{xs = P'.mergeAppend (xs old'Self) new'Field}) (P'.wireGetPacked 18) + _ -> let (field'Number, wire'Type) = P'.splitWireTag wire'Tag in P'.unknown field'Number wire'Type old'Self + +instance P'.MessageAPI msg' (msg' -> Rq1) Rq1 where + getVal m' f' = f' m' + +instance P'.GPB Rq1 + +instance P'.ReflectDescriptor Rq1 where + getMessageInfo _ = P'.GetMessageInfo (P'.fromDistinctAscList [8, 16]) (P'.fromDistinctAscList [8, 16, 24, 26]) + reflectDescriptorInfo _ + = Prelude'.read + "DescriptorInfo {descName = ProtoName {protobufName = FIName \".Lol.Rq1\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"Lol\"], baseName = MName \"Rq1\"}, descFilePath = [\"Crypto\",\"Proto\",\"Lol\",\"Rq1.hs\"], isGroup = False, fields = fromList [FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".Lol.Rq1.m\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"Lol\",MName \"Rq1\"], baseName' = FName \"m\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 1}, wireTag = WireTag {getWireTag = 8}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 13}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".Lol.Rq1.q\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"Lol\",MName \"Rq1\"], baseName' = FName \"q\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 2}, wireTag = WireTag {getWireTag = 16}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 4}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".Lol.Rq1.xs\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"Lol\",MName \"Rq1\"], baseName' = FName \"xs\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 3}, wireTag = WireTag {getWireTag = 24}, packedTag = Just (WireTag {getWireTag = 24},WireTag {getWireTag = 26}), wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = True, mightPack = True, typeCode = FieldType {getFieldType = 18}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing}], descOneofs = fromList [], keys = fromList [], extRanges = [], knownKeys = fromList [], storeUnknown = False, lazyFields = False, makeLenses = False}" + +instance P'.TextType Rq1 where + tellT = P'.tellSubMessage + getT = P'.getSubMessage + +instance P'.TextMsg Rq1 where + textPut msg + = do + P'.tellT "m" (m msg) + P'.tellT "q" (q msg) + P'.tellT "xs" (xs msg) + textGet + = do + mods <- P'.sepEndBy (P'.choice [parse'm, parse'q, parse'xs]) P'.spaces + Prelude'.return (Prelude'.foldl (\ v f -> f v) P'.defaultValue mods) + where + parse'm + = P'.try + (do + v <- P'.getT "m" + Prelude'.return (\ o -> o{m = v})) + parse'q + = P'.try + (do + v <- P'.getT "q" + Prelude'.return (\ o -> o{q = v})) + parse'xs + = P'.try + (do + v <- P'.getT "xs" + Prelude'.return (\ o -> o{xs = P'.append (xs o) v})) diff --git a/Crypto/Proto/Lol/RqProduct.hs b/Crypto/Proto/Lol/RqProduct.hs new file mode 100644 --- /dev/null +++ b/Crypto/Proto/Lol/RqProduct.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE BangPatterns, DeriveDataTypeable, DeriveGeneric, FlexibleInstances, MultiParamTypeClasses #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +module Crypto.Proto.Lol.RqProduct (RqProduct(..)) where +import Prelude ((+), (/)) +import qualified Prelude as Prelude' +import qualified Data.Typeable as Prelude' +import qualified GHC.Generics as Prelude' +import qualified Data.Data as Prelude' +import qualified Text.ProtocolBuffers.Header as P' +import qualified Crypto.Proto.Lol.Rq1 as Lol (Rq1) + +data RqProduct = RqProduct{rqlist :: !(P'.Seq Lol.Rq1)} + deriving (Prelude'.Show, Prelude'.Eq, Prelude'.Ord, Prelude'.Typeable, Prelude'.Data, Prelude'.Generic) + +instance P'.Mergeable RqProduct where + mergeAppend (RqProduct x'1) (RqProduct y'1) = RqProduct (P'.mergeAppend x'1 y'1) + +instance P'.Default RqProduct where + defaultValue = RqProduct P'.defaultValue + +instance P'.Wire RqProduct where + wireSize ft' self'@(RqProduct x'1) + = case ft' of + 10 -> calc'Size + 11 -> P'.prependMessageSize calc'Size + _ -> P'.wireSizeErr ft' self' + where + calc'Size = (P'.wireSizeRep 1 11 x'1) + wirePut ft' self'@(RqProduct x'1) + = case ft' of + 10 -> put'Fields + 11 -> do + P'.putSize (P'.wireSize 10 self') + put'Fields + _ -> P'.wirePutErr ft' self' + where + put'Fields + = do + P'.wirePutRep 10 11 x'1 + wireGet ft' + = case ft' of + 10 -> P'.getBareMessageWith update'Self + 11 -> P'.getMessageWith update'Self + _ -> P'.wireGetErr ft' + where + update'Self wire'Tag old'Self + = case wire'Tag of + 10 -> Prelude'.fmap (\ !new'Field -> old'Self{rqlist = P'.append (rqlist old'Self) new'Field}) (P'.wireGet 11) + _ -> let (field'Number, wire'Type) = P'.splitWireTag wire'Tag in P'.unknown field'Number wire'Type old'Self + +instance P'.MessageAPI msg' (msg' -> RqProduct) RqProduct where + getVal m' f' = f' m' + +instance P'.GPB RqProduct + +instance P'.ReflectDescriptor RqProduct where + getMessageInfo _ = P'.GetMessageInfo (P'.fromDistinctAscList []) (P'.fromDistinctAscList [10]) + reflectDescriptorInfo _ + = Prelude'.read + "DescriptorInfo {descName = ProtoName {protobufName = FIName \".Lol.RqProduct\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"Lol\"], baseName = MName \"RqProduct\"}, descFilePath = [\"Crypto\",\"Proto\",\"Lol\",\"RqProduct.hs\"], isGroup = False, fields = fromList [FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".Lol.RqProduct.rqlist\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"Lol\",MName \"RqProduct\"], baseName' = FName \"rqlist\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 1}, wireTag = WireTag {getWireTag = 10}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = True, mightPack = False, typeCode = FieldType {getFieldType = 11}, typeName = Just (ProtoName {protobufName = FIName \".Lol.Rq1\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"Lol\"], baseName = MName \"Rq1\"}), hsRawDefault = Nothing, hsDefault = Nothing}], descOneofs = fromList [], keys = fromList [], extRanges = [], knownKeys = fromList [], storeUnknown = False, lazyFields = False, makeLenses = False}" + +instance P'.TextType RqProduct where + tellT = P'.tellSubMessage + getT = P'.getSubMessage + +instance P'.TextMsg RqProduct where + textPut msg + = do + P'.tellT "rqlist" (rqlist msg) + textGet + = do + mods <- P'.sepEndBy (P'.choice [parse'rqlist]) P'.spaces + Prelude'.return (Prelude'.foldl (\ v f -> f v) P'.defaultValue mods) + where + parse'rqlist + = P'.try + (do + v <- P'.getT "rqlist" + Prelude'.return (\ o -> o{rqlist = P'.append (rqlist o) v})) diff --git a/Crypto/Proto/Lol/TypeRep.hs b/Crypto/Proto/Lol/TypeRep.hs new file mode 100644 --- /dev/null +++ b/Crypto/Proto/Lol/TypeRep.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE BangPatterns, DeriveDataTypeable, DeriveGeneric, FlexibleInstances, MultiParamTypeClasses #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +module Crypto.Proto.Lol.TypeRep (TypeRep(..)) where +import Prelude ((+), (/)) +import qualified Prelude as Prelude' +import qualified Data.Typeable as Prelude' +import qualified GHC.Generics as Prelude' +import qualified Data.Data as Prelude' +import qualified Text.ProtocolBuffers.Header as P' + +data TypeRep = TypeRep{a :: !(P'.Word64), b :: !(P'.Word64)} + deriving (Prelude'.Show, Prelude'.Eq, Prelude'.Ord, Prelude'.Typeable, Prelude'.Data, Prelude'.Generic) + +instance P'.Mergeable TypeRep where + mergeAppend (TypeRep x'1 x'2) (TypeRep y'1 y'2) = TypeRep (P'.mergeAppend x'1 y'1) (P'.mergeAppend x'2 y'2) + +instance P'.Default TypeRep where + defaultValue = TypeRep P'.defaultValue P'.defaultValue + +instance P'.Wire TypeRep where + wireSize ft' self'@(TypeRep x'1 x'2) + = case ft' of + 10 -> calc'Size + 11 -> P'.prependMessageSize calc'Size + _ -> P'.wireSizeErr ft' self' + where + calc'Size = (P'.wireSizeReq 1 4 x'1 + P'.wireSizeReq 1 4 x'2) + wirePut ft' self'@(TypeRep x'1 x'2) + = case ft' of + 10 -> put'Fields + 11 -> do + P'.putSize (P'.wireSize 10 self') + put'Fields + _ -> P'.wirePutErr ft' self' + where + put'Fields + = do + P'.wirePutReq 8 4 x'1 + P'.wirePutReq 16 4 x'2 + wireGet ft' + = case ft' of + 10 -> P'.getBareMessageWith update'Self + 11 -> P'.getMessageWith update'Self + _ -> P'.wireGetErr ft' + where + update'Self wire'Tag old'Self + = case wire'Tag of + 8 -> Prelude'.fmap (\ !new'Field -> old'Self{a = new'Field}) (P'.wireGet 4) + 16 -> Prelude'.fmap (\ !new'Field -> old'Self{b = new'Field}) (P'.wireGet 4) + _ -> let (field'Number, wire'Type) = P'.splitWireTag wire'Tag in P'.unknown field'Number wire'Type old'Self + +instance P'.MessageAPI msg' (msg' -> TypeRep) TypeRep where + getVal m' f' = f' m' + +instance P'.GPB TypeRep + +instance P'.ReflectDescriptor TypeRep where + getMessageInfo _ = P'.GetMessageInfo (P'.fromDistinctAscList [8, 16]) (P'.fromDistinctAscList [8, 16]) + reflectDescriptorInfo _ + = Prelude'.read + "DescriptorInfo {descName = ProtoName {protobufName = FIName \".Lol.TypeRep\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"Lol\"], baseName = MName \"TypeRep\"}, descFilePath = [\"Crypto\",\"Proto\",\"Lol\",\"TypeRep.hs\"], isGroup = False, fields = fromList [FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".Lol.TypeRep.a\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"Lol\",MName \"TypeRep\"], baseName' = FName \"a\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 1}, wireTag = WireTag {getWireTag = 8}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 4}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".Lol.TypeRep.b\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"Lol\",MName \"TypeRep\"], baseName' = FName \"b\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 2}, wireTag = WireTag {getWireTag = 16}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 4}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing}], descOneofs = fromList [], keys = fromList [], extRanges = [], knownKeys = fromList [], storeUnknown = False, lazyFields = False, makeLenses = False}" + +instance P'.TextType TypeRep where + tellT = P'.tellSubMessage + getT = P'.getSubMessage + +instance P'.TextMsg TypeRep where + textPut msg + = do + P'.tellT "a" (a msg) + P'.tellT "b" (b msg) + textGet + = do + mods <- P'.sepEndBy (P'.choice [parse'a, parse'b]) P'.spaces + Prelude'.return (Prelude'.foldl (\ v f -> f v) P'.defaultValue mods) + where + parse'a + = P'.try + (do + v <- P'.getT "a" + Prelude'.return (\ o -> o{a = v})) + parse'b + = P'.try + (do + v <- P'.getT "b" + Prelude'.return (\ o -> o{b = v})) diff --git a/Crypto/Proto/RLWE.hs b/Crypto/Proto/RLWE.hs --- a/Crypto/Proto/RLWE.hs +++ b/Crypto/Proto/RLWE.hs @@ -14,10 +14,10 @@ protoInfo :: ProtoInfo protoInfo = Prelude'.read - "ProtoInfo {protoMod = ProtoName {protobufName = FIName \".RLWE\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [], baseName = MName \"RLWE\"}, protoFilePath = [\"Crypto\",\"Proto\",\"RLWE.hs\"], protoSource = \"RLWE.proto\", extensionKeys = fromList [], messages = [DescriptorInfo {descName = ProtoName {protobufName = FIName \".RLWE.SampleCont\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"RLWE\"], baseName = MName \"SampleCont\"}, descFilePath = [\"Crypto\",\"Proto\",\"RLWE\",\"SampleCont.hs\"], isGroup = False, fields = fromList [FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".RLWE.SampleCont.a\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"RLWE\",MName \"SampleCont\"], baseName' = FName \"a\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 1}, wireTag = WireTag {getWireTag = 10}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 11}, typeName = Just (ProtoName {protobufName = FIName \".RLWE.Rq\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"RLWE\"], baseName = MName \"Rq\"}), hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".RLWE.SampleCont.b\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"RLWE\",MName \"SampleCont\"], baseName' = FName \"b\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 2}, wireTag = WireTag {getWireTag = 18}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 11}, typeName = Just (ProtoName {protobufName = FIName \".RLWE.Kq\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"RLWE\"], baseName = MName \"Kq\"}), hsRawDefault = Nothing, hsDefault = Nothing}], descOneofs = fromList [], keys = fromList [], extRanges = [], knownKeys = fromList [], storeUnknown = False, lazyFields = False, makeLenses = False},DescriptorInfo {descName = ProtoName {protobufName = FIName \".RLWE.SampleDisc\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"RLWE\"], baseName = MName \"SampleDisc\"}, descFilePath = [\"Crypto\",\"Proto\",\"RLWE\",\"SampleDisc.hs\"], isGroup = False, fields = fromList [FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".RLWE.SampleDisc.a\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"RLWE\",MName \"SampleDisc\"], baseName' = FName \"a\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 1}, wireTag = WireTag {getWireTag = 10}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 11}, typeName = Just (ProtoName {protobufName = FIName \".RLWE.Rq\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"RLWE\"], baseName = MName \"Rq\"}), hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".RLWE.SampleDisc.b\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"RLWE\",MName \"SampleDisc\"], baseName' = FName \"b\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 2}, wireTag = WireTag {getWireTag = 18}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 11}, typeName = Just (ProtoName {protobufName = FIName \".RLWE.Rq\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"RLWE\"], baseName = MName \"Rq\"}), hsRawDefault = Nothing, hsDefault = Nothing}], descOneofs = fromList [], keys = fromList [], extRanges = [], knownKeys = fromList [], storeUnknown = False, lazyFields = False, makeLenses = False},DescriptorInfo {descName = ProtoName {protobufName = FIName \".RLWE.SampleRLWR\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"RLWE\"], baseName = MName \"SampleRLWR\"}, descFilePath = [\"Crypto\",\"Proto\",\"RLWE\",\"SampleRLWR.hs\"], isGroup = False, fields = fromList [FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".RLWE.SampleRLWR.a\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"RLWE\",MName \"SampleRLWR\"], baseName' = FName \"a\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 1}, wireTag = WireTag {getWireTag = 10}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 11}, typeName = Just (ProtoName {protobufName = FIName \".RLWE.Rq\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"RLWE\"], baseName = MName \"Rq\"}), hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".RLWE.SampleRLWR.b\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"RLWE\",MName \"SampleRLWR\"], baseName' = FName \"b\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 2}, wireTag = WireTag {getWireTag = 18}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 11}, typeName = Just (ProtoName {protobufName = FIName \".RLWE.Rq\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"RLWE\"], baseName = MName \"Rq\"}), hsRawDefault = Nothing, hsDefault = Nothing}], descOneofs = fromList [], keys = fromList [], extRanges = [], knownKeys = fromList [], storeUnknown = False, lazyFields = False, makeLenses = False},DescriptorInfo {descName = ProtoName {protobufName = FIName \".RLWE.Rq\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"RLWE\"], baseName = MName \"Rq\"}, descFilePath = [\"Crypto\",\"Proto\",\"RLWE\",\"Rq.hs\"], isGroup = False, fields = fromList [FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".RLWE.Rq.m\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"RLWE\",MName \"Rq\"], baseName' = FName \"m\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 1}, wireTag = WireTag {getWireTag = 8}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 13}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".RLWE.Rq.q\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"RLWE\",MName \"Rq\"], baseName' = FName \"q\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 2}, wireTag = WireTag {getWireTag = 16}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 4}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".RLWE.Rq.xs\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"RLWE\",MName \"Rq\"], baseName' = FName \"xs\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 3}, wireTag = WireTag {getWireTag = 24}, packedTag = Just (WireTag {getWireTag = 24},WireTag {getWireTag = 26}), wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = True, mightPack = True, typeCode = FieldType {getFieldType = 18}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing}], descOneofs = fromList [], keys = fromList [], extRanges = [], knownKeys = fromList [], storeUnknown = False, lazyFields = False, makeLenses = False},DescriptorInfo {descName = ProtoName {protobufName = FIName \".RLWE.Kq\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"RLWE\"], baseName = MName \"Kq\"}, descFilePath = [\"Crypto\",\"Proto\",\"RLWE\",\"Kq.hs\"], isGroup = False, fields = fromList [FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".RLWE.Kq.m\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"RLWE\",MName \"Kq\"], baseName' = FName \"m\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 1}, wireTag = WireTag {getWireTag = 8}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 13}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".RLWE.Kq.q\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"RLWE\",MName \"Kq\"], baseName' = FName \"q\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 2}, wireTag = WireTag {getWireTag = 16}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 4}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".RLWE.Kq.xs\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"RLWE\",MName \"Kq\"], baseName' = FName \"xs\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 3}, wireTag = WireTag {getWireTag = 25}, packedTag = Just (WireTag {getWireTag = 25},WireTag {getWireTag = 26}), wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = True, mightPack = True, typeCode = FieldType {getFieldType = 1}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing}], descOneofs = fromList [], keys = fromList [], extRanges = [], knownKeys = fromList [], storeUnknown = False, lazyFields = False, makeLenses = False}], enums = [], oneofs = [], knownKeyMap = fromList []}" + "ProtoInfo {protoMod = ProtoName {protobufName = FIName \".RLWE\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [], baseName = MName \"RLWE\"}, protoFilePath = [\"Crypto\",\"Proto\",\"RLWE.hs\"], protoSource = \"RLWE.proto\", extensionKeys = fromList [], messages = [DescriptorInfo {descName = ProtoName {protobufName = FIName \".RLWE.SampleCont1\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"RLWE\"], baseName = MName \"SampleCont1\"}, descFilePath = [\"Crypto\",\"Proto\",\"RLWE\",\"SampleCont1.hs\"], isGroup = False, fields = fromList [FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".RLWE.SampleCont1.a\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"RLWE\",MName \"SampleCont1\"], baseName' = FName \"a\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 1}, wireTag = WireTag {getWireTag = 10}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 11}, typeName = Just (ProtoName {protobufName = FIName \".Lol.Rq1\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"Lol\"], baseName = MName \"Rq1\"}), hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".RLWE.SampleCont1.b\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"RLWE\",MName \"SampleCont1\"], baseName' = FName \"b\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 2}, wireTag = WireTag {getWireTag = 18}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 11}, typeName = Just (ProtoName {protobufName = FIName \".Lol.Kq1\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"Lol\"], baseName = MName \"Kq1\"}), hsRawDefault = Nothing, hsDefault = Nothing}], descOneofs = fromList [], keys = fromList [], extRanges = [], knownKeys = fromList [], storeUnknown = False, lazyFields = False, makeLenses = False},DescriptorInfo {descName = ProtoName {protobufName = FIName \".RLWE.SampleDisc1\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"RLWE\"], baseName = MName \"SampleDisc1\"}, descFilePath = [\"Crypto\",\"Proto\",\"RLWE\",\"SampleDisc1.hs\"], isGroup = False, fields = fromList [FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".RLWE.SampleDisc1.a\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"RLWE\",MName \"SampleDisc1\"], baseName' = FName \"a\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 1}, wireTag = WireTag {getWireTag = 10}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 11}, typeName = Just (ProtoName {protobufName = FIName \".Lol.Rq1\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"Lol\"], baseName = MName \"Rq1\"}), hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".RLWE.SampleDisc1.b\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"RLWE\",MName \"SampleDisc1\"], baseName' = FName \"b\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 2}, wireTag = WireTag {getWireTag = 18}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 11}, typeName = Just (ProtoName {protobufName = FIName \".Lol.Rq1\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"Lol\"], baseName = MName \"Rq1\"}), hsRawDefault = Nothing, hsDefault = Nothing}], descOneofs = fromList [], keys = fromList [], extRanges = [], knownKeys = fromList [], storeUnknown = False, lazyFields = False, makeLenses = False},DescriptorInfo {descName = ProtoName {protobufName = FIName \".RLWE.SampleRLWR1\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"RLWE\"], baseName = MName \"SampleRLWR1\"}, descFilePath = [\"Crypto\",\"Proto\",\"RLWE\",\"SampleRLWR1.hs\"], isGroup = False, fields = fromList [FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".RLWE.SampleRLWR1.a\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"RLWE\",MName \"SampleRLWR1\"], baseName' = FName \"a\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 1}, wireTag = WireTag {getWireTag = 10}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 11}, typeName = Just (ProtoName {protobufName = FIName \".Lol.Rq1\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"Lol\"], baseName = MName \"Rq1\"}), hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".RLWE.SampleRLWR1.b\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"RLWE\",MName \"SampleRLWR1\"], baseName' = FName \"b\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 2}, wireTag = WireTag {getWireTag = 18}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 11}, typeName = Just (ProtoName {protobufName = FIName \".Lol.Rq1\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"Lol\"], baseName = MName \"Rq1\"}), hsRawDefault = Nothing, hsDefault = Nothing}], descOneofs = fromList [], keys = fromList [], extRanges = [], knownKeys = fromList [], storeUnknown = False, lazyFields = False, makeLenses = False},DescriptorInfo {descName = ProtoName {protobufName = FIName \".RLWE.SampleCont\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"RLWE\"], baseName = MName \"SampleCont\"}, descFilePath = [\"Crypto\",\"Proto\",\"RLWE\",\"SampleCont.hs\"], isGroup = False, fields = fromList [FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".RLWE.SampleCont.a\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"RLWE\",MName \"SampleCont\"], baseName' = FName \"a\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 1}, wireTag = WireTag {getWireTag = 10}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 11}, typeName = Just (ProtoName {protobufName = FIName \".Lol.RqProduct\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"Lol\"], baseName = MName \"RqProduct\"}), hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".RLWE.SampleCont.b\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"RLWE\",MName \"SampleCont\"], baseName' = FName \"b\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 2}, wireTag = WireTag {getWireTag = 18}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 11}, typeName = Just (ProtoName {protobufName = FIName \".Lol.KqProduct\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"Lol\"], baseName = MName \"KqProduct\"}), hsRawDefault = Nothing, hsDefault = Nothing}], descOneofs = fromList [], keys = fromList [], extRanges = [], knownKeys = fromList [], storeUnknown = False, lazyFields = False, makeLenses = False},DescriptorInfo {descName = ProtoName {protobufName = FIName \".RLWE.SampleDisc\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"RLWE\"], baseName = MName \"SampleDisc\"}, descFilePath = [\"Crypto\",\"Proto\",\"RLWE\",\"SampleDisc.hs\"], isGroup = False, fields = fromList [FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".RLWE.SampleDisc.a\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"RLWE\",MName \"SampleDisc\"], baseName' = FName \"a\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 1}, wireTag = WireTag {getWireTag = 10}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 11}, typeName = Just (ProtoName {protobufName = FIName \".Lol.RqProduct\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"Lol\"], baseName = MName \"RqProduct\"}), hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".RLWE.SampleDisc.b\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"RLWE\",MName \"SampleDisc\"], baseName' = FName \"b\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 2}, wireTag = WireTag {getWireTag = 18}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 11}, typeName = Just (ProtoName {protobufName = FIName \".Lol.RqProduct\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"Lol\"], baseName = MName \"RqProduct\"}), hsRawDefault = Nothing, hsDefault = Nothing}], descOneofs = fromList [], keys = fromList [], extRanges = [], knownKeys = fromList [], storeUnknown = False, lazyFields = False, makeLenses = False},DescriptorInfo {descName = ProtoName {protobufName = FIName \".RLWE.SampleRLWR\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"RLWE\"], baseName = MName \"SampleRLWR\"}, descFilePath = [\"Crypto\",\"Proto\",\"RLWE\",\"SampleRLWR.hs\"], isGroup = False, fields = fromList [FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".RLWE.SampleRLWR.a\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"RLWE\",MName \"SampleRLWR\"], baseName' = FName \"a\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 1}, wireTag = WireTag {getWireTag = 10}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 11}, typeName = Just (ProtoName {protobufName = FIName \".Lol.RqProduct\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"Lol\"], baseName = MName \"RqProduct\"}), hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".RLWE.SampleRLWR.b\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"RLWE\",MName \"SampleRLWR\"], baseName' = FName \"b\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 2}, wireTag = WireTag {getWireTag = 18}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 11}, typeName = Just (ProtoName {protobufName = FIName \".Lol.RqProduct\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"Lol\"], baseName = MName \"RqProduct\"}), hsRawDefault = Nothing, hsDefault = Nothing}], descOneofs = fromList [], keys = fromList [], extRanges = [], knownKeys = fromList [], storeUnknown = False, lazyFields = False, makeLenses = False}], enums = [], oneofs = [], knownKeyMap = fromList []}" fileDescriptorProto :: FileDescriptorProto fileDescriptorProto = P'.getFromBS (P'.wireGet 11) (P'.pack - "\132\STX\n\nRLWE.proto\"6\n\nSampleCont\DC2\DC3\n\SOHa\CAN\SOH \STX(\v2\b.RLWE.Rq\DC2\DC3\n\SOHb\CAN\STX \STX(\v2\b.RLWE.Kq\"6\n\nSampleDisc\DC2\DC3\n\SOHa\CAN\SOH \STX(\v2\b.RLWE.Rq\DC2\DC3\n\SOHb\CAN\STX \STX(\v2\b.RLWE.Rq\"6\n\nSampleRLWR\DC2\DC3\n\SOHa\CAN\SOH \STX(\v2\b.RLWE.Rq\DC2\DC3\n\SOHb\CAN\STX \STX(\v2\b.RLWE.Rq\"&\n\STXRq\DC2\t\n\SOHm\CAN\SOH \STX(\r\DC2\t\n\SOHq\CAN\STX \STX(\EOT\DC2\n\n\STXxs\CAN\ETX \ETX(\DC2\"&\n\STXKq\DC2\t\n\SOHm\CAN\SOH \STX(\r\DC2\t\n\SOHq\CAN\STX \STX(\EOT\DC2\n\n\STXxs\CAN\ETX \ETX(\SOH") + "\142\ETX\n\nRLWE.proto\SUB\tLol.proto\"7\n\vSampleCont1\DC2\DC3\n\SOHa\CAN\SOH \STX(\v2\b.Lol.Rq1\DC2\DC3\n\SOHb\CAN\STX \STX(\v2\b.Lol.Kq1\"7\n\vSampleDisc1\DC2\DC3\n\SOHa\CAN\SOH \STX(\v2\b.Lol.Rq1\DC2\DC3\n\SOHb\CAN\STX \STX(\v2\b.Lol.Rq1\"7\n\vSampleRLWR1\DC2\DC3\n\SOHa\CAN\SOH \STX(\v2\b.Lol.Rq1\DC2\DC3\n\SOHb\CAN\STX \STX(\v2\b.Lol.Rq1\"B\n\nSampleCont\DC2\EM\n\SOHa\CAN\SOH \STX(\v2\SO.Lol.RqProduct\DC2\EM\n\SOHb\CAN\STX \STX(\v2\SO.Lol.KqProduct\"B\n\nSampleDisc\DC2\EM\n\SOHa\CAN\SOH \STX(\v2\SO.Lol.RqProduct\DC2\EM\n\SOHb\CAN\STX \STX(\v2\SO.Lol.RqProduct\"B\n\nSampleRLWR\DC2\EM\n\SOHa\CAN\SOH \STX(\v2\SO.Lol.RqProduct\DC2\EM\n\SOHb\CAN\STX \STX(\v2\SO.Lol.RqProduct") diff --git a/Crypto/Proto/RLWE/Kq.hs b/Crypto/Proto/RLWE/Kq.hs deleted file mode 100644 --- a/Crypto/Proto/RLWE/Kq.hs +++ /dev/null @@ -1,95 +0,0 @@ -{-# LANGUAGE BangPatterns, DeriveDataTypeable, DeriveGeneric, FlexibleInstances, MultiParamTypeClasses #-} -{-# OPTIONS_GHC -fno-warn-unused-imports #-} -module Crypto.Proto.RLWE.Kq (Kq(..)) where -import Prelude ((+), (/)) -import qualified Prelude as Prelude' -import qualified Data.Typeable as Prelude' -import qualified GHC.Generics as Prelude' -import qualified Data.Data as Prelude' -import qualified Text.ProtocolBuffers.Header as P' - -data Kq = Kq{m :: !(P'.Word32), q :: !(P'.Word64), xs :: !(P'.Seq P'.Double)} - deriving (Prelude'.Show, Prelude'.Eq, Prelude'.Ord, Prelude'.Typeable, Prelude'.Data, Prelude'.Generic) - -instance P'.Mergeable Kq where - mergeAppend (Kq x'1 x'2 x'3) (Kq y'1 y'2 y'3) = Kq (P'.mergeAppend x'1 y'1) (P'.mergeAppend x'2 y'2) (P'.mergeAppend x'3 y'3) - -instance P'.Default Kq where - defaultValue = Kq P'.defaultValue P'.defaultValue P'.defaultValue - -instance P'.Wire Kq where - wireSize ft' self'@(Kq x'1 x'2 x'3) - = case ft' of - 10 -> calc'Size - 11 -> P'.prependMessageSize calc'Size - _ -> P'.wireSizeErr ft' self' - where - calc'Size = (P'.wireSizeReq 1 13 x'1 + P'.wireSizeReq 1 4 x'2 + P'.wireSizeRep 1 1 x'3) - wirePut ft' self'@(Kq x'1 x'2 x'3) - = case ft' of - 10 -> put'Fields - 11 -> do - P'.putSize (P'.wireSize 10 self') - put'Fields - _ -> P'.wirePutErr ft' self' - where - put'Fields - = do - P'.wirePutReq 8 13 x'1 - P'.wirePutReq 16 4 x'2 - P'.wirePutRep 25 1 x'3 - wireGet ft' - = case ft' of - 10 -> P'.getBareMessageWith update'Self - 11 -> P'.getMessageWith update'Self - _ -> P'.wireGetErr ft' - where - update'Self wire'Tag old'Self - = case wire'Tag of - 8 -> Prelude'.fmap (\ !new'Field -> old'Self{m = new'Field}) (P'.wireGet 13) - 16 -> Prelude'.fmap (\ !new'Field -> old'Self{q = new'Field}) (P'.wireGet 4) - 25 -> Prelude'.fmap (\ !new'Field -> old'Self{xs = P'.append (xs old'Self) new'Field}) (P'.wireGet 1) - 26 -> Prelude'.fmap (\ !new'Field -> old'Self{xs = P'.mergeAppend (xs old'Self) new'Field}) (P'.wireGetPacked 1) - _ -> let (field'Number, wire'Type) = P'.splitWireTag wire'Tag in P'.unknown field'Number wire'Type old'Self - -instance P'.MessageAPI msg' (msg' -> Kq) Kq where - getVal m' f' = f' m' - -instance P'.GPB Kq - -instance P'.ReflectDescriptor Kq where - getMessageInfo _ = P'.GetMessageInfo (P'.fromDistinctAscList [8, 16]) (P'.fromDistinctAscList [8, 16, 25, 26]) - reflectDescriptorInfo _ - = Prelude'.read - "DescriptorInfo {descName = ProtoName {protobufName = FIName \".RLWE.Kq\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"RLWE\"], baseName = MName \"Kq\"}, descFilePath = [\"Crypto\",\"Proto\",\"RLWE\",\"Kq.hs\"], isGroup = False, fields = fromList [FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".RLWE.Kq.m\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"RLWE\",MName \"Kq\"], baseName' = FName \"m\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 1}, wireTag = WireTag {getWireTag = 8}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 13}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".RLWE.Kq.q\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"RLWE\",MName \"Kq\"], baseName' = FName \"q\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 2}, wireTag = WireTag {getWireTag = 16}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 4}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".RLWE.Kq.xs\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"RLWE\",MName \"Kq\"], baseName' = FName \"xs\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 3}, wireTag = WireTag {getWireTag = 25}, packedTag = Just (WireTag {getWireTag = 25},WireTag {getWireTag = 26}), wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = True, mightPack = True, typeCode = FieldType {getFieldType = 1}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing}], descOneofs = fromList [], keys = fromList [], extRanges = [], knownKeys = fromList [], storeUnknown = False, lazyFields = False, makeLenses = False}" - -instance P'.TextType Kq where - tellT = P'.tellSubMessage - getT = P'.getSubMessage - -instance P'.TextMsg Kq where - textPut msg - = do - P'.tellT "m" (m msg) - P'.tellT "q" (q msg) - P'.tellT "xs" (xs msg) - textGet - = do - mods <- P'.sepEndBy (P'.choice [parse'm, parse'q, parse'xs]) P'.spaces - Prelude'.return (Prelude'.foldl (\ v f -> f v) P'.defaultValue mods) - where - parse'm - = P'.try - (do - v <- P'.getT "m" - Prelude'.return (\ o -> o{m = v})) - parse'q - = P'.try - (do - v <- P'.getT "q" - Prelude'.return (\ o -> o{q = v})) - parse'xs - = P'.try - (do - v <- P'.getT "xs" - Prelude'.return (\ o -> o{xs = P'.append (xs o) v})) diff --git a/Crypto/Proto/RLWE/Rq.hs b/Crypto/Proto/RLWE/Rq.hs deleted file mode 100644 --- a/Crypto/Proto/RLWE/Rq.hs +++ /dev/null @@ -1,95 +0,0 @@ -{-# LANGUAGE BangPatterns, DeriveDataTypeable, DeriveGeneric, FlexibleInstances, MultiParamTypeClasses #-} -{-# OPTIONS_GHC -fno-warn-unused-imports #-} -module Crypto.Proto.RLWE.Rq (Rq(..)) where -import Prelude ((+), (/)) -import qualified Prelude as Prelude' -import qualified Data.Typeable as Prelude' -import qualified GHC.Generics as Prelude' -import qualified Data.Data as Prelude' -import qualified Text.ProtocolBuffers.Header as P' - -data Rq = Rq{m :: !(P'.Word32), q :: !(P'.Word64), xs :: !(P'.Seq P'.Int64)} - deriving (Prelude'.Show, Prelude'.Eq, Prelude'.Ord, Prelude'.Typeable, Prelude'.Data, Prelude'.Generic) - -instance P'.Mergeable Rq where - mergeAppend (Rq x'1 x'2 x'3) (Rq y'1 y'2 y'3) = Rq (P'.mergeAppend x'1 y'1) (P'.mergeAppend x'2 y'2) (P'.mergeAppend x'3 y'3) - -instance P'.Default Rq where - defaultValue = Rq P'.defaultValue P'.defaultValue P'.defaultValue - -instance P'.Wire Rq where - wireSize ft' self'@(Rq x'1 x'2 x'3) - = case ft' of - 10 -> calc'Size - 11 -> P'.prependMessageSize calc'Size - _ -> P'.wireSizeErr ft' self' - where - calc'Size = (P'.wireSizeReq 1 13 x'1 + P'.wireSizeReq 1 4 x'2 + P'.wireSizeRep 1 18 x'3) - wirePut ft' self'@(Rq x'1 x'2 x'3) - = case ft' of - 10 -> put'Fields - 11 -> do - P'.putSize (P'.wireSize 10 self') - put'Fields - _ -> P'.wirePutErr ft' self' - where - put'Fields - = do - P'.wirePutReq 8 13 x'1 - P'.wirePutReq 16 4 x'2 - P'.wirePutRep 24 18 x'3 - wireGet ft' - = case ft' of - 10 -> P'.getBareMessageWith update'Self - 11 -> P'.getMessageWith update'Self - _ -> P'.wireGetErr ft' - where - update'Self wire'Tag old'Self - = case wire'Tag of - 8 -> Prelude'.fmap (\ !new'Field -> old'Self{m = new'Field}) (P'.wireGet 13) - 16 -> Prelude'.fmap (\ !new'Field -> old'Self{q = new'Field}) (P'.wireGet 4) - 24 -> Prelude'.fmap (\ !new'Field -> old'Self{xs = P'.append (xs old'Self) new'Field}) (P'.wireGet 18) - 26 -> Prelude'.fmap (\ !new'Field -> old'Self{xs = P'.mergeAppend (xs old'Self) new'Field}) (P'.wireGetPacked 18) - _ -> let (field'Number, wire'Type) = P'.splitWireTag wire'Tag in P'.unknown field'Number wire'Type old'Self - -instance P'.MessageAPI msg' (msg' -> Rq) Rq where - getVal m' f' = f' m' - -instance P'.GPB Rq - -instance P'.ReflectDescriptor Rq where - getMessageInfo _ = P'.GetMessageInfo (P'.fromDistinctAscList [8, 16]) (P'.fromDistinctAscList [8, 16, 24, 26]) - reflectDescriptorInfo _ - = Prelude'.read - "DescriptorInfo {descName = ProtoName {protobufName = FIName \".RLWE.Rq\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"RLWE\"], baseName = MName \"Rq\"}, descFilePath = [\"Crypto\",\"Proto\",\"RLWE\",\"Rq.hs\"], isGroup = False, fields = fromList [FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".RLWE.Rq.m\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"RLWE\",MName \"Rq\"], baseName' = FName \"m\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 1}, wireTag = WireTag {getWireTag = 8}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 13}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".RLWE.Rq.q\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"RLWE\",MName \"Rq\"], baseName' = FName \"q\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 2}, wireTag = WireTag {getWireTag = 16}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 4}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".RLWE.Rq.xs\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"RLWE\",MName \"Rq\"], baseName' = FName \"xs\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 3}, wireTag = WireTag {getWireTag = 24}, packedTag = Just (WireTag {getWireTag = 24},WireTag {getWireTag = 26}), wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = True, mightPack = True, typeCode = FieldType {getFieldType = 18}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing}], descOneofs = fromList [], keys = fromList [], extRanges = [], knownKeys = fromList [], storeUnknown = False, lazyFields = False, makeLenses = False}" - -instance P'.TextType Rq where - tellT = P'.tellSubMessage - getT = P'.getSubMessage - -instance P'.TextMsg Rq where - textPut msg - = do - P'.tellT "m" (m msg) - P'.tellT "q" (q msg) - P'.tellT "xs" (xs msg) - textGet - = do - mods <- P'.sepEndBy (P'.choice [parse'm, parse'q, parse'xs]) P'.spaces - Prelude'.return (Prelude'.foldl (\ v f -> f v) P'.defaultValue mods) - where - parse'm - = P'.try - (do - v <- P'.getT "m" - Prelude'.return (\ o -> o{m = v})) - parse'q - = P'.try - (do - v <- P'.getT "q" - Prelude'.return (\ o -> o{q = v})) - parse'xs - = P'.try - (do - v <- P'.getT "xs" - Prelude'.return (\ o -> o{xs = P'.append (xs o) v})) diff --git a/Crypto/Proto/RLWE/SampleCont.hs b/Crypto/Proto/RLWE/SampleCont.hs --- a/Crypto/Proto/RLWE/SampleCont.hs +++ b/Crypto/Proto/RLWE/SampleCont.hs @@ -7,10 +7,10 @@ import qualified GHC.Generics as Prelude' import qualified Data.Data as Prelude' import qualified Text.ProtocolBuffers.Header as P' -import qualified Crypto.Proto.RLWE.Kq as RLWE (Kq) -import qualified Crypto.Proto.RLWE.Rq as RLWE (Rq) +import qualified Crypto.Proto.Lol.KqProduct as Lol (KqProduct) +import qualified Crypto.Proto.Lol.RqProduct as Lol (RqProduct) -data SampleCont = SampleCont{a :: !(RLWE.Rq), b :: !(RLWE.Kq)} +data SampleCont = SampleCont{a :: !(Lol.RqProduct), b :: !(Lol.KqProduct)} deriving (Prelude'.Show, Prelude'.Eq, Prelude'.Ord, Prelude'.Typeable, Prelude'.Data, Prelude'.Generic) instance P'.Mergeable SampleCont where @@ -60,7 +60,7 @@ getMessageInfo _ = P'.GetMessageInfo (P'.fromDistinctAscList [10, 18]) (P'.fromDistinctAscList [10, 18]) reflectDescriptorInfo _ = Prelude'.read - "DescriptorInfo {descName = ProtoName {protobufName = FIName \".RLWE.SampleCont\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"RLWE\"], baseName = MName \"SampleCont\"}, descFilePath = [\"Crypto\",\"Proto\",\"RLWE\",\"SampleCont.hs\"], isGroup = False, fields = fromList [FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".RLWE.SampleCont.a\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"RLWE\",MName \"SampleCont\"], baseName' = FName \"a\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 1}, wireTag = WireTag {getWireTag = 10}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 11}, typeName = Just (ProtoName {protobufName = FIName \".RLWE.Rq\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"RLWE\"], baseName = MName \"Rq\"}), hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".RLWE.SampleCont.b\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"RLWE\",MName \"SampleCont\"], baseName' = FName \"b\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 2}, wireTag = WireTag {getWireTag = 18}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 11}, typeName = Just (ProtoName {protobufName = FIName \".RLWE.Kq\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"RLWE\"], baseName = MName \"Kq\"}), hsRawDefault = Nothing, hsDefault = Nothing}], descOneofs = fromList [], keys = fromList [], extRanges = [], knownKeys = fromList [], storeUnknown = False, lazyFields = False, makeLenses = False}" + "DescriptorInfo {descName = ProtoName {protobufName = FIName \".RLWE.SampleCont\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"RLWE\"], baseName = MName \"SampleCont\"}, descFilePath = [\"Crypto\",\"Proto\",\"RLWE\",\"SampleCont.hs\"], isGroup = False, fields = fromList [FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".RLWE.SampleCont.a\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"RLWE\",MName \"SampleCont\"], baseName' = FName \"a\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 1}, wireTag = WireTag {getWireTag = 10}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 11}, typeName = Just (ProtoName {protobufName = FIName \".Lol.RqProduct\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"Lol\"], baseName = MName \"RqProduct\"}), hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".RLWE.SampleCont.b\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"RLWE\",MName \"SampleCont\"], baseName' = FName \"b\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 2}, wireTag = WireTag {getWireTag = 18}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 11}, typeName = Just (ProtoName {protobufName = FIName \".Lol.KqProduct\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"Lol\"], baseName = MName \"KqProduct\"}), hsRawDefault = Nothing, hsDefault = Nothing}], descOneofs = fromList [], keys = fromList [], extRanges = [], knownKeys = fromList [], storeUnknown = False, lazyFields = False, makeLenses = False}" instance P'.TextType SampleCont where tellT = P'.tellSubMessage diff --git a/Crypto/Proto/RLWE/SampleCont1.hs b/Crypto/Proto/RLWE/SampleCont1.hs new file mode 100644 --- /dev/null +++ b/Crypto/Proto/RLWE/SampleCont1.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE BangPatterns, DeriveDataTypeable, DeriveGeneric, FlexibleInstances, MultiParamTypeClasses #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +module Crypto.Proto.RLWE.SampleCont1 (SampleCont1(..)) where +import Prelude ((+), (/)) +import qualified Prelude as Prelude' +import qualified Data.Typeable as Prelude' +import qualified GHC.Generics as Prelude' +import qualified Data.Data as Prelude' +import qualified Text.ProtocolBuffers.Header as P' +import qualified Crypto.Proto.Lol.Kq1 as Lol (Kq1) +import qualified Crypto.Proto.Lol.Rq1 as Lol (Rq1) + +data SampleCont1 = SampleCont1{a :: !(Lol.Rq1), b :: !(Lol.Kq1)} + deriving (Prelude'.Show, Prelude'.Eq, Prelude'.Ord, Prelude'.Typeable, Prelude'.Data, Prelude'.Generic) + +instance P'.Mergeable SampleCont1 where + mergeAppend (SampleCont1 x'1 x'2) (SampleCont1 y'1 y'2) = SampleCont1 (P'.mergeAppend x'1 y'1) (P'.mergeAppend x'2 y'2) + +instance P'.Default SampleCont1 where + defaultValue = SampleCont1 P'.defaultValue P'.defaultValue + +instance P'.Wire SampleCont1 where + wireSize ft' self'@(SampleCont1 x'1 x'2) + = case ft' of + 10 -> calc'Size + 11 -> P'.prependMessageSize calc'Size + _ -> P'.wireSizeErr ft' self' + where + calc'Size = (P'.wireSizeReq 1 11 x'1 + P'.wireSizeReq 1 11 x'2) + wirePut ft' self'@(SampleCont1 x'1 x'2) + = case ft' of + 10 -> put'Fields + 11 -> do + P'.putSize (P'.wireSize 10 self') + put'Fields + _ -> P'.wirePutErr ft' self' + where + put'Fields + = do + P'.wirePutReq 10 11 x'1 + P'.wirePutReq 18 11 x'2 + wireGet ft' + = case ft' of + 10 -> P'.getBareMessageWith update'Self + 11 -> P'.getMessageWith update'Self + _ -> P'.wireGetErr ft' + where + update'Self wire'Tag old'Self + = case wire'Tag of + 10 -> Prelude'.fmap (\ !new'Field -> old'Self{a = P'.mergeAppend (a old'Self) (new'Field)}) (P'.wireGet 11) + 18 -> Prelude'.fmap (\ !new'Field -> old'Self{b = P'.mergeAppend (b old'Self) (new'Field)}) (P'.wireGet 11) + _ -> let (field'Number, wire'Type) = P'.splitWireTag wire'Tag in P'.unknown field'Number wire'Type old'Self + +instance P'.MessageAPI msg' (msg' -> SampleCont1) SampleCont1 where + getVal m' f' = f' m' + +instance P'.GPB SampleCont1 + +instance P'.ReflectDescriptor SampleCont1 where + getMessageInfo _ = P'.GetMessageInfo (P'.fromDistinctAscList [10, 18]) (P'.fromDistinctAscList [10, 18]) + reflectDescriptorInfo _ + = Prelude'.read + "DescriptorInfo {descName = ProtoName {protobufName = FIName \".RLWE.SampleCont1\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"RLWE\"], baseName = MName \"SampleCont1\"}, descFilePath = [\"Crypto\",\"Proto\",\"RLWE\",\"SampleCont1.hs\"], isGroup = False, fields = fromList [FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".RLWE.SampleCont1.a\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"RLWE\",MName \"SampleCont1\"], baseName' = FName \"a\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 1}, wireTag = WireTag {getWireTag = 10}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 11}, typeName = Just (ProtoName {protobufName = FIName \".Lol.Rq1\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"Lol\"], baseName = MName \"Rq1\"}), hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".RLWE.SampleCont1.b\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"RLWE\",MName \"SampleCont1\"], baseName' = FName \"b\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 2}, wireTag = WireTag {getWireTag = 18}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 11}, typeName = Just (ProtoName {protobufName = FIName \".Lol.Kq1\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"Lol\"], baseName = MName \"Kq1\"}), hsRawDefault = Nothing, hsDefault = Nothing}], descOneofs = fromList [], keys = fromList [], extRanges = [], knownKeys = fromList [], storeUnknown = False, lazyFields = False, makeLenses = False}" + +instance P'.TextType SampleCont1 where + tellT = P'.tellSubMessage + getT = P'.getSubMessage + +instance P'.TextMsg SampleCont1 where + textPut msg + = do + P'.tellT "a" (a msg) + P'.tellT "b" (b msg) + textGet + = do + mods <- P'.sepEndBy (P'.choice [parse'a, parse'b]) P'.spaces + Prelude'.return (Prelude'.foldl (\ v f -> f v) P'.defaultValue mods) + where + parse'a + = P'.try + (do + v <- P'.getT "a" + Prelude'.return (\ o -> o{a = v})) + parse'b + = P'.try + (do + v <- P'.getT "b" + Prelude'.return (\ o -> o{b = v})) diff --git a/Crypto/Proto/RLWE/SampleDisc.hs b/Crypto/Proto/RLWE/SampleDisc.hs --- a/Crypto/Proto/RLWE/SampleDisc.hs +++ b/Crypto/Proto/RLWE/SampleDisc.hs @@ -7,9 +7,9 @@ import qualified GHC.Generics as Prelude' import qualified Data.Data as Prelude' import qualified Text.ProtocolBuffers.Header as P' -import qualified Crypto.Proto.RLWE.Rq as RLWE (Rq) +import qualified Crypto.Proto.Lol.RqProduct as Lol (RqProduct) -data SampleDisc = SampleDisc{a :: !(RLWE.Rq), b :: !(RLWE.Rq)} +data SampleDisc = SampleDisc{a :: !(Lol.RqProduct), b :: !(Lol.RqProduct)} deriving (Prelude'.Show, Prelude'.Eq, Prelude'.Ord, Prelude'.Typeable, Prelude'.Data, Prelude'.Generic) instance P'.Mergeable SampleDisc where @@ -59,7 +59,7 @@ getMessageInfo _ = P'.GetMessageInfo (P'.fromDistinctAscList [10, 18]) (P'.fromDistinctAscList [10, 18]) reflectDescriptorInfo _ = Prelude'.read - "DescriptorInfo {descName = ProtoName {protobufName = FIName \".RLWE.SampleDisc\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"RLWE\"], baseName = MName \"SampleDisc\"}, descFilePath = [\"Crypto\",\"Proto\",\"RLWE\",\"SampleDisc.hs\"], isGroup = False, fields = fromList [FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".RLWE.SampleDisc.a\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"RLWE\",MName \"SampleDisc\"], baseName' = FName \"a\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 1}, wireTag = WireTag {getWireTag = 10}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 11}, typeName = Just (ProtoName {protobufName = FIName \".RLWE.Rq\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"RLWE\"], baseName = MName \"Rq\"}), hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".RLWE.SampleDisc.b\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"RLWE\",MName \"SampleDisc\"], baseName' = FName \"b\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 2}, wireTag = WireTag {getWireTag = 18}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 11}, typeName = Just (ProtoName {protobufName = FIName \".RLWE.Rq\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"RLWE\"], baseName = MName \"Rq\"}), hsRawDefault = Nothing, hsDefault = Nothing}], descOneofs = fromList [], keys = fromList [], extRanges = [], knownKeys = fromList [], storeUnknown = False, lazyFields = False, makeLenses = False}" + "DescriptorInfo {descName = ProtoName {protobufName = FIName \".RLWE.SampleDisc\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"RLWE\"], baseName = MName \"SampleDisc\"}, descFilePath = [\"Crypto\",\"Proto\",\"RLWE\",\"SampleDisc.hs\"], isGroup = False, fields = fromList [FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".RLWE.SampleDisc.a\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"RLWE\",MName \"SampleDisc\"], baseName' = FName \"a\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 1}, wireTag = WireTag {getWireTag = 10}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 11}, typeName = Just (ProtoName {protobufName = FIName \".Lol.RqProduct\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"Lol\"], baseName = MName \"RqProduct\"}), hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".RLWE.SampleDisc.b\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"RLWE\",MName \"SampleDisc\"], baseName' = FName \"b\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 2}, wireTag = WireTag {getWireTag = 18}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 11}, typeName = Just (ProtoName {protobufName = FIName \".Lol.RqProduct\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"Lol\"], baseName = MName \"RqProduct\"}), hsRawDefault = Nothing, hsDefault = Nothing}], descOneofs = fromList [], keys = fromList [], extRanges = [], knownKeys = fromList [], storeUnknown = False, lazyFields = False, makeLenses = False}" instance P'.TextType SampleDisc where tellT = P'.tellSubMessage diff --git a/Crypto/Proto/RLWE/SampleDisc1.hs b/Crypto/Proto/RLWE/SampleDisc1.hs new file mode 100644 --- /dev/null +++ b/Crypto/Proto/RLWE/SampleDisc1.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE BangPatterns, DeriveDataTypeable, DeriveGeneric, FlexibleInstances, MultiParamTypeClasses #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +module Crypto.Proto.RLWE.SampleDisc1 (SampleDisc1(..)) where +import Prelude ((+), (/)) +import qualified Prelude as Prelude' +import qualified Data.Typeable as Prelude' +import qualified GHC.Generics as Prelude' +import qualified Data.Data as Prelude' +import qualified Text.ProtocolBuffers.Header as P' +import qualified Crypto.Proto.Lol.Rq1 as Lol (Rq1) + +data SampleDisc1 = SampleDisc1{a :: !(Lol.Rq1), b :: !(Lol.Rq1)} + deriving (Prelude'.Show, Prelude'.Eq, Prelude'.Ord, Prelude'.Typeable, Prelude'.Data, Prelude'.Generic) + +instance P'.Mergeable SampleDisc1 where + mergeAppend (SampleDisc1 x'1 x'2) (SampleDisc1 y'1 y'2) = SampleDisc1 (P'.mergeAppend x'1 y'1) (P'.mergeAppend x'2 y'2) + +instance P'.Default SampleDisc1 where + defaultValue = SampleDisc1 P'.defaultValue P'.defaultValue + +instance P'.Wire SampleDisc1 where + wireSize ft' self'@(SampleDisc1 x'1 x'2) + = case ft' of + 10 -> calc'Size + 11 -> P'.prependMessageSize calc'Size + _ -> P'.wireSizeErr ft' self' + where + calc'Size = (P'.wireSizeReq 1 11 x'1 + P'.wireSizeReq 1 11 x'2) + wirePut ft' self'@(SampleDisc1 x'1 x'2) + = case ft' of + 10 -> put'Fields + 11 -> do + P'.putSize (P'.wireSize 10 self') + put'Fields + _ -> P'.wirePutErr ft' self' + where + put'Fields + = do + P'.wirePutReq 10 11 x'1 + P'.wirePutReq 18 11 x'2 + wireGet ft' + = case ft' of + 10 -> P'.getBareMessageWith update'Self + 11 -> P'.getMessageWith update'Self + _ -> P'.wireGetErr ft' + where + update'Self wire'Tag old'Self + = case wire'Tag of + 10 -> Prelude'.fmap (\ !new'Field -> old'Self{a = P'.mergeAppend (a old'Self) (new'Field)}) (P'.wireGet 11) + 18 -> Prelude'.fmap (\ !new'Field -> old'Self{b = P'.mergeAppend (b old'Self) (new'Field)}) (P'.wireGet 11) + _ -> let (field'Number, wire'Type) = P'.splitWireTag wire'Tag in P'.unknown field'Number wire'Type old'Self + +instance P'.MessageAPI msg' (msg' -> SampleDisc1) SampleDisc1 where + getVal m' f' = f' m' + +instance P'.GPB SampleDisc1 + +instance P'.ReflectDescriptor SampleDisc1 where + getMessageInfo _ = P'.GetMessageInfo (P'.fromDistinctAscList [10, 18]) (P'.fromDistinctAscList [10, 18]) + reflectDescriptorInfo _ + = Prelude'.read + "DescriptorInfo {descName = ProtoName {protobufName = FIName \".RLWE.SampleDisc1\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"RLWE\"], baseName = MName \"SampleDisc1\"}, descFilePath = [\"Crypto\",\"Proto\",\"RLWE\",\"SampleDisc1.hs\"], isGroup = False, fields = fromList [FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".RLWE.SampleDisc1.a\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"RLWE\",MName \"SampleDisc1\"], baseName' = FName \"a\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 1}, wireTag = WireTag {getWireTag = 10}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 11}, typeName = Just (ProtoName {protobufName = FIName \".Lol.Rq1\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"Lol\"], baseName = MName \"Rq1\"}), hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".RLWE.SampleDisc1.b\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"RLWE\",MName \"SampleDisc1\"], baseName' = FName \"b\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 2}, wireTag = WireTag {getWireTag = 18}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 11}, typeName = Just (ProtoName {protobufName = FIName \".Lol.Rq1\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"Lol\"], baseName = MName \"Rq1\"}), hsRawDefault = Nothing, hsDefault = Nothing}], descOneofs = fromList [], keys = fromList [], extRanges = [], knownKeys = fromList [], storeUnknown = False, lazyFields = False, makeLenses = False}" + +instance P'.TextType SampleDisc1 where + tellT = P'.tellSubMessage + getT = P'.getSubMessage + +instance P'.TextMsg SampleDisc1 where + textPut msg + = do + P'.tellT "a" (a msg) + P'.tellT "b" (b msg) + textGet + = do + mods <- P'.sepEndBy (P'.choice [parse'a, parse'b]) P'.spaces + Prelude'.return (Prelude'.foldl (\ v f -> f v) P'.defaultValue mods) + where + parse'a + = P'.try + (do + v <- P'.getT "a" + Prelude'.return (\ o -> o{a = v})) + parse'b + = P'.try + (do + v <- P'.getT "b" + Prelude'.return (\ o -> o{b = v})) diff --git a/Crypto/Proto/RLWE/SampleRLWR.hs b/Crypto/Proto/RLWE/SampleRLWR.hs --- a/Crypto/Proto/RLWE/SampleRLWR.hs +++ b/Crypto/Proto/RLWE/SampleRLWR.hs @@ -7,9 +7,9 @@ import qualified GHC.Generics as Prelude' import qualified Data.Data as Prelude' import qualified Text.ProtocolBuffers.Header as P' -import qualified Crypto.Proto.RLWE.Rq as RLWE (Rq) +import qualified Crypto.Proto.Lol.RqProduct as Lol (RqProduct) -data SampleRLWR = SampleRLWR{a :: !(RLWE.Rq), b :: !(RLWE.Rq)} +data SampleRLWR = SampleRLWR{a :: !(Lol.RqProduct), b :: !(Lol.RqProduct)} deriving (Prelude'.Show, Prelude'.Eq, Prelude'.Ord, Prelude'.Typeable, Prelude'.Data, Prelude'.Generic) instance P'.Mergeable SampleRLWR where @@ -59,7 +59,7 @@ getMessageInfo _ = P'.GetMessageInfo (P'.fromDistinctAscList [10, 18]) (P'.fromDistinctAscList [10, 18]) reflectDescriptorInfo _ = Prelude'.read - "DescriptorInfo {descName = ProtoName {protobufName = FIName \".RLWE.SampleRLWR\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"RLWE\"], baseName = MName \"SampleRLWR\"}, descFilePath = [\"Crypto\",\"Proto\",\"RLWE\",\"SampleRLWR.hs\"], isGroup = False, fields = fromList [FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".RLWE.SampleRLWR.a\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"RLWE\",MName \"SampleRLWR\"], baseName' = FName \"a\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 1}, wireTag = WireTag {getWireTag = 10}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 11}, typeName = Just (ProtoName {protobufName = FIName \".RLWE.Rq\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"RLWE\"], baseName = MName \"Rq\"}), hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".RLWE.SampleRLWR.b\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"RLWE\",MName \"SampleRLWR\"], baseName' = FName \"b\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 2}, wireTag = WireTag {getWireTag = 18}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 11}, typeName = Just (ProtoName {protobufName = FIName \".RLWE.Rq\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"RLWE\"], baseName = MName \"Rq\"}), hsRawDefault = Nothing, hsDefault = Nothing}], descOneofs = fromList [], keys = fromList [], extRanges = [], knownKeys = fromList [], storeUnknown = False, lazyFields = False, makeLenses = False}" + "DescriptorInfo {descName = ProtoName {protobufName = FIName \".RLWE.SampleRLWR\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"RLWE\"], baseName = MName \"SampleRLWR\"}, descFilePath = [\"Crypto\",\"Proto\",\"RLWE\",\"SampleRLWR.hs\"], isGroup = False, fields = fromList [FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".RLWE.SampleRLWR.a\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"RLWE\",MName \"SampleRLWR\"], baseName' = FName \"a\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 1}, wireTag = WireTag {getWireTag = 10}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 11}, typeName = Just (ProtoName {protobufName = FIName \".Lol.RqProduct\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"Lol\"], baseName = MName \"RqProduct\"}), hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".RLWE.SampleRLWR.b\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"RLWE\",MName \"SampleRLWR\"], baseName' = FName \"b\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 2}, wireTag = WireTag {getWireTag = 18}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 11}, typeName = Just (ProtoName {protobufName = FIName \".Lol.RqProduct\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"Lol\"], baseName = MName \"RqProduct\"}), hsRawDefault = Nothing, hsDefault = Nothing}], descOneofs = fromList [], keys = fromList [], extRanges = [], knownKeys = fromList [], storeUnknown = False, lazyFields = False, makeLenses = False}" instance P'.TextType SampleRLWR where tellT = P'.tellSubMessage diff --git a/Crypto/Proto/RLWE/SampleRLWR1.hs b/Crypto/Proto/RLWE/SampleRLWR1.hs new file mode 100644 --- /dev/null +++ b/Crypto/Proto/RLWE/SampleRLWR1.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE BangPatterns, DeriveDataTypeable, DeriveGeneric, FlexibleInstances, MultiParamTypeClasses #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +module Crypto.Proto.RLWE.SampleRLWR1 (SampleRLWR1(..)) where +import Prelude ((+), (/)) +import qualified Prelude as Prelude' +import qualified Data.Typeable as Prelude' +import qualified GHC.Generics as Prelude' +import qualified Data.Data as Prelude' +import qualified Text.ProtocolBuffers.Header as P' +import qualified Crypto.Proto.Lol.Rq1 as Lol (Rq1) + +data SampleRLWR1 = SampleRLWR1{a :: !(Lol.Rq1), b :: !(Lol.Rq1)} + deriving (Prelude'.Show, Prelude'.Eq, Prelude'.Ord, Prelude'.Typeable, Prelude'.Data, Prelude'.Generic) + +instance P'.Mergeable SampleRLWR1 where + mergeAppend (SampleRLWR1 x'1 x'2) (SampleRLWR1 y'1 y'2) = SampleRLWR1 (P'.mergeAppend x'1 y'1) (P'.mergeAppend x'2 y'2) + +instance P'.Default SampleRLWR1 where + defaultValue = SampleRLWR1 P'.defaultValue P'.defaultValue + +instance P'.Wire SampleRLWR1 where + wireSize ft' self'@(SampleRLWR1 x'1 x'2) + = case ft' of + 10 -> calc'Size + 11 -> P'.prependMessageSize calc'Size + _ -> P'.wireSizeErr ft' self' + where + calc'Size = (P'.wireSizeReq 1 11 x'1 + P'.wireSizeReq 1 11 x'2) + wirePut ft' self'@(SampleRLWR1 x'1 x'2) + = case ft' of + 10 -> put'Fields + 11 -> do + P'.putSize (P'.wireSize 10 self') + put'Fields + _ -> P'.wirePutErr ft' self' + where + put'Fields + = do + P'.wirePutReq 10 11 x'1 + P'.wirePutReq 18 11 x'2 + wireGet ft' + = case ft' of + 10 -> P'.getBareMessageWith update'Self + 11 -> P'.getMessageWith update'Self + _ -> P'.wireGetErr ft' + where + update'Self wire'Tag old'Self + = case wire'Tag of + 10 -> Prelude'.fmap (\ !new'Field -> old'Self{a = P'.mergeAppend (a old'Self) (new'Field)}) (P'.wireGet 11) + 18 -> Prelude'.fmap (\ !new'Field -> old'Self{b = P'.mergeAppend (b old'Self) (new'Field)}) (P'.wireGet 11) + _ -> let (field'Number, wire'Type) = P'.splitWireTag wire'Tag in P'.unknown field'Number wire'Type old'Self + +instance P'.MessageAPI msg' (msg' -> SampleRLWR1) SampleRLWR1 where + getVal m' f' = f' m' + +instance P'.GPB SampleRLWR1 + +instance P'.ReflectDescriptor SampleRLWR1 where + getMessageInfo _ = P'.GetMessageInfo (P'.fromDistinctAscList [10, 18]) (P'.fromDistinctAscList [10, 18]) + reflectDescriptorInfo _ + = Prelude'.read + "DescriptorInfo {descName = ProtoName {protobufName = FIName \".RLWE.SampleRLWR1\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"RLWE\"], baseName = MName \"SampleRLWR1\"}, descFilePath = [\"Crypto\",\"Proto\",\"RLWE\",\"SampleRLWR1.hs\"], isGroup = False, fields = fromList [FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".RLWE.SampleRLWR1.a\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"RLWE\",MName \"SampleRLWR1\"], baseName' = FName \"a\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 1}, wireTag = WireTag {getWireTag = 10}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 11}, typeName = Just (ProtoName {protobufName = FIName \".Lol.Rq1\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"Lol\"], baseName = MName \"Rq1\"}), hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".RLWE.SampleRLWR1.b\", haskellPrefix' = [MName \"Crypto\",MName \"Proto\"], parentModule' = [MName \"RLWE\",MName \"SampleRLWR1\"], baseName' = FName \"b\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 2}, wireTag = WireTag {getWireTag = 18}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 11}, typeName = Just (ProtoName {protobufName = FIName \".Lol.Rq1\", haskellPrefix = [MName \"Crypto\",MName \"Proto\"], parentModule = [MName \"Lol\"], baseName = MName \"Rq1\"}), hsRawDefault = Nothing, hsDefault = Nothing}], descOneofs = fromList [], keys = fromList [], extRanges = [], knownKeys = fromList [], storeUnknown = False, lazyFields = False, makeLenses = False}" + +instance P'.TextType SampleRLWR1 where + tellT = P'.tellSubMessage + getT = P'.getSubMessage + +instance P'.TextMsg SampleRLWR1 where + textPut msg + = do + P'.tellT "a" (a msg) + P'.tellT "b" (b msg) + textGet + = do + mods <- P'.sepEndBy (P'.choice [parse'a, parse'b]) P'.spaces + Prelude'.return (Prelude'.foldl (\ v f -> f v) P'.defaultValue mods) + where + parse'a + = P'.try + (do + v <- P'.getT "a" + Prelude'.return (\ o -> o{a = v})) + parse'b + = P'.try + (do + v <- P'.getT "b" + Prelude'.return (\ o -> o{b = v})) diff --git a/Lol.proto b/Lol.proto new file mode 100644 --- /dev/null +++ b/Lol.proto @@ -0,0 +1,53 @@ +// Proto messages for cyclotomic rings and other basic types in Lol + +// run this: + +// hprotoc -p Crypto.Proto Lol.proto + +// coeffs contains the function output corresponding to the decoding basis in R +message LinearRq { + required uint32 e = 1; + required uint32 r = 2; + repeated RqProduct coeffs = 3; +} + +// For each of the following, the "xs" array is with respect to the +// decoding basis. + +message R { + required uint32 m = 1; + repeated sint64 xs = 2; +} + +// only holds a single modulus. This type was used to serialize cyclotomic ring +// elements in the RLWE/RLWR challenges. +message Rq1 { + required uint32 m = 1; + required uint64 q = 2; + repeated sint64 xs = 3; +} + +// only holds a single modulus. This type was used to serialize cyclotomic ring +// elements in the RLWE challenges. +message Kq1 { + required uint32 m = 1; + required uint64 q = 2; + repeated double xs = 3; +} + +// cyclotomic ring mod the product of one or more moduli +message RqProduct { + repeated Rq1 rqlist = 1; +} + +// cyclotomic ring mod the product of one or more moduli +message KqProduct { + repeated Kq1 kqlist = 1; +} + +// used to serialize GHC.Fingerprint.Fingerprint. Obviously not intended to be +// platform independent. +message TypeRep { + required uint64 a = 1; + required uint64 b = 2; +} diff --git a/README b/README --- a/README +++ b/README @@ -1,10 +1,19 @@ +This package is primarily a library providing interfaces for lattice cryptography +primitives. There are two main interfaces: 'Cyclotomic' and 'Tensor'. The +Cyclotomic interface is the outward-facing API that is used to build cryptographic +applications like pseudo-random functions, encryption, etc. The Tensor interface allows +multiple backends to implement the functionality used by the Cyclotomic interface. +Unless you are writing a new backend implementation, you shouldn't need to +understand the Tensor interface. However, you *will* need an implementation of the +Tensor interface in order to test, benchmark, and run applications. + Most of the functionality in Lol is exported by two modules: * 'Crypto.Lol' exports the primary *interfaces* of Lol * 'Crypto.Lol.Types' exports concrete types that would be used by most - instantiations including tensors, base rings, and cryptographic + instantiations. For a brief introduction to relevant mathematical notation, see 'Crypto.Lol'. @@ -27,12 +36,10 @@ \( R \)- and \( R_q \)-elements, e.g., the CRT transform, converting between the powerful and decoding bases, generating error terms, etc. -* 'Crypto.Lol.Cyclotomic.Tensor.RepaTensor', which gives an - implementation of the 'Tensor' class based on the "repa" - package, a highly optimized and parallelizable array library. - -* 'Crypto.Lol.Cyclotomic.Tensor.CTensor', which gives an - implementation of the 'Tensor' class using a C++ backend via Haskell's FFI. +* You will need an implementation of the 'Tensor' interface in order to use Lol. + Two implementations can be found at + + and . Base ring layer: @@ -45,10 +52,13 @@ If you need to use an unsupported finite field, define your own instance of 'IrreduciblePoly' and do **not** import 'IrreducibleChar2'. -* 'Crypto.Lol.Types.ZqBasic', which is a basic implementation of +* 'Crypto.Lol.Types.Unsafe.ZqBasic', which is a basic implementation of \( \Z_q=\Z/q\Z \) arithmetic. * 'Crypto.Lol.Factored', which contains type-level support code for factored integers. It also supports "reifying" 'Int's at runtime as static types and "reflecting" those types as integers back to the code.. 'Factored' types are mainly used to represent cyclotomic indices. + +Tests and benchmarks can be found in the packages and , +respectively, though they are instantiated in individual tensors. diff --git a/RLWE.proto b/RLWE.proto new file mode 100644 --- /dev/null +++ b/RLWE.proto @@ -0,0 +1,44 @@ +// proto messages for the RLWE/RLWR problems + +import "Lol.proto"; + +// Proto messages for RLWE/RLWR samples + +// run this: + +// hprotoc -a Lol.proto=Crypto.Proto -p Crypto.Proto RLWE.proto + +// the Sample*1 messages were used to serialize RLWE/RLWR samples in the +// RLWE/RLWR challenges, and only support cyclotomic rings mod a single modulus +message SampleCont1 { + required Rq1 a = 1; + required Kq1 b = 2; +} + +message SampleDisc1 { + required Rq1 a = 1; + required Rq1 b = 2; +} + +message SampleRLWR1 { + required Rq1 a = 1; + required Rq1 b = 2; // for some modulus p < q +} + +// continuous RLWE sample, possibly with mutliple moduli +message SampleCont { + required RqProduct a = 1; + required KqProduct b = 2; +} + +// discrete RLWE sample, possibly with multiple moduli +message SampleDisc { + required RqProduct a = 1; + required RqProduct b = 2; +} + +// RLWR sample, possibly with multiple moduli +message SampleRLWR { + required RqProduct a = 1; + required RqProduct b = 2; // for some modulus p < q +} diff --git a/benchmarks/CycBenches.hs b/benchmarks/CycBenches.hs deleted file mode 100644 --- a/benchmarks/CycBenches.hs +++ /dev/null @@ -1,152 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} - -module CycBenches (cycBenches) where - -import Apply.Cyc -import Benchmarks -import BenchParams - -import Control.Monad.Random - -import Crypto.Lol -import Crypto.Lol.Types -import Crypto.Random.DRBG - -cycBenches :: IO Benchmark -cycBenches = benchGroup "Cyc" [ - benchGroup "unzipPow" $ [hideArgs bench_unzipCycPow testParam], - benchGroup "unzipDec" $ [hideArgs bench_unzipCycDec testParam], - benchGroup "unzipCRT" $ [hideArgs bench_unzipCycCRT testParam], - benchGroup "zipWith (*)" $ [hideArgs bench_mul testParam], - benchGroup "crt" $ [hideArgs bench_crt testParam], - benchGroup "crtInv" $ [hideArgs bench_crtInv testParam], - benchGroup "l" $ [hideArgs bench_l testParam], - benchGroup "lInv" $ [hideArgs bench_lInv testParam], - benchGroup "*g Pow" $ [hideArgs bench_mulgPow testParam], - benchGroup "*g Dec" $ [hideArgs bench_mulgDec testParam], - benchGroup "*g CRT" $ [hideArgs bench_mulgCRT testParam], - benchGroup "divg Pow" $ [hideArgs bench_divgPow testParam], - benchGroup "divg Dec" $ [hideArgs bench_divgDec testParam], - benchGroup "divg CRT" $ [hideArgs bench_divgCRT testParam], - benchGroup "lift" $ [hideArgs bench_liftPow testParam], - benchGroup "error" $ [hideArgs (bench_errRounded 0.1) testParam'], - benchGroup "twacePow" $ [hideArgs bench_twacePow twoIdxParam], - benchGroup "twaceDec" $ [hideArgs bench_twaceDec twoIdxParam], - benchGroup "twaceCRT" $ [hideArgs bench_twaceCRT twoIdxParam], - benchGroup "embedPow" $ [hideArgs bench_embedPow twoIdxParam], - benchGroup "embedDec" $ [hideArgs bench_embedDec twoIdxParam], - benchGroup "embedCRT" $ [hideArgs bench_embedCRT twoIdxParam] - ] - -bench_unzipCycPow :: (UnzipCtx t m r) => Cyc t m (r,r) -> Bench '(t,m,r) -bench_unzipCycPow a = - let a' = advisePow a - in bench unzipCyc a' - -bench_unzipCycDec :: (UnzipCtx t m r) => Cyc t m (r,r) -> Bench '(t,m,r) -bench_unzipCycDec a = - let a' = adviseDec a - in bench unzipCyc a' - -bench_unzipCycCRT :: (UnzipCtx t m r) => Cyc t m (r,r) -> Bench '(t,m,r) -bench_unzipCycCRT a = - let a' = adviseCRT a - in bench unzipCyc a' - --- no CRT conversion, just coefficient-wise multiplication -bench_mul :: (BasicCtx t m r) => Cyc t m r -> Cyc t m r -> Bench '(t,m,r) -bench_mul a b = - 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 - --- convert input from Pow basis to Dec basis -bench_lInv :: (BasicCtx t m r) => Cyc t m r -> Bench '(t,m,r) -bench_lInv x = let y = advisePow x in bench adviseDec 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) 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 Dec basis -bench_mulgDec :: (BasicCtx t m r) => Cyc t m r -> Bench '(t,m,r) -bench_mulgDec x = let y = adviseDec 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 - --- divide by g when input is in Pow basis -bench_divgPow :: (BasicCtx t m r) => Cyc t m r -> Bench '(t,m,r) -bench_divgPow x = let y = advisePow $ mulG x in bench divG y - --- divide by g when input is in Dec basis -bench_divgDec :: (BasicCtx t m r) => Cyc t m r -> Bench '(t,m,r) -bench_divgDec x = let y = adviseDec $ mulG x in bench divG y - --- divide by g when input is in CRT basis -bench_divgCRT :: (BasicCtx t m r) => Cyc t m r -> Bench '(t,m,r) -bench_divgCRT x = let y = adviseCRT x in bench divG 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_twaceDec :: forall t m m' r . (TwoIdxCtx t m m' r) - => Cyc t m' r -> Bench '(t,m,m',r) -bench_twaceDec x = - let y = adviseDec x - in bench (twace :: Cyc t m' r -> Cyc t m r) y - -bench_twaceCRT :: forall t m m' r . (TwoIdxCtx t m m' r) - => Cyc t m' r -> Bench '(t,m,m',r) -bench_twaceCRT x = - let y = adviseCRT 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 (advisePow . embed :: Cyc t m r -> Cyc t m' r) y - -bench_embedDec :: forall t m m' r . (TwoIdxCtx t m m' r) - => Cyc t m r -> Bench '(t,m,m',r) -bench_embedDec x = - let y = adviseDec x - in bench (adviseDec . embed :: Cyc t m r -> Cyc t m' r) y - -bench_embedCRT :: forall t m m' r . (TwoIdxCtx t m m' r) - => Cyc t m r -> Bench '(t,m,m',r) -bench_embedCRT x = - let y = adviseCRT x - in bench (adviseCRT . embed :: Cyc t m r -> Cyc t m' r) y diff --git a/benchmarks/Main.hs b/benchmarks/Main.hs deleted file mode 100644 --- a/benchmarks/Main.hs +++ /dev/null @@ -1,173 +0,0 @@ -{- -import TensorBenches -import Criterion.Main - -main :: IO () -main = defaultMain =<< sequence [ - tensorBenches - ] --} -{-# LANGUAGE BangPatterns, RecordWildCards #-} - -import CycBenches -import TensorBenches -import UCycBenches - -import Criterion.Internal (runAndAnalyseOne) -import Criterion.Main.Options (defaultConfig) -import Criterion.Measurement (secs) -import Criterion.Monad (Criterion, withConfig) -import Criterion.Types -import Control.Monad (foldM, forM_, when) -import Control.Monad.IO.Class (MonadIO, liftIO) - -import Control.Exception (evaluate) - -import Control.DeepSeq (rnf) - -import Data.List (transpose) -import qualified Data.Map as Map -import Data.Maybe - -import Statistics.Resampling.Bootstrap (Estimate(..)) -import System.Console.ANSI -import System.IO -import Text.Printf - --- table print parameters -colWidth, testNameWidth :: Int -colWidth = 15 -testNameWidth = 40 -verb :: Verb -verb = Progress - -benches :: [String] -benches = [ - "unzipPow", - "unzipDec", - "unzipCRT", - "zipWith (*)", - "crt", - "crtInv", - "l", - "lInv", - "*g Pow", - "*g Dec", - "*g CRT", - "divg Pow", - "divg Dec", - "divg CRT", - "lift", - "error", - "twacePow", - "twaceDec", - "twaceCRT", - "embedPow", - "embedDec", - "embedCRT" - - ] - -data Verb = Progress | Abridged | Full deriving (Eq) - -main :: IO () -main = do - hSetBuffering stdout NoBuffering -- for better printing of progress - reports <- mapM (getReports =<<) [ - tensorBenches, - ucycBenches, - cycBenches - ] - when (verb == Progress) $ putStrLn "" - printTable $ map reverse reports - -printTable :: [[Report]] -> IO () -printTable rpts = do - let colLbls = map (takeWhile (/= '/') . reportName . head) rpts - printf testName "" - mapM_ (\lbl -> printf col lbl) colLbls - printf "\n" - mapM_ printRow $ transpose rpts - -col, testName :: String -testName = "%-" ++ (show testNameWidth) ++ "s " -col = "%-" ++ (show colWidth) ++ "s " - -printANSI :: (MonadIO m) => Color -> String -> m () -printANSI sgr str = liftIO $ do - setSGR [SetColor Foreground Vivid sgr] - putStrLn str - setSGR [Reset] - -config :: Config -config = defaultConfig {verbosity = if verb == Full then Normal else Quiet} - -getRuntime :: Report -> Double -getRuntime Report{..} = - let SampleAnalysis{..} = reportAnalysis - (builtin, _) = splitAt 1 anRegress - mests = map (\Regression{..} -> Map.lookup "iters" regCoeffs) builtin - [Estimate{..}] = catMaybes mests - in estPoint - --- See Criterion.Internal.analyseOne -printRow :: [Report] -> IO () -printRow xs@(rpt : _) = do - printf testName $ stripOuterGroup $ reportName rpt - let times = map getRuntime xs - minTime = minimum times - printCol t = - if t > (1.1*minTime) - then do - setSGR [SetColor Foreground Vivid Red] - printf col $ secs t - setSGR [Reset] - else printf col $ secs t - forM_ times printCol - putStrLn "" - -stripOuterGroup :: String -> String -stripOuterGroup = tail . dropWhile (/= '/') - -getReports :: Benchmark -> IO [Report] -getReports = withConfig config . runAndAnalyse - --- | Run, and analyse, one or more benchmarks. --- From Criterion.Internal -runAndAnalyse :: Benchmark - -> Criterion [Report] -runAndAnalyse bs = for bs $ \idx desc bm -> do - when (verb == Abridged || verb == Full) $ liftIO $ putStr $ "benchmark " ++ desc - when (verb == Full) $ liftIO $ putStrLn "" - (Analysed rpt) <- runAndAnalyseOne idx desc bm - when (verb == Progress) $ liftIO $ putStr "." - when (verb == Abridged) $ liftIO $ putStrLn $ "..." ++ (secs $ getRuntime rpt) - return rpt - --- | Iterate over benchmarks. --- From Criterion.Internal -for :: MonadIO m => Benchmark - -> (Int -> String -> Benchmarkable -> m a) -> m [a] -for bs0 handle = snd <$> go (0::Int, []) ("", bs0) - where - select = flip elem benches . takeWhile (/= '/') . stripOuterGroup - go (!idx,drs) (pfx, Environment mkenv mkbench) - | shouldRun pfx mkbench = do - e <- liftIO $ do - ee <- mkenv - evaluate (rnf ee) - return ee - go (idx,drs) (pfx, mkbench e) - | otherwise = return (idx,drs) - go (!idx, drs) (pfx, Benchmark desc b) - | select desc' = do - x <- handle idx desc' b; - return (idx + 1, x:drs) - | otherwise = return (idx, drs) - where desc' = addPrefix pfx desc - go (!idx,drs) (pfx, BenchGroup desc bs) = - foldM go (idx,drs) [(addPrefix pfx desc, b) | b <- bs] - - shouldRun pfx mkbench = - any (select . addPrefix pfx) . benchNames . mkbench $ - error "Criterion.env could not determine the list of your benchmarks since they force the environment (see the documentation for details)" diff --git a/benchmarks/TensorBenches.hs b/benchmarks/TensorBenches.hs deleted file mode 100644 --- a/benchmarks/TensorBenches.hs +++ /dev/null @@ -1,131 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - -module TensorBenches (tensorBenches) where - -import Apply.Cyc -import Benchmarks -import BenchParams - -import Control.Applicative -import Control.Monad.Random - -import Crypto.Lol.Prelude -import Crypto.Lol.Cyclotomic.Tensor -import Crypto.Lol.Types -import Crypto.Random.DRBG - -tensorBenches :: IO Benchmark -tensorBenches = benchGroup "Tensor" [ - benchGroup "unzipPow" $ [hideArgs bench_unzip testParam], - benchGroup "unzipDec" $ [hideArgs bench_unzip testParam], - benchGroup "unzipCRT" $ [hideArgs bench_unzip testParam], - benchGroup "zipWith (*)" $ [hideArgs bench_mul testParam], - benchGroup "crt" $ [hideArgs bench_crt testParam], - benchGroup "crtInv" $ [hideArgs bench_crtInv testParam], - benchGroup "l" $ [hideArgs bench_l testParam], - benchGroup "lInv" $ [hideArgs bench_lInv testParam], - benchGroup "*g Pow" $ [hideArgs bench_mulgPow testParam], - benchGroup "*g Dec" $ [hideArgs bench_mulgDec testParam], - benchGroup "*g CRT" $ [hideArgs bench_mulgCRT testParam], - benchGroup "divg Pow" $ [hideArgs bench_divgPow testParam], - benchGroup "divg Dec" $ [hideArgs bench_divgDec testParam], - benchGroup "divg CRT" $ [hideArgs bench_divgCRT testParam], - benchGroup "lift" $ [hideArgs bench_liftPow testParam], - benchGroup "error" $ [hideArgs (bench_errRounded 0.1) testParam'], - benchGroup "twacePow" $ [hideArgs bench_twacePow twoIdxParam], - benchGroup "twaceDec" $ [hideArgs bench_twacePow twoIdxParam], -- yes, twacePow is correct here. It's the same function! - benchGroup "twaceCRT" $ [hideArgs bench_twaceCRT twoIdxParam], - benchGroup "embedPow" $ [hideArgs bench_embedPow twoIdxParam], - benchGroup "embedDec" $ [hideArgs bench_embedDec twoIdxParam], - benchGroup "embedCRT" $ [hideArgs bench_embedCRT twoIdxParam] - ] - -bench_unzip :: (UnzipCtx t m r) => t m (r,r) -> Bench '(t,m,r) -bench_unzip = bench unzipT - --- no CRT conversion, just coefficient-wise multiplication -bench_mul :: (BasicCtx t m r) => t m r -> t m r -> Bench '(t,m,r) -bench_mul a = bench (zipWithT (*) a) - --- convert input from Pow basis to CRT basis -bench_crt :: (BasicCtx t m r) => t m r -> Bench '(t,m,r) -bench_crt = bench (fromJust' "TensorBenches.bench_crt" crt) - --- convert input from CRT basis to Pow basis -bench_crtInv :: (BasicCtx t m r) => t m r -> Bench '(t,m,r) -bench_crtInv = bench (fromJust' "TensorBenches.bench_crtInv" crtInv) - --- convert input from Dec basis to Pow basis -bench_l :: (BasicCtx t m r) => t m r -> Bench '(t,m,r) -bench_l = bench l - --- convert input from Dec basis to Pow basis -bench_lInv :: (BasicCtx t m r) => t m r -> Bench '(t,m,r) -bench_lInv = bench lInv - --- lift an element in the Pow basis -bench_liftPow :: forall t m r . (LiftCtx t m r) => t m r -> Bench '(t,m,r) -bench_liftPow = bench (fmapT lift) - --- multiply by g when input is in Pow basis -bench_mulgPow :: (BasicCtx t m r) => t m r -> Bench '(t,m,r) -bench_mulgPow = bench mulGPow - --- multiply by g when input is in Dec basis -bench_mulgDec :: (BasicCtx t m r) => t m r -> Bench '(t,m,r) -bench_mulgDec = bench mulGDec - --- multiply by g when input is in CRT basis -bench_mulgCRT :: (BasicCtx t m r) => t m r -> Bench '(t,m,r) -bench_mulgCRT = bench (fromJust' "TensorBenches.bench_mulgCRT" mulGCRT) - --- divide by g when input is in Pow basis -bench_divgPow :: (BasicCtx t m r) => t m r -> Bench '(t,m,r) -bench_divgPow x = - let y = mulGPow x - in bench divGPow y - --- divide by g when input is in Dec basis -bench_divgDec :: (BasicCtx t m r) => t m r -> Bench '(t,m,r) -bench_divgDec x = - let y = mulGDec x - in bench divGDec y - --- divide by g when input is in CRT basis -bench_divgCRT :: (BasicCtx t m r) => t m r -> Bench '(t,m,r) -bench_divgCRT = bench (fromJust' "TensorBenches.bench_divgCRT" divGCRT) - --- 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 - (fmapT (roundMult one) <$> - (tGaussianDec v :: Rand (CryptoRand gen) (t m Double)) :: Rand (CryptoRand gen) (t m (LiftOf r))) gen - -bench_twacePow :: forall t m m' r . (TwoIdxCtx t m m' r) - => t m' r -> Bench '(t,m,m',r) -bench_twacePow = bench (twacePowDec :: t m' r -> t m r) - -bench_twaceCRT :: forall t m m' r . (TwoIdxCtx t m m' r) - => t m' r -> Bench '(t,m,m',r) -bench_twaceCRT = bench (fromJust' "TensorBenches.bench_twaceCRT" twaceCRT :: t m' r -> t m r) - -bench_embedPow :: forall t m m' r . (TwoIdxCtx t m m' r) - => t m r -> Bench '(t,m,m',r) -bench_embedPow = bench (embedPow :: t m r -> t m' r) - -bench_embedDec :: forall t m m' r . (TwoIdxCtx t m m' r) - => t m r -> Bench '(t,m,m',r) -bench_embedDec = bench (embedDec :: t m r -> t m' r) - -bench_embedCRT :: forall t m m' r . (TwoIdxCtx t m m' r) - => t m r -> Bench '(t,m,m',r) -bench_embedCRT = bench (fromJust' "TensorBenches.bench_embedCRT" embedCRT :: t m r -> t m' r) diff --git a/benchmarks/UCycBenches.hs b/benchmarks/UCycBenches.hs deleted file mode 100644 --- a/benchmarks/UCycBenches.hs +++ /dev/null @@ -1,142 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} - -module UCycBenches (ucycBenches) where - -import Apply.Cyc -import Benchmarks -import BenchParams - -import Control.Monad.Random - -import Crypto.Lol.Prelude -import Crypto.Lol.Cyclotomic.UCyc -import Crypto.Lol.Types -import Crypto.Random.DRBG - -ucycBenches :: IO Benchmark -ucycBenches = benchGroup "UCyc" [ - benchGroup "unzipPow" $ [hideArgs bench_unzipUCycPow testParam], - benchGroup "unzipDec" $ [hideArgs bench_unzipUCycDec testParam], - benchGroup "unzipCRT" $ [hideArgs bench_unzipUCycCRT testParam], - benchGroup "zipWith (*)" $ [hideArgs bench_mul testParam], - benchGroup "crt" $ [hideArgs bench_crt testParam], - benchGroup "crtInv" $ [hideArgs bench_crtInv testParam], - benchGroup "l" $ [hideArgs bench_l testParam], - benchGroup "lInv" $ [hideArgs bench_lInv testParam], - benchGroup "*g Pow" $ [hideArgs bench_mulgPow testParam], - benchGroup "*g Dec" $ [hideArgs bench_mulgDec testParam], - benchGroup "*g CRT" $ [hideArgs bench_mulgCRT testParam], - benchGroup "divg Pow" $ [hideArgs bench_divgPow testParam], - benchGroup "divg Dec" $ [hideArgs bench_divgDec testParam], - benchGroup "divg CRT" $ [hideArgs bench_divgCRT testParam], - benchGroup "lift" $ [hideArgs bench_liftPow testParam], - benchGroup "error" $ [hideArgs (bench_errRounded 0.1) testParam'], - benchGroup "twacePow" $ [hideArgs bench_twacePow twoIdxParam], - benchGroup "twaceDec" $ [hideArgs bench_twaceDec twoIdxParam], - benchGroup "twaceCRT" $ [hideArgs bench_twaceCRT twoIdxParam], - benchGroup "embedPow" $ [hideArgs bench_embedPow twoIdxParam], - benchGroup "embedDec" $ [hideArgs bench_embedDec twoIdxParam], - benchGroup "embedCRT" $ [hideArgs bench_embedCRT twoIdxParam] - ] - -bench_unzipUCycPow :: (UnzipCtx t m r) => UCyc t m P (r,r) -> Bench '(t,m,r) -bench_unzipUCycPow = bench unzipPow - -bench_unzipUCycDec :: (UnzipCtx t m r) => UCyc t m D (r,r) -> Bench '(t,m,r) -bench_unzipUCycDec = bench unzipDec - -bench_unzipUCycCRT :: (UnzipCtx t m r) => UCycPC t m (r,r) -> Bench '(t,m,r) -bench_unzipUCycCRT (Right a) = bench unzipCRTC a - -pcToEC :: UCycPC t m r -> UCycEC t m r -pcToEC (Right x) = (Right x) - --- no CRT conversion, just coefficient-wise multiplication -bench_mul :: (BasicCtx t m r) => UCycPC t m r -> UCycPC t m r -> Bench '(t,m,r) -bench_mul a b = - let a' = pcToEC a - b' = pcToEC b - in bench (a' *) b' - --- convert input from Pow basis to CRT basis -bench_crt :: (BasicCtx t m r) => UCyc t m P r -> Bench '(t,m,r) -bench_crt = bench toCRT - --- convert input from CRT basis to Pow basis -bench_crtInv :: (BasicCtx t m r) => UCycPC t m r -> Bench '(t,m,r) -bench_crtInv (Right a) = bench toPow a - --- convert input from Dec basis to Pow basis -bench_l :: (BasicCtx t m r) => UCyc t m D r -> Bench '(t,m,r) -bench_l = bench toPow - --- convert input from Pow basis to Dec basis -bench_lInv :: (BasicCtx t m r) => UCyc t m P r -> Bench '(t,m,r) -bench_lInv = bench toDec - --- lift an element in the Pow basis -bench_liftPow :: (LiftCtx t m r) => UCyc t m P r -> Bench '(t,m,r) -bench_liftPow = bench lift - --- multiply by g when input is in Pow basis -bench_mulgPow :: (BasicCtx t m r) => UCyc t m P r -> Bench '(t,m,r) -bench_mulgPow = bench mulG - --- multiply by g when input is in Dec basis -bench_mulgDec :: (BasicCtx t m r) => UCyc t m D r -> Bench '(t,m,r) -bench_mulgDec = bench mulG - --- multiply by g when input is in CRT basis -bench_mulgCRT :: (BasicCtx t m r) => UCycPC t m r -> Bench '(t,m,r) -bench_mulgCRT (Right a) = bench mulG a - --- divide by g when input is in Pow basis -bench_divgPow :: (BasicCtx t m r) => UCyc t m P r -> Bench '(t,m,r) -bench_divgPow x = - let y = mulG x - in bench divGPow y - --- divide by g when input is in Dec basis -bench_divgDec :: (BasicCtx t m r) => UCyc t m D r -> Bench '(t,m,r) -bench_divgDec x = - let y = mulG x - in bench divGDec y - --- divide by g when input is in CRT basis -bench_divgCRT :: (BasicCtx t m r) => UCycPC t m r -> Bench '(t,m,r) -bench_divgCRT (Right a) = bench divGCRTC a - --- 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) (UCyc t m D (LiftOf r))) gen - -bench_twacePow :: forall t m m' r . (TwoIdxCtx t m m' r) - => UCyc t m' P r -> Bench '(t,m,m',r) -bench_twacePow = bench (twacePow :: UCyc t m' P r -> UCyc t m P r) - -bench_twaceDec :: forall t m m' r . (TwoIdxCtx t m m' r) - => UCyc t m' D r -> Bench '(t,m,m',r) -bench_twaceDec = bench (twaceDec :: UCyc t m' D r -> UCyc t m D r) - -bench_twaceCRT :: forall t m m' r . (TwoIdxCtx t m m' r) - => UCycPC t m' r -> Bench '(t,m,m',r) -bench_twaceCRT (Right a) = bench (twaceCRTC :: UCyc t m' C r -> UCycPC t m r) a - -bench_embedPow :: forall t m m' r . (TwoIdxCtx t m m' r) - => UCyc t m P r -> Bench '(t,m,m',r) -bench_embedPow = bench (embedPow :: UCyc t m P r -> UCyc t m' P r) - -bench_embedDec :: forall t m m' r . (TwoIdxCtx t m m' r) - => UCyc t m D r -> Bench '(t,m,m',r) -bench_embedDec = bench (embedDec :: UCyc t m D r -> UCyc t m' D r) - -bench_embedCRT :: forall t m m' r . (TwoIdxCtx t m m' r) - => UCycPC t m r -> Bench '(t,m,m',r) -bench_embedCRT (Right a) = bench (embedCRTC :: UCyc t m C r -> UCycPC t m' r) a diff --git a/benchmarks/ZqBenches.hs b/benchmarks/ZqBenches.hs deleted file mode 100644 --- a/benchmarks/ZqBenches.hs +++ /dev/null @@ -1,39 +0,0 @@ -{-# 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 Utils -import GenArgs -import Benchmarks - -type Arr = R.Array R.U R.DIM1 - -zqBenches :: IO 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 = bench (R.computeUnboxedS . R.zipWith (*) a) - -bench_mul_unb :: (Ring zq, U.Unbox zq) => U.Vector zq -> U.Vector zq -> Bench zq -bench_mul_unb a = bench (U.zipWith (*) a) - -vecLen :: Int -vecLen = 100 - -instance (U.Unbox zq, Random zq, MonadRandom rnd) => Generatable rnd (Arr zq) where - genArg = R.fromListUnboxed (R.Z R.:. vecLen) <$> replicateM vecLen getRandom - -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.5.0.2 +version: 0.6.0.0 synopsis: A library for lattice cryptography. homepage: https://github.com/cpeikert/Lol Bug-Reports: https://github.com/cpeikert/Lol/issues @@ -17,31 +17,16 @@ category: Crypto stability: experimental build-type: Simple -extra-source-files: README, CHANGES.md, - benchmarks/CycBenches.hs, - benchmarks/TensorBenches.hs, - benchmarks/UCycBenches.hs, - benchmarks/ZqBenches.hs, - tests/CycTests.hs, - tests/TensorTests.hs, - tests/ZqTests.hs, - utils/Apply.hs, - utils/Apply/Cyc.hs, - utils/Apply/Zq.hs, - utils/Benchmarks.hs, - utils/GenArgs.hs, - utils/GenArgs/Zq.hs, - utils/Tests.hs, - utils/TestTypes.hs, - utils/Utils.hs, - Crypto/Lol/Cyclotomic/Tensor/CTensor/*.h, - Crypto/Lol/Cyclotomic/Tensor/CTensor/*.cpp +extra-source-files: README, CHANGES.md, Lol.proto, RLWE.proto 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 - . + . + Backends for the library include + and . For example cryptographic applications, see . + source-repository head type: git location: https://github.com/cpeikert/Lol @@ -62,22 +47,6 @@ library default-language: Haskell2010 ghc-options: -fwarn-dodgy-imports - cc-options: -std=c++11 - Include-dirs: Crypto/Lol/Cyclotomic/Tensor/CTensor - -- Due to #12152, the file containing the definition of `Zq::q` must be linked first, - -- otherwise dynamic linking (`cabal repl` or `stack ghci`) results in the error: - -- "Loading temp shared object failed: /tmp/ghc54651_0/libghc_1.so: undefined symbol _ZN2Zq1qE" - -- For `cabal repl`, we can simply reorder the list so that the file that should be linked - -- first comes first in the list. However `stack ghci` always links alphabetically, - -- so we really just have to define `Zq::q` in the first file alphabetically. - C-sources: Crypto/Lol/Cyclotomic/Tensor/CTensor/common.cpp, - Crypto/Lol/Cyclotomic/Tensor/CTensor/crt.cpp, - Crypto/Lol/Cyclotomic/Tensor/CTensor/g.cpp, - Crypto/Lol/Cyclotomic/Tensor/CTensor/l.cpp, - Crypto/Lol/Cyclotomic/Tensor/CTensor/mul.cpp, - Crypto/Lol/Cyclotomic/Tensor/CTensor/norm.cpp, - Crypto/Lol/Cyclotomic/Tensor/CTensor/random.cpp, - Crypto/Lol/Cyclotomic/Tensor/CTensor/zq.cpp if flag(llvm) ghc-options: -fllvm -optlo-O3 @@ -105,123 +74,64 @@ Crypto.Lol.RLWE.RLWR Crypto.Lol.Cyclotomic.Tensor - Crypto.Lol.Cyclotomic.Tensor.CTensor - Crypto.Lol.Cyclotomic.Tensor.RepaTensor - - Crypto.Lol.Types.Random + Crypto.Lol.GaussRandom + Crypto.Lol.Types.Unsafe.Complex Crypto.Lol.Types.FiniteField Crypto.Lol.Types.IrreducibleChar2 + Crypto.Lol.Types.IZipVector Crypto.Lol.Types.Proto - Crypto.Lol.Types.RRq + Crypto.Lol.Types.Random + Crypto.Lol.Types.Unsafe.RRq + Crypto.Lol.Types.ZmStar Crypto.Lol.Types.ZPP - Crypto.Lol.Types.ZqBasic + Crypto.Lol.Types.Unsafe.ZqBasic + Crypto.Proto.Lol + Crypto.Proto.Lol.LinearRq + Crypto.Proto.Lol.R + Crypto.Proto.Lol.Rq1 + Crypto.Proto.Lol.RqProduct + Crypto.Proto.Lol.Kq1 + Crypto.Proto.Lol.KqProduct + Crypto.Proto.Lol.TypeRep Crypto.Proto.RLWE - Crypto.Proto.RLWE.Rq - Crypto.Proto.RLWE.Kq Crypto.Proto.RLWE.SampleCont Crypto.Proto.RLWE.SampleDisc Crypto.Proto.RLWE.SampleRLWR + Crypto.Proto.RLWE.SampleCont1 + Crypto.Proto.RLWE.SampleDisc1 + Crypto.Proto.RLWE.SampleRLWR1 - other-modules: + Crypto.Lol.Utils.GenArgs + Crypto.Lol.Utils.ShowType - Crypto.Lol.PosBin + other-modules: + Crypto.Lol.Cyclotomic.CRTSentinel 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.CRTSentinel - Crypto.Lol.Cyclotomic.Tensor.RepaTensor.CRT - Crypto.Lol.Cyclotomic.Tensor.RepaTensor.Extension - 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.Cyclotomic.Tensor.CTensor.Backend + Crypto.Lol.PosBin + Crypto.Lol.PosBinDefs build-depends: - arithmoi >= 0.4.1.3 && <0.5, - base>=4.8 && <5, - binary, + arithmoi >= 0.4.1.3, + base >= 4.9 && < 5, bytestring, constraints, - containers >= 0.5.6.2 && < 0.6, + containers >= 0.5.6.2, crypto-api, - data-default >= 0.3.0 && < 0.8, - deepseq >= 1.4.1.1 && <1.5, + data-default >= 0.3.0, + deepseq >= 1.4.1.1, + directory, monadcryptorandom, - MonadRandom >= 0.2 && < 0.5, - mtl >= 2.2.1 && < 2.3, - numeric-prelude >= 0.4.2 && < 0.5, - QuickCheck >= 2.8 && < 2.9, + MonadRandom >= 0.2, + mtl >= 2.2.1, + numeric-prelude >= 0.4.2, protocol-buffers, protocol-buffers-descriptor, - random >= 1.1 && < 1.2, - reflection >= 1.5.1 && < 2.2, - repa==3.4.*, - singletons >= 1.1.2.1 && < 2.2, - th-desugar >= 1.5.4 && < 1.7, - tagged-transformer >= 0.7 && < 0.9, - template-haskell >= 2.2.0.0, - transformers >= 0.4.2.0 && < 0.6, - vector==0.11.*, - vector-th-unbox >= 0.2.1.0 && < 0.3 - - other-extensions: TemplateHaskell - -test-suite test-lol - type: exitcode-stdio-1.0 - hs-source-dirs: tests,utils - default-language: Haskell2010 - main-is: Main.hs - - ghc-options: -threaded -rtsopts - - build-depends: - arithmoi, - base, - constraints, - deepseq, - DRBG, - lol, - MonadRandom, - mtl, - QuickCheck >= 2.8 && < 2.9, - random, - repa, - singletons, - test-framework >= 0.8 && < 0.9, - test-framework-quickcheck2 >= 0.3 && < 0.4, - 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: -O2 - -- ghc-options: -ddump-to-file -ddump-simpl - -- ghc-options: -dsuppress-coercions -dsuppress-type-applications -dsuppress-uniques -dsuppress-module-prefixes - - build-depends: - ansi-terminal, - arithmoi, - base, - containers, - criterion, - deepseq, - DRBG, - lol, - MonadRandom, - mtl, - singletons, - statistics, - transformers, - vector, - repa + random >= 1.1, + reflection >= 1.5.1, + singletons >= 1.1.2.1, + tagged-transformer >= 0.7, + template-haskell >= 2.2.0.0, + vector >=0.11, + vector-th-unbox >= 0.2.1.0 diff --git a/tests/CycTests.hs b/tests/CycTests.hs deleted file mode 100644 --- a/tests/CycTests.hs +++ /dev/null @@ -1,85 +0,0 @@ -{-# LANGUAGE DataKinds, FlexibleContexts, NoImplicitPrelude, PolyKinds, - ScopedTypeVariables, TypeOperators, TypeFamilies #-} -module CycTests (cycTests) where - -import Control.Monad (liftM2,join) - -import Crypto.Lol -import Crypto.Lol.Types -import Crypto.Lol.Types.ZPP - -import Utils -import Apply.Cyc -import Tests - -import qualified Test.Framework as TF - -cycTests :: [TF.Test] -cycTests = [ - testGroupM "mulGPow" $ applyBasic allParams $ hideArgs prop_mulgPow, - testGroupM "mulGDec" $ applyBasic allParams $ hideArgs prop_mulgDec, - testGroupM "mulGCRT" $ applyBasic allParams $ hideArgs prop_mulgCRT, - testGroupM "crtSet" $ applyBasis basisParams $ hideArgs prop_crtSet_pairs, - testGroupM "coeffsPow" $ applyTwoIdx basisParams $ hideArgs prop_coeffsBasis - ] - -prop_mulgPow :: (CElt t r, Fact m, Eq r, IntegralDomain r) => Cyc t m r -> Test '(t,m,r) -prop_mulgPow x = - let y = advisePow x - in test $ y == (fromJust' "prop_mulgPow failed divisibility!" $ divG $ mulG y) - -prop_mulgDec :: (CElt t r, Fact m, Eq r, IntegralDomain r) => Cyc t m r -> Test '(t,m,r) -prop_mulgDec x = - let y = adviseDec x - in test $ y == (fromJust' "prop_mulgDec failed divisibility!" $ divG $ mulG y) - -prop_mulgCRT :: (CElt t r, Fact m, Eq r, IntegralDomain r) => Cyc t m r -> Test '(t,m,r) -prop_mulgCRT x = - let y = adviseCRT x - in test $ y == (fromJust' "prop_mulgCRT failed divisibility!" $ divG $ mulG y) - -prop_coeffsBasis :: forall t m m' r . (m `Divides` m', CElt t r, Eq r) - => Cyc t m' r -> Test '(t,m,m',r) -prop_coeffsBasis x = - 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 -allParams :: Proxy AllParams -allParams = Proxy - -type BasisParams = ( '(,) <$> Tensors) <*> MM'RCombos -basisParams :: Proxy BasisParams -basisParams = Proxy diff --git a/tests/Main.hs b/tests/Main.hs deleted file mode 100644 --- a/tests/Main.hs +++ /dev/null @@ -1,14 +0,0 @@ - -import TensorTests -import CycTests -import ZqTests - -import Test.Framework - -main :: IO () -main = - 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 deleted file mode 100644 --- a/tests/TensorTests.hs +++ /dev/null @@ -1,337 +0,0 @@ -{-# LANGUAGE ConstraintKinds, FlexibleContexts, DataKinds, NoImplicitPrelude, - RebindableSyntax, ScopedTypeVariables, TypeFamilies, TypeOperators, - UndecidableInstances #-} - -module TensorTests (tensorTests) where - -import Apply.Cyc -import Tests -import Utils - -import TestTypes - -import Crypto.Lol -import Crypto.Lol.CRTrans -import Crypto.Lol.Cyclotomic.Tensor -import Crypto.Lol.Types - -import Control.Applicative - -import Data.Maybe - -import Data.Singletons -import Data.Promotion.Prelude.Eq -import Data.Singletons.TypeRepStar () - -import qualified Test.Framework as TF - -tensorTests :: [TF.Test] -tensorTests = - [testGroupM "fmapT comparison" $ applyBasic tmrParams $ hideArgs prop_fmapT, - testGroupM "fmap comparison" $ applyBasic tmrParams $ hideArgs prop_fmap, - testGroup "GInv.G == id" gInvGTests, - testGroupM "CRTInv.CRT == id" $ applyBasic tmrParams $ hideArgs prop_crt_inv, - testGroupM "LInv.L == id" $ applyBasic tmrParams $ hideArgs prop_l_inv, - testGroupM "Scalar" $ applyBasic tmrParams $ hideArgs prop_scalar_crt, - testGroup "G commutes with L" gCommuteTests, - testGroupM "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, CRTrans Maybe r) - => t m r -> Test '(t,m,r) -prop_ginv_crt x = test $ fromMaybe (error "no CRT in prop_ginv_crt") $ do - divGCRT' <- divGCRT - mulGCRT' <- mulGCRT - return $ (divGCRT' $ mulGCRT' x) == x \\ witness entailEqT x - -gInvGTests :: [TF.Test] -gInvGTests = [ - testGroupM "Pow basis" $ applyBasic tmrParams $ hideArgs prop_ginv_pow, - testGroupM "Dec basis" $ applyBasic tmrParams $ hideArgs prop_ginv_dec, - testGroupM "CRT basis" $ applyBasic tmrParams $ hideArgs prop_ginv_crt] - --- mulGDec == lInv. mulGPow . l -prop_g_dec :: (Tensor t, Ring r, Fact m, TElt t r, Eq r) => t m r -> Test '(t,m,r) -prop_g_dec x = test $ (mulGDec x) == (lInv $ mulGPow $ l x) \\ witness entailEqT x - -prop_g_crt :: (Tensor t, TElt t r, Fact m, Eq r, CRTrans Maybe r) - => t m r -> Test '(t,m,r) -prop_g_crt x = test $ fromMaybe (error "no CRT in prop_g_crt") $ do - mulGCRT' <- mulGCRT - crt' <- crt - crtInv' <- crtInv - return $ (mulGCRT' x) == (crt' $ mulGPow $ crtInv' x) \\ witness entailEqT x - -gCommuteTests :: [TF.Test] -gCommuteTests = [ - testGroupM "Dec basis" $ applyBasic tmrParams $ hideArgs prop_g_dec, - testGroupM "CRT basis" $ applyBasic tmrParams $ hideArgs prop_g_crt] - --- crtInv . crt == id -prop_crt_inv :: (Tensor t, TElt t r, Fact m, Eq r, CRTrans Maybe r) - => t m r -> Test '(t,m,r) -prop_crt_inv x = test $ fromMaybe (error "no CRT in prop_crt_inv") $ do - crt' <- crt - 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, CRTrans Maybe 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)) - -type NormCtx t m r = (TElt t r, TElt t (LiftOf r), - Fact m, Lift' r, CRTrans Maybe r, Eq (LiftOf r), - ZeroTestable r, Ring (LiftOf r), Ring r, IntegralDomain r) - -type NormWrapCtx m r = (NormCtx CT m r, NormCtx RT m r) - --- tests that gSqNormDec of two "random-looking" vectors agrees for RT and CT --- t is a dummy param -prop_gsqnorm :: forall (t :: Factored -> * -> *) m r . - (NormWrapCtx 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 Maybe r, Eq r, ZeroTestable r, IntegralDomain r) - --- groups related tests -tremTests :: [TF.Test] -tremTests = [ - testGroupM "Pow basis" $ applyTwoIdx tremParams $ hideArgs prop_trem_pow, - testGroupM "Dec basis" $ applyTwoIdx tremParams $ hideArgs prop_trem_dec, - testGroupM "CRT basis" $ applyTwoIdx tremParams $ hideArgs prop_trem_crt] - --- tests that twace . embed == id in the Pow basis -prop_trem_pow :: forall t m m' r . (TMM'RCtx t m m' r) - => 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 :: [TF.Test] -embedCommuteTests = [ - testGroupM "Dec basis" $ applyTwoIdx tremParams $ hideArgs prop_embed_dec, - testGroupM "CRT basis" $ applyTwoIdx tremParams $ hideArgs prop_embed_crt] - --- embedDec == lInv . embedPow . l -prop_embed_dec :: forall t m m' r . (TMM'RCtx t m m' r) => t m r -> Test '(t,m,m',r) -prop_embed_dec x = test $ (embedDec x :: t m' r) == (lInv $ embedPow $ l x) - \\ 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 :: [TF.Test] -twaceCommuteTests = [ - testGroupM "Dec basis" $ applyTwoIdx tremParams $ hideArgs prop_twace_dec, - testGroupM "CRT basis" $ applyTwoIdx tremParams $ hideArgs prop_twace_crt] - --- twacePowDec = lInv . twacePowDec . l -prop_twace_dec :: forall t m m' r . (TMM'RCtx t m m' r) => t m' r -> Test '(t,m,m',r) -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 :: [TF.Test] -twaceInvarTests = [ - testGroupM "Tw and Em ID for equal indices" $ applyBasic tmrParams $ hideArgs prop_twEmID, - testGroupM "Invar1 Pow basis" $ applyTwoIdx tremParams $ hideArgs prop_twace_invar1_pow, - testGroupM "Invar1 Dec basis" $ applyTwoIdx tremParams $ hideArgs prop_twace_invar1_dec, - testGroupM "Invar1 CRT basis" $ applyTwoIdx tremParams $ hideArgs prop_twace_invar1_crt, - testGroupM "Invar2 Pow/Dec basis" $ applyTwoIdx tremParams $ hideArgs prop_twace_invar2_powdec, - testGroupM "Invar2 CRT basis" $ applyTwoIdx tremParams $ hideArgs prop_twace_invar2_crt - ] - -prop_twEmID :: forall t m r . (Tensor t, TElt t r, CRTrans Maybe 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 -tmrParams :: Proxy TMRParams -tmrParams = Proxy - ---type ExtParams = ( '(,) <$> Tensors) <*> MRExtCombos -type TrEmParams = ( '(,) <$> Tensors) <*> MM'RCombos -tremParams :: Proxy TrEmParams -tremParams = Proxy - -type NormParams = ( '(,) <$> '[RT]) <*> (Filter Liftable MRCombos) - -data Liftable :: TyFun (Factored, *) Bool -> * -type instance Apply Liftable '(m,zq) = Int64 :== (LiftOf zq) diff --git a/tests/ZqTests.hs b/tests/ZqTests.hs deleted file mode 100644 --- a/tests/ZqTests.hs +++ /dev/null @@ -1,47 +0,0 @@ -{-# LANGUAGE DataKinds, FlexibleContexts, NoImplicitPrelude, - ScopedTypeVariables, TypeOperators #-} - -module ZqTests (zqTests) where - -import Apply.Zq -import Tests -import Utils - -import Crypto.Lol -import Crypto.Lol.CRTrans - -import qualified Test.Framework as TF - -zqTests :: [TF.Test] -zqTests = [ - testGroupM "(+)" $ applyBasic zqTypes $ hideArgs prop_add, - testGroupM "(*)" $ applyBasic zqTypes $ hideArgs prop_mul, - testGroupM "^-1" $ applyBasic zqTypes $ hideArgs prop_recip, - testGroupM "extension ring (*)" $ applyBasic zqTypes $ hideArgs prop_mul_ext - ] - -prop_add :: forall r . (Ring r, Eq r) => LiftedMod r -> LiftedMod r -> Test r -prop_add (LMod x) (LMod y) = test $ fromIntegral (x + y) == (fromIntegral x + fromIntegral y :: r) - -prop_mul :: forall r . (Ring r, Eq r) => LiftedInvertible r -> LiftedInvertible r -> Test r -prop_mul (LInv x) (LInv y) = test $ fromIntegral (x * y) == (fromIntegral x * fromIntegral y :: r) - -prop_recip :: forall r . (Field r, Eq r) => Invertible r -> Test r -prop_recip (Invertible x) = test $ one == (x * recip x) - --- tests that multiplication in the extension ring matches CRT multiplication -prop_mul_ext :: forall r . (CRTEmbed r, Eq r) - => Invertible r -> Invertible r -> Test r -prop_mul_ext (Invertible x) (Invertible y) = test $ - let z = x * y - z' = fromExt $ toExt x * toExt y - in z == z' - -type ZqTypes = [ - Zq 3, - Zq 7, - Zq (3 ** 5), - Zq (3 ** 5 ** 7)] - -zqTypes :: Proxy ZqTypes -zqTypes = Proxy diff --git a/utils/Apply.hs b/utils/Apply.hs deleted file mode 100644 --- a/utils/Apply.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# LANGUAGE DataKinds, FlexibleInstances, MultiParamTypeClasses, PolyKinds, - TypeFamilies, TypeOperators #-} - --- applies functions to proxy arguments -module Apply where - --- not associated due to the generic instance below: --- any definition of ArgsCtx would conflict with specific instances -data family ArgsCtx ctx - -class (params :: [k]) `Satisfy` (ctx :: *) where - run :: proxy params - -> (ArgsCtx ctx -> rnd res) - -> [rnd res] - -instance '[] `Satisfy` ctx where - run _ _ = [] diff --git a/utils/Apply/Cyc.hs b/utils/Apply/Cyc.hs deleted file mode 100644 --- a/utils/Apply/Cyc.hs +++ /dev/null @@ -1,127 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - -module Apply.Cyc where - -import Control.DeepSeq -import Control.Monad.Random - -import Crypto.Lol -import Crypto.Lol.Cyclotomic.Tensor -import Crypto.Lol.Types -import Crypto.Lol.Types.ZPP -import Crypto.Random.DRBG - -import Apply -import GenArgs -import Utils - -data BasicCtxD -type BasicCtx t m r = - (CElt t r, Fact m, IntegralDomain r, Random r, Eq r, NFElt r, ShowType '(t,m,r), - Random (t m r), m `Divides` m, NFData (t m r)) -data instance ArgsCtx BasicCtxD where - BC :: (BasicCtx t m r) => Proxy '(t,m,r) -> ArgsCtx BasicCtxD -instance (params `Satisfy` BasicCtxD, BasicCtx t m r) - => ( '(t, '(m,r)) ': params) `Satisfy` BasicCtxD where - run _ f = f (BC (Proxy::Proxy '(t,m,r))) : run (Proxy::Proxy params) f - -applyBasic :: (params `Satisfy` BasicCtxD, MonadRandom rnd) => - Proxy params - -> (forall t m r . (BasicCtx t m r, 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 - -data UnzipCtxD -type UnzipCtx t m r = - (Fact m, CElt t (r,r), Random (t m (r,r)), CElt t r, ShowType '(t,m,r), NFElt r, Random r, NFData (t m r)) -data instance ArgsCtx UnzipCtxD where - UzC :: (UnzipCtx t m r) => Proxy '(t,m,r) -> ArgsCtx UnzipCtxD -instance (params `Satisfy` UnzipCtxD, UnzipCtx t m r) - => ( '(t, '(m,r)) ': params) `Satisfy` UnzipCtxD where - run _ f = f (UzC (Proxy::Proxy '(t,m,r))) : run (Proxy::Proxy params) f - -applyUnzip :: (params `Satisfy` UnzipCtxD, MonadRandom rnd) => - Proxy params - -> (forall t m r . (UnzipCtx t m r, Generatable rnd (t m (r,r))) - => Proxy '(t,m,r) -> rnd res) - -> [rnd res] -applyUnzip params g = run params $ \(UzC 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), NFData (t m (LiftOf r))) -data instance ArgsCtx LiftCtxD where - LC :: (LiftCtx t m r) => Proxy '(t,m,r) -> ArgsCtx LiftCtxD -instance (params `Satisfy` LiftCtxD, LiftCtx t m r) - => ( '(t, '(m,r)) ': params) `Satisfy` LiftCtxD where - run _ f = f (LC (Proxy::Proxy '(t,m,r))) : run (Proxy::Proxy params) f - -applyLift :: (params `Satisfy` LiftCtxD, MonadRandom rnd) => - Proxy params - -> (forall t m r . (LiftCtx t m r, Generatable rnd r) => Proxy '(t,m,r) -> rnd res) - -> [rnd res] -applyLift params g = run params $ \(LC p) -> g p - --- similar to LiftCtxD, but with a `gen` param -data ErrorCtxD -type ErrorCtx t m r gen = (CElt t r, Fact m, ShowType '(t,m,r,gen), - CElt t (LiftOf r), NFElt (LiftOf r), Lift' r, - ToInteger (LiftOf r), CryptoRandomGen gen, NFData (t m (LiftOf r))) -data instance ArgsCtx ErrorCtxD where - EC :: (ErrorCtx t m r gen) => Proxy '(t,m,r,gen) -> ArgsCtx ErrorCtxD -instance (params `Satisfy` ErrorCtxD, ErrorCtx t m r gen) - => ( '(gen, '(t, '(m,r))) ': params) `Satisfy` ErrorCtxD where - run _ f = f (EC (Proxy::Proxy '(t,m,r,gen))) : run (Proxy::Proxy params) f - -applyError :: (params `Satisfy` ErrorCtxD) => - Proxy params - -> (forall t m r gen . (ErrorCtx t m r gen) => Proxy '(t,m,r,gen) -> rnd res) - -> [rnd res] -applyError params g = run params $ \(EC p) -> g p - - -data TwoIdxCtxD -type TwoIdxCtx t m m' r = (m `Divides` m', CElt t r, IntegralDomain r, Eq r, Random r, NFElt r, - ShowType '(t,m,m',r), Random (t m r), Random (t m' r), NFData (t m r), NFData (t m' r)) -data instance ArgsCtx TwoIdxCtxD where - TI :: (TwoIdxCtx t m m' r) => Proxy '(t,m,m',r) -> ArgsCtx TwoIdxCtxD -instance (params `Satisfy` TwoIdxCtxD, TwoIdxCtx t m m' r) - => ( '(t, '(m,m',r)) ': params) `Satisfy` TwoIdxCtxD where - run _ f = f (TI (Proxy::Proxy '(t,m,m',r))) : run (Proxy::Proxy params) f - -applyTwoIdx :: (params `Satisfy` TwoIdxCtxD, MonadRandom rnd) => - Proxy params - -> (forall t m m' r . (TwoIdxCtx t m m' r, Generatable rnd (t m r), Generatable rnd (t m' r)) - => Proxy '(t,m,m',r) -> rnd res) - -> [rnd res] -applyTwoIdx params g = run params $ \(TI p) -> g p - --- similar to TwoIdxCtxD, but r must be a prime-power -data BasisCtxD -type BasisCtx t m m' r = (m `Divides` m', Eq r, ZPP r, CElt t r, CElt t (ZpOf r), ShowType '(t,m,m',r)) -data instance ArgsCtx BasisCtxD where - BsC :: (BasisCtx t m m' r) => Proxy '(t,m,m',r) -> ArgsCtx BasisCtxD -instance (params `Satisfy` BasisCtxD, BasisCtx t m m' r) - => ( '(t, '(m,m',r)) ': params) `Satisfy` BasisCtxD where - run _ f = f (BsC (Proxy::Proxy '(t,m,m',r))) : run (Proxy::Proxy params) f - -applyBasis :: (params `Satisfy` BasisCtxD) => - Proxy params - -> (forall t m m' r . (BasisCtx t m m' r) => Proxy '(t,m,m',r) -> rnd res) - -> [rnd res] -applyBasis params g = run params $ \(BsC p) -> g p diff --git a/utils/Apply/Zq.hs b/utils/Apply/Zq.hs deleted file mode 100644 --- a/utils/Apply/Zq.hs +++ /dev/null @@ -1,37 +0,0 @@ -{-# LANGUAGE ConstraintKinds, DataKinds, FlexibleContexts, FlexibleInstances, - GADTs, MultiParamTypeClasses, NoImplicitPrelude, RankNTypes, - RebindableSyntax, ScopedTypeVariables, TypeFamilies, TypeOperators, - UndecidableInstances #-} - -module Apply.Zq -(applyBasic -,LiftedMod(..) -,LiftedInvertible(..) -,Invertible(..)) where - -import Apply -import GenArgs -import GenArgs.Zq -import Utils - -import Control.Monad.Random - -import Crypto.Lol -import Crypto.Lol.CRTrans - -data BasicCtxD -type BasicCtx r = - (Field r, Eq r, Random r, Random (ModRep r), ToInteger (ModRep r), - PID (ModRep r), ShowType r, CRTEmbed r, Mod r) -data instance ArgsCtx BasicCtxD where - BC :: (BasicCtx r) => Proxy r -> ArgsCtx BasicCtxD -instance (params `Satisfy` BasicCtxD, BasicCtx r) - => ( r ': params) `Satisfy` BasicCtxD where - run _ f = f (BC (Proxy::Proxy r)) : run (Proxy::Proxy params) f - -applyBasic :: (params `Satisfy` BasicCtxD, MonadRandom rnd) => - Proxy params - -> (forall r . (BasicCtx r, Generatable rnd r, Generatable rnd (Invertible r)) - => Proxy r -> rnd res) - -> [rnd res] -applyBasic params g = run params $ \(BC p) -> g p diff --git a/utils/Benchmarks.hs b/utils/Benchmarks.hs deleted file mode 100644 --- a/utils/Benchmarks.hs +++ /dev/null @@ -1,44 +0,0 @@ -{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, - PolyKinds, RankNTypes, ScopedTypeVariables, TypeFamilies #-} - -module Benchmarks -(Benchmarks.bench -,benchIO -,benchGroup -,hideArgs -,Bench(..) -,Benchmark -,NFData) where - -import GenArgs -import Utils - -import Control.DeepSeq -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/GenArgs.hs b/utils/GenArgs.hs deleted file mode 100644 --- a/utils/GenArgs.hs +++ /dev/null @@ -1,31 +0,0 @@ -{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TypeFamilies #-} - --- generates arguments to functions -module GenArgs where - -import Control.Monad.Random -import Data.Proxy - --- bnch represents a function whose arguments can be generated, --- resulting in a "NFValue" -class GenArgs rnd bnch where - type ResultOf bnch - genArgs :: bnch -> rnd (ResultOf bnch) - -instance (Generatable rnd a, GenArgs rnd b, - Monad rnd, ResultOf b ~ ResultOf (a -> b)) - => GenArgs rnd (a -> b) where - type ResultOf (a -> b) = ResultOf b - genArgs f = do - x <- genArg - genArgs $ f x - --- a parameter that can be generated using a particular monad -class Generatable rnd arg where - genArg :: rnd arg - -instance {-# Overlappable #-} (Random a, MonadRandom rnd) => Generatable rnd a where - genArg = getRandom - -instance (Monad rnd) => Generatable rnd (Proxy a) where - genArg = return Proxy diff --git a/utils/GenArgs/Zq.hs b/utils/GenArgs/Zq.hs deleted file mode 100644 --- a/utils/GenArgs/Zq.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-# LANGUAGE FlexibleContexts, FlexibleInstances, GADTs, MultiParamTypeClasses, - NoImplicitPrelude, RebindableSyntax, ScopedTypeVariables, - UndecidableInstances #-} - -module GenArgs.Zq where - -import GenArgs - -import Control.Applicative -import Control.Monad.Random - -import Crypto.Lol - -data LiftedMod r where - LMod :: (ToInteger (ModRep r)) => ModRep r -> LiftedMod r - -data LiftedInvertible r where - LInv :: (ToInteger (ModRep r)) => ModRep r -> LiftedInvertible r - -newtype Invertible r = Invertible r - -instance (MonadRandom rnd, Mod r, Random (ModRep r), ToInteger (ModRep r)) - => Generatable rnd (LiftedMod r) where - genArg = - let q = proxy modulus (Proxy::Proxy r) - in LMod <$> getRandomR (0,q-1) - -instance (MonadRandom rnd, Mod r, Random (ModRep r), PID (ModRep r), ToInteger (ModRep r)) - => Generatable rnd (LiftedInvertible r) where - genArg = - let q = proxy modulus (Proxy::Proxy r) - go = do - x <- getRandomR (1,q-1) - if gcd x q == 1 - then return $ LInv x - else go - in go - -instance (MonadRandom rnd, Generatable rnd (LiftedInvertible r), Ring r) - => Generatable rnd (Invertible r) where - genArg = do - (LInv x) :: LiftedInvertible r <- genArg - return $ Invertible $ fromIntegral x diff --git a/utils/TestTypes.hs b/utils/TestTypes.hs deleted file mode 100644 --- a/utils/TestTypes.hs +++ /dev/null @@ -1,38 +0,0 @@ -{-# LANGUAGE ConstraintKinds, DataKinds, FlexibleContexts, - FlexibleInstances, MultiParamTypeClasses, - NoImplicitPrelude, PolyKinds, RankNTypes, RebindableSyntax, - ScopedTypeVariables, TypeFamilies, TypeOperators #-} - -module TestTypes -(SmoothQ1, SmoothQ2, SmoothQ3 -,SmoothZQ1, SmoothZQ2, SmoothZQ3 -,Zq -,ZQ1,ZQ2,ZQ3) where - -import Control.Monad.Random - -import Crypto.Lol - -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 deleted file mode 100644 --- a/utils/Tests.hs +++ /dev/null @@ -1,47 +0,0 @@ -{-# LANGUAGE FlexibleContexts, FlexibleInstances, GADTs, MultiParamTypeClasses, - PolyKinds, RankNTypes, ScopedTypeVariables, TypeFamilies #-} -module Tests -(test -,testIO -,TF.testGroup -,testGroupM -,hideArgs -,Test(..)) where - -import GenArgs -import Utils - -import Control.Monad.Random - -import Data.Proxy - -import qualified Test.Framework as TF -import Test.Framework.Providers.QuickCheck2 - -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 deleted file mode 100644 --- a/utils/Utils.hs +++ /dev/null @@ -1,116 +0,0 @@ -{-# LANGUAGE ConstraintKinds, DataKinds, FlexibleContexts, FlexibleInstances, - GADTs, KindSignatures, MultiParamTypeClasses, PolyKinds, - RankNTypes, ScopedTypeVariables, TypeFamilies, TypeOperators, - UndecidableInstances #-} - -module Utils -(Zq -,type (**) -,type (<$>) -,type (<*>) - -,module Data.Promotion.Prelude.List -,showType -,ShowType) where - -import Crypto.Lol (Int64,Fact,valueFact,Mod(..), Proxy(..), proxy, TrivGad, BaseBGad) -import Crypto.Lol.Reflects -import Crypto.Lol.Cyclotomic.Tensor.RepaTensor -import Crypto.Lol.Cyclotomic.Tensor.CTensor -import Crypto.Lol.Types.ZqBasic -import Crypto.Random.DRBG - -import Data.Promotion.Prelude.List - -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))