diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,339 @@ + GNU GENERAL PUBLIC LICENSE + Version 2, June 1991 + + Copyright (C) 1989, 1991 Free Software Foundation, Inc., + 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +License is intended to guarantee your freedom to share and change free +software--to make sure the software is free for all its users. This +General Public License applies to most of the Free Software +Foundation's software and to any other program whose authors commit to +using it. (Some other Free Software Foundation software is covered by +the GNU Lesser General Public License instead.) You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +this service if you wish), that you receive source code or can get it +if you want it, that you can change the software or use pieces of it +in new free programs; and that you know you can do these things. + + To protect your rights, we need to make restrictions that forbid +anyone to deny you these rights or to ask you to surrender the rights. +These restrictions translate to certain responsibilities for you if you +distribute copies of the software, or if you modify it. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must give the recipients all the rights that +you have. You must make sure that they, too, receive or can get the +source code. And you must show them these terms so they know their +rights. + + We protect your rights with two steps: (1) copyright the software, and +(2) offer you this license which gives you legal permission to copy, +distribute and/or modify the software. + + Also, for each author's protection and ours, we want to make certain +that everyone understands that there is no warranty for this free +software. If the software is modified by someone else and passed on, we +want its recipients to know that what they have is not the original, so +that any problems introduced by others will not reflect on the original +authors' reputations. + + Finally, any free program is threatened constantly by software +patents. We wish to avoid the danger that redistributors of a free +program will individually obtain patent licenses, in effect making the +program proprietary. To prevent this, we have made it clear that any +patent must be licensed for everyone's free use or not licensed at all. + + The precise terms and conditions for copying, distribution and +modification follow. + + GNU GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License applies to any program or other work which contains +a notice placed by the copyright holder saying it may be distributed +under the terms of this General Public License. The "Program", below, +refers to any such program or work, and a "work based on the Program" +means either the Program or any derivative work under copyright law: +that is to say, a work containing the Program or a portion of it, +either verbatim or with modifications and/or translated into another +language. (Hereinafter, translation is included without limitation in +the term "modification".) Each licensee is addressed as "you". + +Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running the Program is not restricted, and the output from the Program +is covered only if its contents constitute a work based on the +Program (independent of having been made by running the Program). +Whether that is true depends on what the Program does. + + 1. You may copy and distribute verbatim copies of the Program's +source code as you receive it, in any medium, provided that you +conspicuously and appropriately publish on each copy an appropriate +copyright notice and disclaimer of warranty; keep intact all the +notices that refer to this License and to the absence of any warranty; +and give any other recipients of the Program a copy of this License +along with the Program. + +You may charge a fee for the physical act of transferring a copy, and +you may at your option offer warranty protection in exchange for a fee. + + 2. You may modify your copy or copies of the Program or any portion +of it, thus forming a work based on the Program, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) You must cause the modified files to carry prominent notices + stating that you changed the files and the date of any change. + + b) You must cause any work that you distribute or publish, that in + whole or in part contains or is derived from the Program or any + part thereof, to be licensed as a whole at no charge to all third + parties under the terms of this License. + + c) If the modified program normally reads commands interactively + when run, you must cause it, when started running for such + interactive use in the most ordinary way, to print or display an + announcement including an appropriate copyright notice and a + notice that there is no warranty (or else, saying that you provide + a warranty) and that users may redistribute the program under + these conditions, and telling the user how to view a copy of this + License. (Exception: if the Program itself is interactive but + does not normally print such an announcement, your work based on + the Program is not required to print an announcement.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Program, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Program, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Program. + +In addition, mere aggregation of another work not based on the Program +with the Program (or with a work based on the Program) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may copy and distribute the Program (or a work based on it, +under Section 2) in object code or executable form under the terms of +Sections 1 and 2 above provided that you also do one of the following: + + a) Accompany it with the complete corresponding machine-readable + source code, which must be distributed under the terms of Sections + 1 and 2 above on a medium customarily used for software interchange; or, + + b) Accompany it with a written offer, valid for at least three + years, to give any third party, for a charge no more than your + cost of physically performing source distribution, a complete + machine-readable copy of the corresponding source code, to be + distributed under the terms of Sections 1 and 2 above on a medium + customarily used for software interchange; or, + + c) Accompany it with the information you received as to the offer + to distribute corresponding source code. (This alternative is + allowed only for noncommercial distribution and only if you + received the program in object code or executable form with such + an offer, in accord with Subsection b above.) + +The source code for a work means the preferred form of the work for +making modifications to it. For an executable work, complete source +code means all the source code for all modules it contains, plus any +associated interface definition files, plus the scripts used to +control compilation and installation of the executable. However, as a +special exception, the source code distributed need not include +anything that is normally distributed (in either source or binary +form) with the major components (compiler, kernel, and so on) of the +operating system on which the executable runs, unless that component +itself accompanies the executable. + +If distribution of executable or object code is made by offering +access to copy from a designated place, then offering equivalent +access to copy the source code from the same place counts as +distribution of the source code, even though third parties are not +compelled to copy the source along with the object code. + + 4. You may not copy, modify, sublicense, or distribute the Program +except as expressly provided under this License. Any attempt +otherwise to copy, modify, sublicense or distribute the Program is +void, and will automatically terminate your rights under this License. +However, parties who have received copies, or rights, from you under +this License will not have their licenses terminated so long as such +parties remain in full compliance. + + 5. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Program or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Program (or any work based on the +Program), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Program or works based on it. + + 6. Each time you redistribute the Program (or any work based on the +Program), the recipient automatically receives a license from the +original licensor to copy, distribute or modify the Program subject to +these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties to +this License. + + 7. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Program at all. For example, if a patent +license would not permit royalty-free redistribution of the Program by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Program. + +If any portion of this section is held invalid or unenforceable under +any particular circumstance, the balance of the section is intended to +apply and the section as a whole is intended to apply in other +circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system, which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 8. If the distribution and/or use of the Program is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Program under this License +may add an explicit geographical distribution limitation excluding +those countries, so that distribution is permitted only in or among +countries not thus excluded. In such case, this License incorporates +the limitation as if written in the body of this License. + + 9. The Free Software Foundation may publish revised and/or new versions +of the General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + +Each version is given a distinguishing version number. If the Program +specifies a version number of this License which applies to it and "any +later version", you have the option of following the terms and conditions +either of that version or of any later version published by the Free +Software Foundation. If the Program does not specify a version number of +this License, you may choose any version ever published by the Free Software +Foundation. + + 10. If you wish to incorporate parts of the Program into other free +programs whose distribution conditions are different, write to the author +to ask for permission. For software which is copyrighted by the Free +Software Foundation, write to the Free Software Foundation; we sometimes +make exceptions for this. Our decision will be guided by the two goals +of preserving the free status of all derivatives of our free software and +of promoting the sharing and reuse of software generally. + + NO WARRANTY + + 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY +FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN +OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES +PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED +OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS +TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE +PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, +REPAIR OR CORRECTION. + + 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR +REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, +INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING +OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED +TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY +YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER +PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGES. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +convey the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License along + with this program; if not, write to the Free Software Foundation, Inc., + 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + +Also add information on how to contact you by electronic and paper mail. + +If the program is interactive, make it output a short notice like this +when it starts in an interactive mode: + + Gnomovision version 69, Copyright (C) year name of author + Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, the commands you use may +be called something other than `show w' and `show c'; they could even be +mouse-clicks or menu items--whatever suits your program. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the program, if +necessary. Here is a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the program + `Gnomovision' (which makes passes at compilers) written by James Hacker. + + , 1 April 1989 + Ty Coon, President of Vice + +This General Public License does not permit incorporating your program into +proprietary programs. If your program is a subroutine library, you may +consider it more useful to permit linking proprietary applications with the +library. If this is what you want to do, use the GNU Lesser General +Public License instead of this License. diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,38 @@ +Overview of key modules, roughly from highest- to lowest-level: + +* SymmSHE.hs, an implementation of a symmetric-key, + somewhat-homomorphic encryption scheme that is essentially + equivalent to the one from the toolkit paper [LPR'13]. + +* Cyc.hs, which defines an interface for using cyclotomic fields, + rings R, and quotient rings Rq=R/qR; as well as many other + commonly used operations, e.g., converting + between rings, decoding and decomposing elements, modulus + reduction/rounding, etc. etc. Cyc is a safe wrapper around the + UCyc type, which exposes some representation-dependent operations. + UCyc (and hence Cyc) is implemented using a generic Tensor (described below). + +* Tensor.hs, which defines a class that encapsulates all the necessary + linear transformations for operating on representations of R- and + Rq-elements, e.g., the CRT transform, converting between the + powerful and decoding bases, generating error terms, etc. + +* RepaTensor.hs, which gives an + implementation of the Tensor class based on the "repa" + package, a highly optimized and parallelizable array library. + +* CTensor.hs, which gives an + implementation of the Tensor class using a C backend via Haskell's FFI. + +* FiniteField.hs, which gives an unoptimized implementation of finite field + arithmetic. To use this module, you will need an instance of IrreduciblePoly. + These instances provide irreducible polynomials for various degrees and base fields. + One instance is provided for characteristic 2 fields of size up to 2^32 in + IrreducibleChar2.hs. + +* ZqBasic.hs, which is a basic implementation of Zq=Z/qZ arithmetic. + +* Factored.hs, which contains support code for "reifying" + runtime-chosen integers as static types (mainly, the types q and m + that are floating around as parameters of many other data types), + and "reflecting" those types as integers back to the code. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/lol.cabal b/lol.cabal new file mode 100644 --- /dev/null +++ b/lol.cabal @@ -0,0 +1,160 @@ +name: lol +-- The package version. See the Haskell package versioning policy (PVP) +-- for standards guiding when and how versions should be incremented. +-- http://www.haskell.org/haskellwiki/Package_versioning_policy +-- PVP summary: +-+------- breaking API changes +-- | | +----- non-breaking API additions +-- | | | +--- code changes with no API change +version: 0.0.1.0 +synopsis: A general-purpose library for lattice cryptography. +homepage: https://github.com/cpeikert/Lol +Bug-Reports: https://github.com/cpeikert/Lol/issues +license: GPL-2 +license-file: LICENSE +author: Eric Crockett, Chris Peikert +maintainer: Eric Crockett +copyright: Eric Crockett, Chris Peikert +category: Crypto +stability: experimental +build-type: Simple +extra-source-files: README, + src/Crypto/Lol/Cyclotomic/Tensor/CTensor/tensorTypes.h, + test-suite/CycTests.hs, + test-suite/SHETests.hs, + test-suite/TensorTests.hs, + test-suite/TestTypes.hs, + test-suite/ZqTests.hs +cabal-version: >=1.10 +description: \\Lambda \\ocirc \\lambda is a general-purpose library for ring-based lattice cryptography. +source-repository head + type: git + location: https://github.com/cpeikert/Lol + +-- For information on compiling C with cabal: http://blog.ezyang.com/2010/06/setting-up-cabal-the-ffi-and-c2hs/ + +Flag useICC + Description: Use ICC instead of GCC to compile C backend. + Default: False + +Flag llvm + Description: Compile via LLVM. This produces much better object code, + but you need to have the LLVM compiler installed. + + Default: False + +library + hs-source-dirs: src + Include-dirs: src/Crypto/Lol/Cyclotomic/Tensor/CTensor + C-sources: src/Crypto/Lol/Cyclotomic/Tensor/CTensor/basic.c, + src/Crypto/Lol/Cyclotomic/Tensor/CTensor/crt.c, + src/Crypto/Lol/Cyclotomic/Tensor/CTensor/g.c, + src/Crypto/Lol/Cyclotomic/Tensor/CTensor/generalfuncs.c, + src/Crypto/Lol/Cyclotomic/Tensor/CTensor/l.c, + src/Crypto/Lol/Cyclotomic/Tensor/CTensor/random.c + Includes: src/Crypto/Lol/Cyclotomic/Tensor/CTensor/tensorTypes.h + default-language: Haskell2010 + + if flag(useICC) + ghc-options: -pgml icc -optc-O3 + cc-options: -std=gnu99 -Wall -DSTATS -DCINTRIN + else + ghc-options: -pgml gcc -fPIC -optc-O3 + cc-options: -std=gnu99 -fPIC -Wall + + if flag(llvm) + ghc-options: -fllvm -optlo-O3 + + -- ghc optimizations + ghc-options: -O3 -Odph -funbox-strict-fields -fwarn-dodgy-imports -rtsopts + ghc-options: -fno-liberate-case -funfolding-use-threshold1000 -funfolding-keeness-factor1000 + + exposed-modules: + Crypto.Lol + Crypto.Lol.CRTrans + Crypto.Lol.Gadget + Crypto.Lol.LatticePrelude + + Crypto.Lol.Applications.SymmSHE + Crypto.Lol.Cyclotomic.Tensor + Crypto.Lol.Factored + + Crypto.Lol.Cyclotomic.Cyc + Crypto.Lol.Cyclotomic.UCyc + Crypto.Lol.Cyclotomic.Utility + + Crypto.Lol.Cyclotomic.Linear + + Crypto.Lol.Cyclotomic.Tensor.CTensor + Crypto.Lol.Cyclotomic.Tensor.RepaTensor + + Crypto.Lol.Types.FiniteField + Crypto.Lol.Types.PrimeField + Crypto.Lol.Types.IrreducibleChar2 + + Crypto.Lol.Types.ZPP + Crypto.Lol.Types.ZqBasic + + Crypto.Lol.Reflects + + other-modules: + + Crypto.Lol.Types.ZmStar + Crypto.Lol.GaussRandom + Crypto.Lol.Types.Complex + Crypto.Lol.Types.IZipVector + Crypto.Lol.Cyclotomic.Tensor.RepaTensor.CRT + Crypto.Lol.Cyclotomic.Tensor.RepaTensor.Extension + Crypto.Lol.Cyclotomic.Tensor.RepaTensor.Gauss + Crypto.Lol.Cyclotomic.Tensor.RepaTensor.GL + Crypto.Lol.Cyclotomic.Tensor.RepaTensor.RTCommon + + Crypto.Lol.Cyclotomic.Tensor.CTensor.Extension + Crypto.Lol.Types.Numeric + + build-depends: + arithmoi>=0.4.1.3 && <0.5, + base==4.8.*, + constraints==0.4.*, + containers>=0.5.6.2 && < 0.6, + data-default>=0.3.0 && < 0.6, + deepseq>=1.4.1.1 && <1.5, + MonadRandom>=0.2 && < 0.5, + mtl>=2.2.1 && < 2.3, + numeric-prelude>=0.4.2 && < 0.5, + QuickCheck>=2.8 && < 2.9, + random>=1.1 && < 1.2, + reflection>=1.5.1 && < 2.2, + repa==3.4.*, + singletons>=1.1.2.1 && < 2.1, + storable-record>=0.0.3 && < 0.1, + storable-tuple>=0.0.1 && < 0.1, + th-desugar>=1.5.4 && < 1.6, + type-natural>=0.2.3.2 && < 0.4, + tagged-transformer>=0.7 && < 0.9, + transformers>=0.4.2.0 && < 0.5, + vector==0.11.*, + vector-th-unbox>=0.2.1.0 && < 0.3 + + other-extensions: TemplateHaskell + +test-suite lol-test-suite + type: exitcode-stdio-1.0 + hs-source-dirs: test-suite + default-language: Haskell2010 + main-is: Main.hs + + -- ghc optimizations + ghc-options: -threaded -rtsopts + + build-depends: + base, + constraints, + lol, + MonadRandom, + QuickCheck>=2.8 && < 2.9, + repa, + test-framework >= 0.8 && < 0.9, + test-framework-quickcheck2 >= 0.3 && < 0.4, + time>=1.2 && < 1.6, + type-natural, + vector diff --git a/src/Crypto/Lol.hs b/src/Crypto/Lol.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/Lol.hs @@ -0,0 +1,21 @@ + +-- | Re-exports primary interfaces. + +module Crypto.Lol +( module Crypto.Lol.Cyclotomic.Cyc +, module Crypto.Lol.Gadget +, module Crypto.Lol.LatticePrelude + +, module Crypto.Lol.Types.ZqBasic +, module Crypto.Lol.Cyclotomic.Tensor.CTensor +, module Crypto.Lol.Cyclotomic.Tensor.RepaTensor +, module Crypto.Lol.Types.IrreducibleChar2) where + +import Crypto.Lol.Cyclotomic.Cyc +import Crypto.Lol.Gadget +import Crypto.Lol.LatticePrelude + +import Crypto.Lol.Types.ZqBasic +import Crypto.Lol.Cyclotomic.Tensor.CTensor +import Crypto.Lol.Cyclotomic.Tensor.RepaTensor +import Crypto.Lol.Types.IrreducibleChar2 diff --git a/src/Crypto/Lol/Applications/SymmSHE.hs b/src/Crypto/Lol/Applications/SymmSHE.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/Lol/Applications/SymmSHE.hs @@ -0,0 +1,496 @@ +{-# LANGUAGE ConstraintKinds, DataKinds, DeriveDataTypeable, + FlexibleContexts, FlexibleInstances, GADTs, + MultiParamTypeClasses, NoImplicitPrelude, ScopedTypeVariables, + TypeFamilies, TypeOperators, UndecidableInstances #-} + +-- | Symmetric-key somewhat homomorphic encryption. + +module Crypto.Lol.Applications.SymmSHE +( +-- * Data types +SK, PT, CT -- don't export constructors! +-- * Keygen, encryption, decryption +, genSK +, encrypt +, errorTerm, errorTermUnrestricted, decrypt, decryptUnrestricted +-- * Encoding of plaintext +, toMSD, toLSD +-- * Arithmetic with public values +, addScalar, addPublic, mulPublic +-- * Modulus switching +, rescaleLinearCT, modSwitchPT +-- * Key switching +, keySwitchLinear, keySwitchQuadCirc +-- * Ring switching +, embedSK, embedCT, twaceCT +, tunnelCT +-- * Constraint synonyms +, AddPublicCtx, MulPublicCtx, KeySwitchCtx, KSHintCtx, ModSwitchPTCtx +, ToSDCtx, EncryptCtx, TunnelCtx, GenSKCtx, DecryptCtx +, ErrorTermCtx +) where + +import qualified Algebra.Additive as Additive (C) +import qualified Algebra.Ring as Ring (C) + +import Crypto.Lol.Cyclotomic.Cyc +import Crypto.Lol.Cyclotomic.UCyc (forceDec) +import Crypto.Lol.Cyclotomic.Linear +import Crypto.Lol.Gadget +import Crypto.Lol.LatticePrelude as LP hiding (sin) + +import Control.Applicative hiding ((*>)) +import Control.DeepSeq +import Control.Monad as CM +import Control.Monad.Random +import Data.Maybe +import Data.Traversable as DT +import Data.Typeable + +import MathObj.Polynomial as P + +-- | secret key +data SK r where + SK :: (ToRational v, NFData v) => v -> r -> SK r + +-- | plaintext +type PT rp = rp + +-- | Ciphertext encoding type +data Encoding = MSD | LSD deriving (Show, Eq) + +-- | Ciphertext over @R'_q@, encrypting a plaintext in @R_p (R=O_m)@. +data CT (m :: Factored) zp r'q = + CT + !Encoding -- MSD/LSD encoding + !Int -- accumulated power of g_m' in c(s) + !zp -- factor to mul by upon decryption + !(Polynomial r'q) -- the polynomial c(s) + deriving (Typeable, Show) + +-- Note: do *not* give an Eq instance for CT, because it's not +-- meaningful to compare ciphertexts for equality + +instance (NFData zp, NFData r'q) => NFData (CT m zp r'q) where + rnf (CT _ k sc cs) = rnf k `seq` rnf sc `seq` rnf cs + +instance (NFData r) => NFData (SK r) where + rnf (SK v s) = rnf v `seq` rnf s + +---------- Basic functions: Gen, Enc, Dec ---------- + +-- | Constraint synonym for generating a secret key. +type GenSKCtx t m z v = + (ToInteger z, Fact m, CElt t z, ToRational v, NFData v) + +-- | Generates a secret key with (index-independent) scaled variance +-- parameter @v@; see 'errorRounded'. +genSK :: (GenSKCtx t m z v, MonadRandom rnd) + => v -> rnd (SK (Cyc t m z)) +genSK v = liftM (SK v) $ errorRounded v + +-- | Constraint synonym for encryption. +type EncryptCtx t m m' z zp zq = + (Mod zp, Ring zp, Ring zq, Lift zp (ModRep zp), + Reduce z zq, Reduce (LiftOf zp) zq, + CElt t zq, CElt t zp, CElt t z, CElt t (LiftOf zp), + m `Divides` m') + +-- | Encrypt a plaintext under a secret key. +encrypt :: forall t m m' z zp zq e rnd . (EncryptCtx t m m' z zp zq, MonadRandom rnd) + => SK (Cyc t m' z) -> PT (Cyc t m zp) -> rnd (CT m zp (Cyc t m' zq)) +encrypt (SK svar s) = + let sq = reduce s + in (\pt -> do + e <- errorCoset svar (embed pt :: PT (Cyc t m' zp)) + c1 <- getRandom + return $! CT LSD zero one $ fromCoeffs [reduce e - c1 * sq, c1]) + +-- | Constraint synonym for extracting the error term of a ciphertext. +type ErrorTermCtx t m' z zp zq = + (Reduce z zq, Lift' zq, CElt t z, CElt t (LiftOf zq), + ToSDCtx t m' zp zq) + +-- | Extract the error term of a ciphertext. +errorTerm :: (ErrorTermCtx t m' z zp zq) + => SK (Cyc t m' z) -> CT m zp (Cyc t m' zq) -> Cyc t m' (LiftOf zq) +errorTerm (SK _ s) = let sq = reduce s in + \ct -> let (CT LSD _ _ c) = toLSD ct + in liftCyc Dec $ evaluate c sq + +-- for when we know the division must succeed +divG' :: (Fact m, CElt t r) => Cyc t m r -> Cyc t m r +divG' = fromJust . divG + +-- | Constraint synonym for decryption. +type DecryptCtx t m m' z zp zq = + (ErrorTermCtx t m' z zp zq, Reduce (LiftOf zq) zp, + m `Divides` m', CElt t zp) + +-- | Decrypt a ciphertext. +decrypt :: forall t m m' z zp zq . (DecryptCtx t m m' z zp zq) + => SK (Cyc t m' z) -> CT m zp (Cyc t m' zq) -> PT (Cyc t m zp) +decrypt sk ct = + let ct'@(CT LSD k l _) = toLSD ct + in let e :: Cyc t m' zp = reduce $ errorTerm sk ct' + in (scalarCyc l) * twace (iterate divG' e !! k) + +--- unrestricted versions --- + +-- | More general form of 'errorTerm' that works for unrestricted +-- output coefficient types. +errorTermUnrestricted :: + (Reduce z zq, Lift' zq, CElt t z, ToSDCtx t m' zp zq) + => SK (Cyc t m' z) -> CT m zp (Cyc t m' zq) -> Cyc t m' (LiftOf zq) +errorTermUnrestricted (SK _ s) = let sq = reduce s in + \ct -> let (CT LSD _ _ c) = toLSD ct + eval = evaluate c sq + in cyc $ fmap lift $ forceDec $ unsafeUnCyc eval + +-- | More general form of 'decrypt' that works for unrestricted output +-- coefficient types. +decryptUnrestricted :: + (Fact m, Fact m', CElt t zp, m `Divides` m', + Reduce z zq, Lift' zq, CElt t z, ToSDCtx t m' zp zq, Reduce (LiftOf zq) zp) + => SK (Cyc t m' z) -> CT m zp (Cyc t m' zq) -> PT (Cyc t m zp) + +decryptUnrestricted (SK _ s) = let sq = reduce s in + \ct -> let (CT LSD k l c) = toLSD ct + in let eval = evaluate c sq + e = cyc $ fmap (reduce . lift) $ forceDec $ unsafeUnCyc eval + l' = scalarCyc l + in l' * twace (iterate divG' e !! k) + +---------- LSD/MSD switching ---------- + +-- | Constraint synonym for converting between ciphertext encodings. +type ToSDCtx t m' zp zq = (Encode zp zq, Fact m', CElt t zq) + +toLSD, toMSD :: ToSDCtx t m' zp zq + => CT m zp (Cyc t m' zq) -> CT m zp (Cyc t m' zq) + +-- CJP: reduce duplication in these functions? They differ in only two places + +-- | Convert a ciphertext to MSD encoding. +toMSD = let (zpScale, zqScale) = lsdToMSD + rqScale = scalarCyc zqScale + in \ct@(CT enc k l c) -> case enc of + MSD -> ct + LSD -> CT MSD k (zpScale * l) ((rqScale *) <$> c) + +-- | Convert a ciphertext to LSD encoding. +toLSD = let (zpScale, zqScale) = msdToLSD + rqScale = scalarCyc zqScale + in \ct@(CT enc k l c) -> case enc of + LSD -> ct + MSD -> CT LSD k (zpScale * l) ((rqScale *) <$> c) + +---------- Modulus switching ---------- + +-- | Rescale a linear polynomial in MSD encoding, for best noise +-- behavior. +rescaleLinearMSD :: (RescaleCyc (Cyc t) zq zq', Fact m') + => Polynomial (Cyc t m' zq) -> Polynomial (Cyc t m' zq') +rescaleLinearMSD c = case coeffs c of + [] -> fromCoeffs [] + [c0] -> fromCoeffs [rescaleCyc Dec c0] + [c0,c1] -> let c0' = rescaleCyc Dec c0 + c1' = rescaleCyc Pow c1 + in fromCoeffs [c0', c1'] + _ -> error $ "rescaleLinearMSD: list too long (not linear): " ++ + show (length $ coeffs c) + +-- | Rescale a linear ciphertext to a new modulus. +rescaleLinearCT :: (RescaleCyc (Cyc t) zq zq', ToSDCtx t m' zp zq) + => CT m zp (Cyc t m' zq) -> CT m zp (Cyc t m' zq') +rescaleLinearCT ct = let CT MSD k l c = toMSD ct + in CT MSD k l $ rescaleLinearMSD c + +-- | Constraint synonym for modulus switching. +type ModSwitchPTCtx t m' zp zp' zq = + (Lift' zp, Reduce (LiftOf zp) zp', ToSDCtx t m' zp zq) + +-- | Homomorphically divide a plaintext that is known to be a multiple +-- of @(p\/p\')@ by that factor, thereby scaling the plaintext modulus +-- from @p@ to @p\'@. +modSwitchPT :: (ModSwitchPTCtx t m' zp zp' zq) + => CT m zp (Cyc t m' zq) -> CT m zp' (Cyc t m' zq) +modSwitchPT ct = let CT MSD k l c = toMSD ct in + CT MSD k (reduce (lift l)) c + +---------- Key switching ---------- + +type LWECtx t m' z zq = + (ToInteger z, Reduce z zq, Ring zq, Fact m', CElt t z, CElt t zq) + +-- | An LWE sample for a given secret (corresponding to a linear +-- ciphertext encrypting 0 in MSD form) +lweSample :: (LWECtx t m' z zq, MonadRandom rnd) + => SK (Cyc t m' z) -> rnd (Polynomial (Cyc t m' zq)) +lweSample (SK svar s) = + let sq = adviseCRT $ negate $ reduce s + in do + e <- errorRounded svar + c1 <- getRandom + return $ fromCoeffs [c1 * sq + reduce (e `asTypeOf` s), c1] + +-- | Constraint synonym for generating key-switch hints. +type KSHintCtx gad t m' z zq = + (LWECtx t m' z zq, Reduce (DecompOf zq) zq, Gadget gad zq, + CElt t (DecompOf zq)) + +-- | Generate a hint that "encrypts" a value under a secret key, in +-- the sense required for key-switching. The hint works for any +-- plaintext modulus, but must be applied on a ciphertext in MSD form. +ksHint :: (KSHintCtx gad t m' z zq, MonadRandom rnd) + => SK (Cyc t m' z) -> Cyc t m' z + -> rnd (Tagged gad [Polynomial (Cyc t m' zq)]) +ksHint skout val = do -- rnd monad + let valq = reduce val + valgad = encode valq + -- CJP: clunky, but that's what we get without a MonadTagged + samples <- DT.mapM (\as -> replicateM (length as) (lweSample skout)) valgad + return $ zipWith (+) <$> (map P.const <$> valgad) <*> samples + +type KnapsackCtx t (m' :: Factored) z zq' = + (Reduce z zq', Fact m', CElt t z, CElt t zq') + +-- poor man's module multiplication for knapsack +(*>>) :: Ring r => r -> Polynomial r -> Polynomial r +(*>>) r = fmap (r *) + +knapsack :: forall t m' z zq' . (KnapsackCtx t m' z zq') + => [Polynomial (Cyc t m' zq')] -> [Cyc t m' z] -> Polynomial (Cyc t m' zq') +knapsack hint xs = sum (zipWith (*>>) (adviseCRT <$> reduce <$> xs) hint) + +type InnerKeySwitchCtx gad t m' zq zq' = + (RescaleCyc (Cyc t) zq' zq, RescaleCyc (Cyc t) zq zq', + Decompose gad zq', KnapsackCtx t m' (DecompOf zq') zq') + +-- Helper function: applies key-switch hint to a ring element. +-- Signature is such that we should rescale input and output. +switch :: forall gad t m' zq' zq . (InnerKeySwitchCtx gad t m' zq zq') + => Tagged gad [Polynomial (Cyc t m' zq')] -> Cyc t m' zq -> Polynomial (Cyc t m' zq) +switch hint c = rescaleLinearMSD $ untag $ knapsack <$> + hint <*> decompose (rescaleCyc Pow c :: Cyc t m' zq') + +-- | Constraint synonym for key switching. +type KeySwitchCtx gad t m' zp zq zq' = + (ToSDCtx t m' zp zq, + -- EAC: same as InnerKeySwitchCtx, but duplicated for haddock + RescaleCyc (Cyc t) zq' zq, RescaleCyc (Cyc t) zq zq', + Decompose gad zq', KnapsackCtx t m' (DecompOf zq') zq') + +-- | Switch a linear ciphertext under @s_in@ to a linear one under @s_out@ +keySwitchLinear :: forall gad t m' zp zq zq' z rnd m . + (KeySwitchCtx gad t m' zp zq zq', KSHintCtx gad t m' z zq', MonadRandom rnd) + => SK (Cyc t m' z) -- sout + -> SK (Cyc t m' z) -- sin + -> TaggedT (gad, zq') rnd (CT m zp (Cyc t m' zq) -> CT m zp (Cyc t m' zq)) +keySwitchLinear skout (SK _ sin) = tagT $ do + hint :: Tagged gad [Polynomial (Cyc t m' zq')] <- ksHint skout sin + return $ hint `deepseq` + (\ct -> let CT MSD k l c = toMSD ct + [c0,c1] = coeffs c + in CT MSD k l $ P.const c0 + switch hint c1) + +-- | Switch a quadratic ciphertext (i.e., one with three components) +-- to a linear one under the /same/ key. +keySwitchQuadCirc :: forall gad t m' zp zq zq' z m rnd . + (KeySwitchCtx gad t m' zp zq zq', KSHintCtx gad t m' z zq', MonadRandom rnd) + => SK (Cyc t m' z) + -> TaggedT (gad, zq') rnd (CT m zp (Cyc t m' zq) -> CT m zp (Cyc t m' zq)) +keySwitchQuadCirc sk@(SK _ s) = tagT $ do + hint :: Tagged gad [Polynomial (Cyc t m' zq')] <- ksHint sk (s*s) + return $ hint `deepseq` (\ct -> + let CT MSD k l c = toMSD ct + [c0,c1,c2] = coeffs c + in CT MSD k l $ P.fromCoeffs [c0,c1] + switch hint c2) + +---------- Misc homomorphic operations ---------- + +type AddScalarCtx t m' zp zq = + (Lift' zp, Reduce (LiftOf zp) zq, ToSDCtx t m' zp zq) + +-- | Homomorphically add a public @Z_p@ value to an encrypted value. The +-- ciphertext must not carry any @g@ factors. +addScalar :: (AddScalarCtx t m' zp zq) + => zp -> CT m zp (Cyc t m' zq) -> CT m zp (Cyc t m' zq) +addScalar b ct = + let (l,c) = case toLSD ct of + CT LSD 0 l c -> (l,c) + CT LSD _ _ _ -> error "cannot add public scalar to ciphertext with 'g' factors" + _ -> error "internal error: addScalar" + b' = scalarCyc (reduce $ lift $ b * recip l) + in CT LSD 0 l $ c + P.const b' + +-- | Constraint synonym for adding a public value to an encrypted value +type AddPublicCtx t m m' zp zq = + (Lift' zp, Reduce (LiftOf zp) zq, m `Divides` m', + CElt t zp, CElt t (LiftOf zp), ToSDCtx t m' zp zq) + +-- | Homomorphically add a public @R_p@ value to an encrypted value. +addPublic :: forall t m m' zp zq . (AddPublicCtx t m m' zp zq) + => Cyc t m zp -> CT m zp (Cyc t m' zq) -> CT m zp (Cyc t m' zq) +addPublic b ct = let CT LSD k l c = toLSD ct in + let linv = scalarCyc $ recip l + -- multiply public value by appropriate power of g and divide by the + -- scale, to match the form of the ciphertext + b' :: Cyc t m zq = reduce $ liftCyc Pow $ linv * (iterate mulG b !! k) + in CT LSD k l $ c + P.const (embed b') + +-- | Constraint synonym for multiplying a public value with an encrypted value +type MulPublicCtx t m m' zp zq = + (Lift' zp, Reduce (LiftOf zp) zq, Ring zq, m `Divides` m', + CElt t zp, CElt t (LiftOf zp), CElt t zq) + +-- | Homomorphically multiply an encrypted value by a public @R_p@ value. +mulPublic :: forall t m m' zp zq . (MulPublicCtx t m m' zp zq) + => Cyc t m zp -> CT m zp (Cyc t m' zq) -> CT m zp (Cyc t m' zq) +mulPublic a (CT enc k l c) = + let a' = embed (reduce $ liftCyc Pow a :: Cyc t m zq) + in CT enc k l $ (a' *) <$> c + +-- | Increment the internal g exponent without changing the encrypted +-- message. +mulGCT :: (Fact m', CElt t zq) + => CT m zp (Cyc t m' zq) -> CT m zp (Cyc t m' zq) +mulGCT (CT enc k l c) = CT enc (k+1) l $ mulG <$> c + +---------- NumericPrelude instances ---------- + +instance (Eq zp, m `Divides` m', ToSDCtx t m' zp zq) + => Additive.C (CT m zp (Cyc t m' zq)) where + + zero = CT LSD 0 one zero + + -- the scales, g-exponents of ciphertexts, and MSD/LSD types must match. + ct1@(CT enc1 k1 l1 c1) + ct2@(CT enc2 k2 l2 c2) + -- for simplicity, we don't currently support this. Shouldn't be + -- too complicated though. + | l1 /= l2 = error "Cannot add ciphertexts with different scale values" + | k1 < k2 = iterate mulGCT ct1 !! (k2-k1) + ct2 + | k1 > k2 = ct1 + iterate mulGCT ct2 !! (k1-k2) + | enc1 == LSD && enc2 == MSD = toMSD ct1 + ct2 + | enc1 == MSD && enc2 == LSD = ct1 + toMSD ct2 + | otherwise = CT enc1 k1 l1 $ c1 + c2 + + negate (CT enc k l c) = CT enc k l $ negate <$> c + +instance (ToSDCtx t m' zp zq, Additive (CT m zp (Cyc t m' zq))) + => Ring.C (CT m zp (Cyc t m' zq)) where + + one = CT LSD 0 one one + + -- need at least one ct to be in LSD form + ct1@(CT MSD _ _ _) * ct2@(CT MSD _ _ _) = toLSD ct1 * ct2 + + -- first is in LSD + (CT LSD k1 l1 c1) * (CT d2 k2 l2 c2) = + -- mul by g so error maintains invariant: error*g is "round" + CT d2 (k1+k2+1) (l1*l2) (mulG <$> c1 * c2) + + -- else, second must be in LSD + ct1 * ct2 = ct2 * ct1 + +{- CJP: do we want/need this? We have mulPublic... + +instance (MulPublicCtx t m m' zp zq, Reduce z' zp, CElt t z', + l `Divides` m, Additive (CT m zp (c m' zq)), Ring (c l z')) + => Module.C (c l z') (CT m zp (c m' zq)) where + + (*>) a = mulPublic (embed $ reduce a) +-} + +---------- Ring switching ---------- + +type AbsorbGCtx t m' zp zq = + (Lift' zp, Reduce (LiftOf zp) zq, Ring zp, Ring zq, Fact m', + CElt t (LiftOf zp), CElt t zp, CElt t zq) + +-- | "Absorb" the powers of g associated with the ciphertext, at the +-- cost of some increase in noise. This is usually needed before +-- changing the index of the ciphertext ring. +absorbGFactors :: forall t zp zq m m' . (AbsorbGCtx t m' zp zq) + => CT m zp (Cyc t m' zq) -> CT m zp (Cyc t m' zq) +absorbGFactors ct@(CT enc k l c) + | k == 0 = ct + | k > 0 = let d :: Cyc t m' zp = iterate divG' one !! k + rep = adviseCRT $ reduce $ liftCyc Pow d + in CT enc 0 l $ (rep *) <$> c + | otherwise = error "k < 0 in absorbGFactors" + +-- | Embed a ciphertext in R' encrypting a plaintext in R to a +-- ciphertext in T' encrypting a plaintext in T. The target ciphertext +-- ring T' must contain both the the source ciphertext ring R' and the +-- target plaintext ring T. +embedCT :: (CElt t zq, + r `Divides` r', s `Divides` s', r `Divides` s, r' `Divides` s') + => CT r zp (Cyc t r' zq) -> CT s zp (Cyc t s' zq) +-- We could call absorbGFactors first, insead of error. Embedding +-- *essentially* maintains the invariant that noise*g is "round." +-- While g'/g can be non-spherical, it only stretches by at most a +-- factor of 2 per new odd prime. We *cannot* multiply by g, then +-- embed, then divide by g' because the result would not remain in R'. +-- So this is the best we can do. +embedCT (CT d 0 l c) = CT d 0 l (embed <$> c) +embedCT _ = error "embedCT requires 0 factors of g; call aborbGFactors first" + +-- | Embed a secret key from a subring into a superring. +embedSK :: (CElt t z, m `Divides` m') => SK (Cyc t m z) -> SK (Cyc t m' z) +embedSK (SK v s) = SK v $ embed s + +-- | "Tweaked trace" function for ciphertexts. Mathematically, the +-- target plaintext ring @S@ must contain the intersection of the +-- source plaintext ring @T@ and the target ciphertext ring @S\'@. +-- Here we make the stricter requirement that @s = gcd(s\', t)@. +twaceCT :: (CElt t zq, r `Divides` r', s' `Divides` r', + s ~ (FGCD s' r)) + => CT r zp (Cyc t r' zq) -> CT s zp (Cyc t s' zq) +-- we could call absorbGFactors first, insead of error +twaceCT (CT d 0 l c) = CT d 0 l (twace <$> c) +twaceCT _ = error "twaceCT requires 0 factors of g; call absorbGFactors first" + +-- | Constraint synonym for ring tunneling. +type TunnelCtx t e r s e' r' s' z zp zq zq' gad = + (ExtendLinIdx e r s e' r' s', -- liftLin + KSHintCtx gad t r' z zq', -- ksHint + Reduce z zq, -- Reduce on Linear + Lift zp z, -- liftLin + CElt t zp, -- liftLin + KeySwitchCtx gad t s' zp zq zq') -- keySwitch + +-- | Homomorphically apply the @E@-linear function that maps the +-- elements of the decoding basis of @R\/E@ to the corresponding +-- @S@-elements in the input array. +tunnelCT :: forall gad t e r s e' r' s' z zp zq zq' rnd . + (TunnelCtx t e r s e' r' s' z zp zq zq' gad, + MonadRandom rnd) + => Linear t zp e r s + -> SK (Cyc t s' z) + -> SK (Cyc t r' z) + -> TaggedT (gad,zq') rnd (CT r zp (Cyc t r' zq) -> CT s zp (Cyc t s' zq)) +tunnelCT f skout (SK _ sin) = tagT $ (do -- in rnd + -- generate hints + let f' = extendLin $ lift f :: Linear t z e' r' s' + -- choice of basis here must match coeffsCyc basis below + ps = proxy powBasis (Proxy::Proxy e') + comps = (evalLin f' . (adviseCRT sin *)) <$> ps + hints :: [Tagged gad [Polynomial (Cyc t s' zq')]] <- CM.mapM (ksHint skout) comps + return $ hints `deepseq` \ct' -> + let CT MSD 0 s c = toMSD $ absorbGFactors ct' + [c0,c1] = coeffs c + -- apply E-linear function to constant term c0 + c0' = evalLin (reduce f' :: Linear t zq e' r' s') c0 + -- apply E-linear function to c1 via key-switching + -- this basis must match the basis used above to generate the hints + c1s = coeffsCyc Pow c1 :: [Cyc t e' zq] + -- CJP: don't embed the c1s before decomposing them (inside + -- switch); instead decompose in smaller ring before + -- embedding (it matters). + -- We may need to generalize switch or define an + -- alternative. + c1s' = zipWith switch hints (embed <$> c1s) + c1' = sum c1s' + in CT MSD 0 s $ P.const c0' + c1') + \\ lcmDivides (Proxy::Proxy r) (Proxy::Proxy e') diff --git a/src/Crypto/Lol/CRTrans.hs b/src/Crypto/Lol/CRTrans.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/Lol/CRTrans.hs @@ -0,0 +1,181 @@ +{-# LANGUAGE FlexibleContexts, FlexibleInstances, RebindableSyntax, + ScopedTypeVariables, TypeFamilies #-} + +-- | Classes and helper methods for the Chinese remainder transform +-- and ring extensions. + +module Crypto.Lol.CRTrans +( CRTrans(..), CRTEmbed(..) +, CRTInfo +, crtInfoFact, crtInfoPPow, crtInfoNatC +, gEmbPPow, gEmbNatC +, omegaPowMod, zqHasCRT +) where + +import Crypto.Lol.LatticePrelude + +import Math.NumberTheory.Primes.Factorisation (carmichael, factorise) + +import Control.Arrow +import Data.Singletons +import Data.Singletons.Prelude +import Data.Type.Natural (Sing (SS)) +import qualified Data.Vector as V + +-- | Information that characterizes the (invertible) Chinese remainder +-- transformation over a ring @r@, namely: +-- +-- (1) a function that returns the @i@th power of some @m@th root +-- of unity (for any integer @i@) +-- +-- (2) the multiplicative inverse of @\\hat{m}@ in @r@. + +type CRTInfo r = (Int -> r, r) + +-- | A ring that (possibly) supports invertible Chinese remainder +-- transformations of various indices. + +-- | The values of 'crtInfo' for different indices @m@ should be +-- consistent, in the sense that if @omega@, @omega'@ are respectively +-- the values returned for @m@, @m'@ where @m'@ divides @m@, then it +-- should be the case that @omega^(m/m')=omega'@. + +class Ring r => CRTrans r where + + -- | 'CRTInfo' for a given index @m@. The method itself may be + -- slow, but the function it returns should be fast, e.g., via + -- internal memoization. The default implementation returns + -- 'Nothing'. + crtInfo :: Int -> Maybe (CRTInfo r) + crtInfo = const Nothing + +-- | A ring with a ring embedding into some ring @CRTExt r@ that has +-- an invertible CRT transformation for /every/ positive index @m@. +class (Ring r, Ring (CRTExt r)) => CRTEmbed r where + type CRTExt r + + -- | Embeds from @r@ to @CRTExt r@ + toExt :: r -> CRTExt r + -- | Projects from @CRTExt r@ to @r@ + fromExt :: CRTExt r -> r + +-- CRTrans instance for product rings +instance (CRTrans a, CRTrans b) => CRTrans (a,b) where + crtInfo i = do + (apow, aiInv) <- crtInfo i + (bpow, biInv) <- crtInfo i + return (apow &&& bpow, (aiInv, biInv)) + +-- CRTEmbed instance for product rings +instance (CRTEmbed a, CRTEmbed b) => CRTEmbed (a,b) where + type CRTExt (a,b) = (CRTExt a, CRTExt b) + toExt = toExt *** toExt + fromExt = fromExt *** fromExt + +-- | Default implementation of 'omegaPow' for 'Mod' types. The +-- implementation finds an integer element of maximal multiplicative +-- order, and raises it to the appropriate power. Therefore, the +-- functions returned for different values of the first argument are +-- consistent, i.e., @omega_{m'}^(m'/m) = omega_m@. +omegaPowMod :: forall r . (Mod r, Enumerable r, Ring r, Eq r) + => Int -> Maybe (Int -> r) +omegaPowMod = -- use Integers for all intermediate calcs + + -- CJP: there's a mismatch here between the semantics of Mod and the + -- use of 'values'. If r really represents *integers* modulo + -- something then we're fine, otherwise we might get weird behavior. + + let -- the exponent of Z_q^* + exponent = carmichael $ fromIntegral (proxy modulus (Proxy::Proxy r)) + -- all prime divisors of exponent + primes = map fst $ factorise exponent + -- the powers we need to check + exps = map (exponent `div`) primes + -- whether an element is a unit with maximal order + isGood x = (x^exponent == one) && all (\e -> x^e /= one) exps + in \m -> let (mq, mr) = exponent `divMod` fromIntegral m + in if mr == 0 + then let omega = head (filter isGood values) ^ mq + omegaPows = V.iterateN m (*omega) one + in Just $ (omegaPows V.!) . (`mod` m) + else Nothing + +omegaPowC :: (Transcendental a) => Int -> Int -> Complex a +omegaPowC m i = cis (2*pi*fromIntegral i / fromIntegral m) + +-- | 'crtInfo' wrapper for 'Fact' types. +crtInfoFact :: (Fact m, CRTrans r) => TaggedT m Maybe (CRTInfo r) +crtInfoFact = (tagT . crtInfo) =<< pureT valueFact + +-- | 'crtInfo' wrapper for 'PPow' types. +crtInfoPPow :: (PPow pp, CRTrans r) => TaggedT pp Maybe (CRTInfo r) +crtInfoPPow = (tagT . crtInfo) =<< pureT valuePPow + +-- | 'crtInfo' wrapper for 'NatC' types. +crtInfoNatC :: (NatC p, CRTrans r) => TaggedT p Maybe (CRTInfo r) +crtInfoNatC = (tagT . crtInfo) =<< pureT valueNatC + +-- | A function that returns the 'i'th embedding of @g_{p^e} = g_p@ for +-- @i@ in @Z*_{p^e}@. +gEmbPPow :: forall pp r . (PPow pp, CRTrans r) => TaggedT pp Maybe (Int -> r) +gEmbPPow = tagT $ case (sing :: SPrimePower pp) of + -- intentionally no match for zero exponents + (SPP (STuple2 sp (SS _))) -> withWitnessT gEmbNatC sp + +-- | A function that returns the @i@th embedding of @g_p@ for @i@ in @Z*_p@, +-- i.e., @1-omega_p^i@. +gEmbNatC :: (NatC p, CRTrans r) => TaggedT p Maybe (Int -> r) +gEmbNatC = do + (f, _) <- crtInfoNatC + return $ \i -> one - f i -- not checking that i /= 0 (mod p) + +-- | @zqHasCRT m q@ says whether @Z_q@ has an /invertible/ CRT +-- transform of index @m@, i.e., @Z_q@ has an element of +-- multiplicative order @m@, and @mhat@ is invertible in @Z_q@. +zqHasCRT :: (ToInteger i, PID i) => i -> i -> Bool +zqHasCRT m q = let exponent = fromIntegral $ carmichael $ + fromIntegral q + mhat = if 2 `divides` m then m `div` 2 else m + in m `divides` exponent && fst (extendedGCD mhat q) == one + +-- the complex numbers have roots of unity of any order +instance (Transcendental a) => CRTrans (Complex a) where + crtInfo m = Just (omegaPowC m, recip $ fromIntegral $ valueHat m) + +-- trivial CRTEmbed instance for complex numbers +instance (Transcendental a) => CRTEmbed (Complex a) where + type CRTExt (Complex a) = Complex a + toExt = id + fromExt = id + +-- Default CRTrans instances for real and integer types, which do +-- not have roots of unity (except in trivial cases). These are needed +-- to use FastCyc with these integer types. +instance CRTrans Double +instance CRTrans Int +instance CRTrans Int64 +instance CRTrans Integer +-- can also do for Int8, Int16, Int32 etc. + +-- CRTEmbed instances for real and integer types, embedding into +-- Complex. These are needed to use FastCyc with these integer types. +instance CRTEmbed Double where + type CRTExt Double = Complex Double + toExt = fromReal . realToField + fromExt = realToField . real + +instance CRTEmbed Int where + type CRTExt Int = Complex Double + toExt = fromIntegral + fromExt = fst . roundComplex + +instance CRTEmbed Int64 where + type CRTExt Int64 = Complex Double + toExt = fromIntegral + fromExt = fst . roundComplex + +instance CRTEmbed Integer where + -- CJP: sufficient precision? Not in general. + type CRTExt Integer = Complex Double + toExt = fromIntegral + fromExt = fst . roundComplex diff --git a/src/Crypto/Lol/Cyclotomic/Cyc.hs b/src/Crypto/Lol/Cyclotomic/Cyc.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/Lol/Cyclotomic/Cyc.hs @@ -0,0 +1,175 @@ +{-# LANGUAGE ConstraintKinds, DataKinds, FlexibleContexts, + FlexibleInstances, GADTs, GeneralizedNewtypeDeriving, + MultiParamTypeClasses, NoImplicitPrelude, PolyKinds, + RankNTypes, ScopedTypeVariables, StandaloneDeriving, + TypeFamilies, TypeOperators, UndecidableInstances #-} + +-- | An implementation of cyclotomic rings with safe interface: +-- functions and instances involving 'Cyc' expose nothing about the +-- internal representations of ring elements (e.g., the basis they are +-- represented in). For an experts-only, "unsafe" implementation that +-- offers limited exposure of internal representation, use +-- 'Crypto.Lol.Cyclotomic.UCyc.UCyc'. + +module Crypto.Lol.Cyclotomic.Cyc +( +-- * Data type + Cyc, U.CElt, cyc, unsafeUnCyc +-- * Basic operations +, mulG, divG +, scalarCyc, liftCyc +, adviseCRT +-- * Error sampling +, tGaussian, errorRounded, errorCoset +-- * Sub/extension rings +, embed, twace, powBasis, crtSet, coeffsCyc +, module Crypto.Lol.Cyclotomic.Utility +) where + +import Algebra.Additive as Additive (C) +import Algebra.Ring as Ring (C) + +import Crypto.Lol.Cyclotomic.UCyc (CElt, UCyc) +import qualified Crypto.Lol.Cyclotomic.UCyc as U +import Crypto.Lol.Cyclotomic.Utility +import Crypto.Lol.Gadget +import Crypto.Lol.LatticePrelude as LP +import Crypto.Lol.Types.ZPP + +import Control.Applicative hiding ((*>)) +import Control.DeepSeq +import Control.Monad.Random + +import Data.Coerce + +import Test.QuickCheck + +-- | Wrapper around 'UCyc' that exposes a narrower, safe interface. +newtype Cyc t m r = Cyc { + -- | Unsafe deconstructor for 'Cyc'. + unsafeUnCyc :: UCyc t m r } + deriving (Arbitrary, NFData, Random) + +-- See: https://ghc.haskell.org/trac/ghc/ticket/11008 +-- for why I have to use StandaloneDeriving here +deriving instance Show (UCyc t m a) => Show (Cyc t m a) +deriving instance Eq (UCyc t m a) => Eq (Cyc t m a) +deriving instance Additive (UCyc t m a) => Additive.C (Cyc t m a) +deriving instance Ring (UCyc t m a) => Ring.C (Cyc t m a) +deriving instance Gadget gad (UCyc t m a) => Gadget gad (Cyc t m a) +deriving instance Correct gad (UCyc t m a) => Correct gad (Cyc t m a) + +-- | Smart constructor (to prevent clients from pattern-matching). +cyc :: UCyc t m r -> Cyc t m r +cyc = Cyc + +-- (try to) replace all occurrences of 'Cyc' with 'UCyc' +type family O a where + O (Cyc t m a) = UCyc t m a + O (a -> b) = O a -> O b + O (m a) = m (O a) -- works for concrete m, but not vars + O a = a + +-- specialized 'coerce', to aid type inference +coerceCyc :: (Coercible (O a) a) => O a -> a +coerceCyc = coerce + +-- Can't seem to auto-derive these, due to constraints with GND and +-- MPTCs. +instance (Reduce a b, Fact m, CElt t a, CElt t b) + => Reduce (Cyc t m a) (Cyc t m b) where + reduce = coerceCyc reduce + +-- CJP: will this pick the right overlapping instance for UCyc? I +-- think so... +instance (RescaleCyc (UCyc t) a b) => RescaleCyc (Cyc t) a b where + rescaleCyc = coerceCyc rescaleCyc + +instance (Decompose gad (UCyc t m zq), + Reduce (Cyc t m (DecompOf zq)) (Cyc t m zq)) + => Decompose gad (Cyc t m zq) where + + type DecompOf (Cyc t m zq) = Cyc t m (DecompOf zq) + decompose = coerceCyc decompose + +---------- Core cyclotomic operations ---------- + +-- | Yield an equivalent element that /may/ be in a CRT +-- representation. This can serve as an optimization hint. E.g., +-- call 'adviseCRT' prior to multiplying the same value by many +-- other values. +adviseCRT :: (Fact m, CElt t r) => Cyc t m r -> Cyc t m r +adviseCRT = coerceCyc U.adviseCRT + +-- | Multiply by the special element @g@ of the @m@th cyclotomic. +mulG :: (Fact m, CElt t r) => Cyc t m r -> Cyc t m r +mulG = coerceCyc U.mulG + +-- | Divide by @g@, returning 'Nothing' if not evenly divisible. +-- WARNING: this implementation is not a constant-time algorithm, so +-- information about the argument may be leaked through a timing +-- channel. +divG :: (Fact m, CElt t r) => Cyc t m r -> Maybe (Cyc t m r) +divG = coerceCyc U.divG + +-- | Sample from the "tweaked" Gaussian error distribution @t*D@ in +-- the decoding basis, where @D@ has scaled variance @v@. Note: This +-- implementation uses Double precision to generate the Gaussian +-- sample, which may not be sufficient for rigorous proof-based +-- security. +tGaussian :: (Fact m, OrdFloat q, Random q, CElt t q, + ToRational v, MonadRandom rnd) + => v -> rnd (Cyc t m q) +tGaussian = (Cyc <$>) . U.tGaussian + +-- | Generate an LWE error term with given scaled variance, +-- deterministically rounded in the decoding basis. +errorRounded :: (ToInteger z, Fact m, CElt t z, + ToRational v, MonadRandom rnd) + => v -> rnd (Cyc t m z) +errorRounded = (Cyc <$>) . U.errorRounded + +-- | Generate an LWE error term with given scaled variance @* p^2@ over +-- the given coset, deterministically rounded in the decoding basis. +errorCoset :: + (Mod zp, z ~ ModRep zp, Lift zp z, Fact m, + CElt t zp, CElt t z, ToRational v, MonadRandom rnd) + => v -> Cyc t m zp -> rnd (Cyc t m z) +errorCoset v = (Cyc <$>) . U.errorCoset v . unsafeUnCyc + +-- | Embed into the extension ring. +embed :: (m `Divides` m', CElt t r) => Cyc t m r -> Cyc t m' r +embed = coerceCyc U.embed + +-- | The "tweaked trace" (twace) function +-- @Tw(x) = (mhat \/ m'hat) * Tr(g' \/ g * x)@, +-- which fixes @R@ pointwise (i.e., @twace . embed == id@). +twace :: (m `Divides` m', CElt t r) => Cyc t m' r -> Cyc t m r +twace = coerceCyc U.twace + +-- | Return the given element's coefficient vector with respect to +-- the (relative) powerful/decoding basis of the cyclotomic +-- extension @O_m' / O_m@. +coeffsCyc :: (m `Divides` m', CElt t r) + => Basis -> Cyc t m' r -> [Cyc t m r] +coeffsCyc = coerceCyc U.coeffsCyc + +-- | The relative powerful basis of @O_m' / O_m@. +powBasis :: (m `Divides` m', CElt t r) => Tagged m [Cyc t m' r] +powBasis = coerceCyc U.powBasis + +-- | The relative mod-@r@ "CRT set" of the extension. +crtSet :: (m `Divides` m', ZPP r, CElt t r, CElt t (ZPOf r)) + => Tagged m [Cyc t m' r] +crtSet = coerceCyc U.crtSet + +-- | Lift in the specified basis. +liftCyc :: (Lift b a, Fact m, CElt t a, CElt t b) + => Basis -> Cyc t m b -> Cyc t m a +liftCyc = coerceCyc U.liftCyc + +-- | Embed a scalar from the base ring as a cyclotomic element. +scalarCyc :: (Fact m, CElt t a) => a -> Cyc t m a +scalarCyc = Cyc . U.scalarCyc + + diff --git a/src/Crypto/Lol/Cyclotomic/Linear.hs b/src/Crypto/Lol/Cyclotomic/Linear.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/Lol/Cyclotomic/Linear.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE ConstraintKinds, DataKinds, FlexibleContexts, + GeneralizedNewtypeDeriving, KindSignatures, + MultiParamTypeClasses, NoImplicitPrelude, RoleAnnotations, + ScopedTypeVariables, TypeFamilies, TypeOperators, + UndecidableInstances #-} + +-- | Functions from one cyclotomic ring to another that are linear +-- over a common subring. + +module Crypto.Lol.Cyclotomic.Linear +( Linear, ExtendLinIdx +, linearDec, evalLin, extendLin +) where + +import Crypto.Lol.Cyclotomic.Cyc +import Crypto.Lol.LatticePrelude + +import Algebra.Additive as Additive (C) + +import Control.Applicative +import Control.DeepSeq + +-- | An @E@-linear function from @R@ to @S@. +newtype Linear t z (e::Factored) (r::Factored) (s::Factored) = D [Cyc t s z] + deriving (NFData) + +-- TODO: have constructor for both relative Pow basis of R/E? + +-- some params are phantom but matter for safety +type role Linear representational nominal representational representational nominal + +-- | Construct an @E@-linear function given a list of its output values +-- (in @S@) on the relative decoding basis of @R/E@. The number of +-- elements in the list must not exceed the size of the basis. +linearDec :: forall t z e r s . + (e `Divides` r, e `Divides` s, CElt t z) + => [Cyc t s z] -> Linear t z e r s +linearDec cs = let ps = proxy powBasis (Proxy::Proxy e) `asTypeOf` cs + in if length cs <= length ps then D (adviseCRT <$> cs) + else error $ "linearDec: too many entries: " + ++ show (length cs) ++ " versus " + ++ show (length ps) + +-- | Evaluates the given linear function on the input. +evalLin :: forall t z e r s . + (e `Divides` r, e `Divides` s, CElt t z) + => Linear t z e r s -> Cyc t r z -> Cyc t s z +evalLin (D cs) r = sum (zipWith (*) cs $ + embed <$> (coeffsCyc Dec r :: [Cyc t e z])) + +instance Additive (Cyc t s z) => Additive.C (Linear t z e r s) where + zero = D [] + + (D as) + (D bs) = D $ sumall as bs + where sumall [] ys = ys + sumall xs [] = xs + sumall (x:xs) (y:ys) = x+y : sumall xs ys + + negate (D as) = D $ negate <$> as + +instance (Reduce z zq, Fact s, CElt t z, CElt t zq) + => Reduce (Linear t z e r s) (Linear t zq e r s) where + reduce (D cs) = D $ reduce <$> cs + +instance (CElt t zp, CElt t z, z ~ LiftOf zp, Lift zp z, Fact s) + => Lift' (Linear t zp e r s) where + type LiftOf (Linear t zp e r s) = Linear t (LiftOf zp) e r s + + lift (D cs) = D $ liftCyc Dec <$> cs + +-- | A convenient constraint synonym for extending a linear function +-- to larger rings. +type ExtendLinIdx e r s e' r' s' = + (e ~ FGCD r e', r' ~ FLCM r e', -- these imply R'=R\otimes_E E' + e' ~ (e * (r' / r)), -- just to help GHC. This is implied by previous two constraints + e' `Divides` s', s `Divides` s', -- these imply lcm(s,e')|s' <==> (S+E') \subseteq S' + Fact r) -- need Fact r because nothing else gives it + +-- | Extend an @E@-linear function @R->S@ to an @E'@-linear function +-- @R\'->S\'@. (Mathematically, such extension only requires +-- @lcm(r,e\') | r\'@ (not equality), but this generality would +-- significantly complicate the implementation, and for our purposes +-- there's no reason to use any larger @r'@.) +extendLin :: (ExtendLinIdx e r s e' r' s', CElt t z) + => Linear t z e r s -> Linear t z e' r' s' +-- CJP: this simple implementation works because R/E and R'/E' have +-- identical decoding bases, because R' \cong R \otimes_E E'. If we +-- relax the constraint on E then we'd have to change the +-- implementation to something more difficult. +extendLin (D cs) = D (embed <$> cs) diff --git a/src/Crypto/Lol/Cyclotomic/Tensor.hs b/src/Crypto/Lol/Cyclotomic/Tensor.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/Lol/Cyclotomic/Tensor.hs @@ -0,0 +1,399 @@ +{-# LANGUAGE ConstraintKinds, DataKinds, FlexibleContexts, + NoImplicitPrelude, RankNTypes, ScopedTypeVariables, + TupleSections, TypeFamilies, TypeOperators, + UndecidableInstances #-} + +-- | Interface for cyclotomic tensors, and helper functions for tensor +-- indexing. + +module Crypto.Lol.Cyclotomic.Tensor +( Tensor(..) +-- * Top-level CRT functions +, hasCRTFuncs +, scalarCRT, mulGCRT, divGCRT, crt, crtInv, twaceCRT, embedCRT +-- * Tensor indexing +, Matrix, indexM, twCRTs +, zmsToIndexFact +, indexInfo +, extIndicesPowDec, extIndicesCRT, extIndicesCoeffs +, baseIndicesPow, baseIndicesDec, baseIndicesCRT +, digitRev +) +where + +import Crypto.Lol.CRTrans +import Crypto.Lol.LatticePrelude as LP hiding (lift, (*>)) +import Crypto.Lol.Types.FiniteField + +import Control.Applicative +import Control.DeepSeq +import Control.Monad.Random +import Data.Constraint +import Data.Singletons.Prelude hiding ((:-)) +import Data.Traversable +import Data.Tuple (swap) +import qualified Data.Vector as V +import qualified Data.Vector.Unboxed as U + +-- | 'Tensor' encapsulates all the core linear transformations needed +-- for cyclotomic ring arithmetic. + +-- | The type @t m r@ represents a cyclotomic coefficient tensor of +-- index @m@ over base ring @r@. Most of the methods represent linear +-- transforms corresponding to operations in particular bases. +-- CRT-related methods are wrapped in 'Maybe' because they are +-- well-defined only when a CRT basis exists over the ring @r@ for +-- index @m@. + +-- | The superclass constraint is for convenience, to ensure that we +-- can sample error tensors of 'Double's. + +class (TElt t Double, TElt t (Complex Double)) + => Tensor (t :: Factored -> * -> *) where + + type TElt t r :: Constraint + + -- | Properties that hold for any index. Use with '\\'. + entailIndexT :: Tagged (t m r) + (Fact m :- (Applicative (t m), Traversable (t m))) + + -- | Properties that hold for any (legal) fully-applied tensor. Use + -- with '\\'. + entailFullT :: Tagged (t m r) + ((Fact m, TElt t r) :- + (Eq (t m r), ZeroTestable (t m r), Ring (t m r), + NFData (t m r), Random (t m r))) + + -- | Converts a scalar to a tensor in the powerful basis + scalarPow :: (Fact m, TElt t r) => r -> t m r + + -- | 'l' converts from decoding-basis representation to + -- powerful-basis representation; 'lInv' is its inverse. + l, lInv :: (Fact m, TElt t r) => t m r -> t m r + + -- | Multiply by @g@ in the powerful/decoding basis + mulGPow, mulGDec :: (Fact m, TElt t r) => t m r -> t m r + + -- | Divide by @g@ in the powerful/decoding basis. The 'Maybe' + -- output indicates that the operation may fail, which happens + -- exactly when the input is not divisible by @g@. + divGPow, divGDec :: (Fact m, TElt t r) => t m r -> Maybe (t m r) + + -- | A tuple of all the operations relating to the CRT basis, in a + -- single 'Maybe' value for safety. Clients should typically not + -- use this method directly, but instead call the corresponding + -- top-level functions: the elements of the tuple correpond to the + -- functions 'scalarCRT', 'mulGCRT', 'divGCRT', 'crt', 'crtInv'. + crtFuncs :: (Fact m, TElt t r, CRTrans r) => + Maybe ( r -> t m r, -- scalarCRT + t m r -> t m r, -- mulGCRT + t m r -> t m r, -- divGCRT + t m r -> t m r, -- crt + t m r -> t m r) -- crtInv + + -- | Sample from the "skewed" Gaussian error distribution @t*D@ + -- in the decoding basis, where @D@ has scaled variance @v@. + tGaussianDec :: (Fact m, OrdFloat q, Random q, TElt t q, + ToRational v, MonadRandom rnd) + => v -> rnd (t m q) + + -- | The @twace@ linear transformation, which is the same in both the + -- powerful and decoding bases. + twacePowDec :: (m `Divides` m', TElt t r) => t m' r -> t m r + + -- | The @embed@ linear transformations, for the powerful and + -- decoding bases. + embedPow, embedDec :: (m `Divides` m', TElt t r) + => t m r -> t m' r + + -- | A tuple of all the extension-related operations involving the + -- CRT bases, for safety. Clients should typically not use this + -- method directly, but instead call the corresponding top-level + -- functions: the elements of the tuple correpond to the functions + -- 'twaceCRT', 'embedCRT'. + crtExtFuncs :: (m `Divides` m', TElt t r, CRTrans r) => + Maybe (t m' r -> t m r, -- twaceCRT + t m r -> t m' r) -- embedCRT + + -- | Map a tensor in the powerful\/decoding\/CRT basis, representing + -- an @O_m'@ element, to a vector of tensors representing @O_m@ + -- elements in the same kind of basis. + coeffs :: (m `Divides` m', TElt t r) => t m' r -> [t m r] + + -- | The powerful extension basis w.r.t. the powerful basis. + powBasisPow :: (m `Divides` m', TElt t r) => Tagged m [t m' r] + + -- | A list of tensors representing the mod-@p@ CRT set of the + -- extension. + crtSetDec :: (m `Divides` m', PrimeField fp, + Coprime (PToF (CharOf fp)) m', TElt t fp) + => Tagged m [t m' fp] + + -- | Potentially optimized version of 'fmap' when the input and + -- output element types satisfy 'TElt'. + fmapT :: (Fact m, TElt t a, TElt t b) => (a -> b) -> t m a -> t m b + -- | Potentially optimized monadic 'fmap'. + fmapTM :: (Monad mon, Fact m, TElt t a, TElt t b) + => (a -> mon b) -> t m a -> mon (t m b) + +-- | Convenience value indicating whether 'crtFuncs' exists. +hasCRTFuncs :: forall t m r . (Tensor t, Fact m, TElt t r, CRTrans r) + => TaggedT (t m r) Maybe () +hasCRTFuncs = tagT $ do + (_ :: r -> t m r,_,_,_,_) <- crtFuncs + return () + +-- | Yield a tensor for a scalar in the CRT basis. (This function is +-- simply an appropriate entry from 'crtFuncs'.) +scalarCRT :: (Tensor t, Fact m, TElt t r, CRTrans r) => Maybe (r -> t m r) +scalarCRT = (\(f,_,_,_,_) -> f) <$> crtFuncs + + +mulGCRT, divGCRT, crt, crtInv :: (Tensor t, Fact m, TElt t r, CRTrans r) + => Maybe (t m r -> t m r) +-- | Multiply by @g@ in the CRT basis. (This function is simply an +-- appropriate entry from 'crtFuncs'.) +mulGCRT = (\(_,f,_,_,_) -> f) <$> crtFuncs +-- | Divide by @g@ in the CRT basis. (This function is simply an +-- appropriate entry from 'crtFuncs'.) +divGCRT = (\(_,_,f,_,_) -> f) <$> crtFuncs +-- | The CRT transform. (This function is simply an appropriate entry +-- from 'crtFuncs'.) +crt = (\(_,_,_,f,_) -> f) <$> crtFuncs +-- | The inverse CRT transform. (This function is simply an +-- appropriate entry from 'crtFuncs'.) +crtInv = (\(_,_,_,_,f) -> f) <$> crtFuncs + +-- | The "tweaked trace" function for tensors in the CRT basis: +-- For cyclotomic indices m | m', +-- @Tw(x) = (mhat\/m\'hat) * Tr(g\'\/g * x)@. +-- (This function is simply an appropriate entry from 'crtExtFuncs'.) +twaceCRT :: forall t r m m' . (Tensor t, m `Divides` m', TElt t r, CRTrans r) + => Maybe (t m' r -> t m r) +twaceCRT = proxyT hasCRTFuncs (Proxy::Proxy (t m' r)) *> + proxyT hasCRTFuncs (Proxy::Proxy (t m r)) *> + (fst <$> crtExtFuncs) + + +-- | Embed a tensor with index @m@ in the CRT basis to a tensor with +-- index @m'@ in the CRT basis. +-- (This function is simply an appropriate entry from 'crtExtFuncs'.) +embedCRT :: forall t r m m' . (Tensor t, m `Divides` m', TElt t r, CRTrans r) + => Maybe (t m r -> t m' r) +embedCRT = proxyT hasCRTFuncs (Proxy::Proxy (t m' r)) *> + proxyT hasCRTFuncs (Proxy::Proxy (t m r)) *> + (snd <$> crtExtFuncs) + +fMatrix :: forall m r mon . (Fact m, Monad mon, Ring r) + => (forall pp . (PPow pp) => TaggedT pp mon (MatrixC r)) + -> TaggedT m mon (Matrix r) +fMatrix mat = tagT $ go $ sUnF (sing :: SFactored m) + where go :: Sing (pplist :: [PrimePower]) -> mon (Matrix r) + go spps = case spps of + SNil -> return MNil + (SCons spp rest) -> do + rest' <- go rest + mat' <- withWitnessT mat spp + return $ MKron rest' mat' + +-- deeply embedded DSL for Kronecker products of matrices + +data MatrixC r = + MC (Int -> Int -> r) -- yields element i,j + Int Int -- dims + +-- | A Kronecker product of zero of more matrices over @r@. +data Matrix r = MNil | MKron (Matrix r) (MatrixC r) + +-- | Extract the @(i,j)@ element of a 'Matrix'. +indexM :: Ring r => Matrix r -> Int -> Int -> r +indexM MNil 0 0 = LP.one +indexM (MKron m (MC mc r c)) i j = + let (iq,ir) = i `divMod` r + (jq,jr) = j `divMod` c + in indexM m iq jq * mc ir jr + +-- | The "tweaked" CRT^* matrix: @CRT^* . diag(sigma(g_m))@. +twCRTs :: (Fact m, CRTrans r) => TaggedT m Maybe (Matrix r) +twCRTs = fMatrix twCRTsPPow + +-- | The "tweaked" CRT^* matrix (for prime powers): @CRT^* * diag(sigma(g_p))@. +twCRTsPPow :: (PPow pp, CRTrans r) => TaggedT pp Maybe (MatrixC r) +twCRTsPPow = do + phi <- pureT totientPPow + iToZms <- pureT indexToZmsPPow + jToPow <- pureT indexToPowPPow + (wPow, _) <- crtInfoPPow + gEmb <- gEmbPPow + + return $ MC (\j i -> let i' = iToZms i + in wPow (jToPow j * negate i') * gEmb i') phi phi + +-- Reindexing functions + +-- | Base-p digit reversal; input and output are in @[p^e]@. +digitRev :: PP -> Int -> Int +digitRev (_,0) 0 = 0 +-- CJP: use accumulator to avoid multiple exponentiations? +digitRev (p,e) j + | e >= 1 = let (q,r) = j `divMod` p + in r * (p^(e-1)) + digitRev (p,e-1) q + +indexToPowPPow, indexToZmsPPow :: PPow pp => Tagged pp (Int -> Int) +indexToPowPPow = indexToPow <$> ppPPow +indexToZmsPPow = indexToZms <$> ppPPow + +-- | Convert a @Z_m^*@ index to a linear tensor index in @[m]@. +zmsToIndexFact :: Fact m => Tagged m (Int -> Int) +zmsToIndexFact = zmsToIndex <$> ppsFact + +-- | For a prime power @p^e@, map a tensor index to the corresponding +-- power j in @[phi(p^e)]@, as in the powerful basis. +indexToPow :: PP -> Int -> Int +-- CJP: use accumulator to avoid multiple exponentiations? +indexToPow (p,e) j = let (jq,jr) = j `divMod` (p-1) + in p^(e-1)*jr + digitRev (p,e-1) jq + +-- | For a prime power @p^e@, map a tensor index to the corresponding +-- element i in @Z_{p^e}^*@. +indexToZms :: PP -> Int -> Int +indexToZms (p,_) i = let (i1,i0) = i `divMod` (p-1) + in p*i1 + i0 + 1 + +-- | Convert a Z_m^* index to a linear tensor index. +zmsToIndex :: [PP] -> Int -> Int +zmsToIndex [] _ = 0 +zmsToIndex (pp:rest) i = zmsToIndexPP pp (i `mod` valuePP pp) + + (totientPP pp) * zmsToIndex rest i + +-- | Inverse of 'indexToZms'. +zmsToIndexPP :: PP -> Int -> Int +zmsToIndexPP (p,_) i = let (i1,i0) = i `divMod` p + in (p-1)*i1 + i0 - 1 + +-- Index correspondences for ring extensions + +-- | Correspondences between the linear indexes into a basis of O_m', +-- and pair indices into (extension basis) \otimes (basis of O_m). +-- The work the same for Pow,Dec,CRT bases because all these bases +-- have that factorization. The first argument is the list of +-- @(phi(m),phi(m'))@ pairs for the (merged) prime powers of @m@,@m'@. +toIndexPair :: [(Int,Int)] -> Int -> (Int,Int) +fromIndexPair :: [(Int,Int)] -> (Int,Int) -> Int + +toIndexPair [] 0 = (0,0) +toIndexPair ((phi,phi'):rest) i' = + let (i'q,i'r) = i' `divMod` phi' + (i'rq,i'rr) = i'r `divMod` phi + (i'q1,i'q0) = toIndexPair rest i'q + in (i'rq + i'q1*(phi' `div` phi), i'rr + i'q0*phi) + +fromIndexPair [] (0,0) = 0 +fromIndexPair ((phi,phi'):rest) (i1,i0) = + let (i0q,i0r) = i0 `divMod` phi + (i1q,i1r) = i1 `divMod` (phi' `div` phi) + i = fromIndexPair rest (i1q,i0q) + in (i0r + i1r*phi) + i*phi' + +-- | A collection of useful information for working with tensor +-- extensions. The first component is a list of triples @(p,e,e')@ +-- where @e@, @e'@ are respectively the exponents of prime @p@ in @m@, +-- @m'@. The next two components are @phi(m)@ and @phi(m')@. The +-- final component is a pair @(phi(p^e), phi(p^e'))@ for each triple +-- in the first component. +indexInfo :: forall m m' . (m `Divides` m') + => Tagged '(m, m') ([(Int,Int,Int)], Int, Int, [(Int,Int)]) +indexInfo = let pps = proxy ppsFact (Proxy::Proxy m) + pps' = proxy ppsFact (Proxy::Proxy m') + mpps = mergePPs pps pps' + phi = totientPPs pps + phi' = totientPPs pps' + tots = totients mpps + in tag (mpps, phi, phi', tots) + +-- | A vector of @phi(m)@ entries, where the @i@th entry is the index +-- into the powerful\/decoding basis of @O_m'@ of the +-- @i@th entry of the powerful\/decoding basis of @O_m@. +extIndicesPowDec :: (m `Divides` m') => Tagged '(m, m') (U.Vector Int) +extIndicesPowDec = do + (_, phi, _, tots) <- indexInfo + return $ U.generate phi (fromIndexPair tots . (0,)) + +-- | A vector of @phi(m)@ blocks of @phi(m')\/phi(m)@ consecutive +-- entries. Each block contains all those indices into the CRT basis +-- of @O_m'@ that "lie above" the corresponding index into the CRT +-- basis of @O_m@. +extIndicesCRT :: forall m m' . (m `Divides` m') + => Tagged '(m, m') (U.Vector Int) +extIndicesCRT = do + (_, phi, phi', tots) <- indexInfo + return $ U.generate phi' + (fromIndexPair tots . swap . (`divMod` (phi' `div` phi))) + +baseWrapper :: forall m m' a . (m `Divides` m', U.Unbox a) + => ([(Int,Int,Int)] -> Int -> a) + -> Tagged '(m, m') (U.Vector a) +baseWrapper f = do + (mpps, _, phi', _) <- indexInfo + return $ U.generate phi' (f mpps) + +-- | A lookup table for 'toIndexPair' applied to indices @[phi(m')]@. +baseIndicesPow :: forall m m' . (m `Divides` m') + => Tagged '(m, m') (U.Vector (Int,Int)) +-- | A lookup table for 'baseIndexDec' applied to indices @[phi(m')]@. +baseIndicesDec :: forall m m' . (m `Divides` m') + => Tagged '(m, m') (U.Vector (Maybe (Int,Bool))) + +-- | Same as 'baseIndicesPow', but only includes the second component +-- of each pair. +baseIndicesCRT :: forall m m' . (m `Divides` m') + => Tagged '(m, m') (U.Vector Int) + +baseIndicesPow = baseWrapper (toIndexPair . totients) + +-- this one is more complicated; requires the prime powers +baseIndicesDec = baseWrapper baseIndexDec + +baseIndicesCRT = + baseWrapper (\pps -> snd . toIndexPair (totients pps)) + + +-- | The @i0@th entry of the @i1@th vector is 'fromIndexPair' @(i1,i0)@. +extIndicesCoeffs :: forall m m' . (m `Divides` m') + => Tagged '(m, m') (V.Vector (U.Vector Int)) +extIndicesCoeffs = do + (_, phi, phi', tots) <- indexInfo + return $ V.generate (phi' `div` phi) + (\i1 -> U.generate phi (\i0 -> fromIndexPair tots (i1,i0))) + +-- | Convenient reindexing functions + +-- | Maps an index of the extension ring array to its corresponding +-- index in the base ring array (if it exists), with sign, under the +-- decoding basis. +baseIndexDec :: [(Int,Int,Int)] -> Int -> Maybe (Int, Bool) +baseIndexDec [] 0 = Just (0,False) +baseIndexDec ((p,e,e'):rest) i' + = let (i'q, i'r) = i' `divMod` totientPP (p,e') + phi = totientPP (p,e) + curr + | p>2 && e==0 && e' > 0 = case i'r of + 0 -> Just (0,False) + 1 -> Just (0,True) + _ -> Nothing + | otherwise = if i'r < phi then Just (i'r,False) else Nothing + in do + (i,b) <- curr + (j,b') <- baseIndexDec rest i'q + return (i + phi*j, b /= b') + +-- the first list of pps must "divide" the other. result is a list of +-- all (prime, min e, max e). +mergePPs :: [PP] -> [PP] -> [(Int,Int,Int)] +mergePPs [] pps = LP.map (\(p,e) -> (p,0,e)) pps +mergePPs allpps@((p,e):pps) ((p',e'):pps') + | p == p' && e <= e' = (p, e, e') : mergePPs pps pps' + | p > p' = (p', 0, e') : mergePPs allpps pps' + +totients :: [(Int, Int, Int)] -> [(Int,Int)] +totients = LP.map (\(p,e,e') -> (totientPP (p,e), totientPP (p,e'))) diff --git a/src/Crypto/Lol/Cyclotomic/Tensor/CTensor.hs b/src/Crypto/Lol/Cyclotomic/Tensor/CTensor.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/Lol/Cyclotomic/Tensor/CTensor.hs @@ -0,0 +1,723 @@ +{-# LANGUAGE ConstraintKinds, DataKinds, DeriveDataTypeable, GADTs, + FlexibleContexts, FlexibleInstances, TypeOperators, PolyKinds, + GeneralizedNewtypeDeriving, InstanceSigs, RoleAnnotations, + MultiParamTypeClasses, NoImplicitPrelude, StandaloneDeriving, + ScopedTypeVariables, TupleSections, TypeFamilies, RankNTypes, + TypeSynonymInstances, UndecidableInstances, + RebindableSyntax #-} + +-- | Wrapper for a C implementation of the 'Tensor' interface. + +module Crypto.Lol.Cyclotomic.Tensor.CTensor +( CT +-- Exports below here are due solely to ticket #10338. See CycTests for more details +, CRNS +, Dispatch +) where + +import Algebra.Additive as Additive (C) +import Algebra.Ring as Ring (C) + +import Control.Applicative +import Control.DeepSeq +import Control.Monad +import Control.Monad.Identity +import Control.Monad.Random +import Control.Monad.Trans (lift) + +import Data.Coerce +import Data.Constraint +import Data.Foldable as F +import Data.Int +import Data.Maybe +import Data.Traversable as T +import Data.Typeable +import Data.Vector.Generic as V (zip, unzip) +import Data.Vector.Storable as SV (Vector, replicate, replicateM, thaw, convert, foldl', + unsafeToForeignPtr0, unsafeSlice, mapM, fromList, + generate, foldl1', + unsafeWith, zipWith, map, length, unsafeFreeze, thaw) +import Data.Vector.Storable.Internal (getPtr) +import Data.Vector.Storable.Mutable as SM hiding (replicate) + +import Foreign.ForeignPtr +import Foreign.Marshal.Array +import Foreign.Ptr +import Foreign.Storable (Storable (..)) +import qualified Foreign.Storable.Record as Store +import Foreign.Storable.Tuple () +import System.IO.Unsafe +import Test.QuickCheck hiding (generate) +import Unsafe.Coerce + +import Crypto.Lol.CRTrans +import Crypto.Lol.LatticePrelude as LP hiding (replicate, unzip, zip, lift) +import Crypto.Lol.Reflects +import Crypto.Lol.Cyclotomic.Tensor + +import Crypto.Lol.Types.IZipVector +import Crypto.Lol.Types.ZqBasic +import Crypto.Lol.GaussRandom + +import Crypto.Lol.Cyclotomic.Tensor.CTensor.Extension + +import Algebra.ZeroTestable as ZeroTestable (C) + + +-- | Newtype wrapper around a Vector. +newtype CT' (m :: Factored) r = CT' { unCT :: Vector r } + deriving (Show, Eq, NFData, Typeable) + +-- the first argument, though phantom, affects representation +type role CT' representational nominal + +-- GADT wrapper that distinguishes between Unbox and unrestricted +-- element types + +-- | An implementation of 'Tensor' backed by C code. +data CT (m :: Factored) r where + CT :: Storable r => CT' m r -> CT m r + ZV :: IZipVector m r -> CT m r + deriving (Typeable) + +instance Eq r => Eq (CT m r) where + (ZV x) == (ZV y) = x == y + (CT x) == (CT y) = x == y + x@(CT _) == y = x == toCT y + y == x@(CT _) = x == toCT y + +deriving instance Show r => Show (CT m r) + +toCT :: (Storable r) => CT m r -> CT m r +toCT v@(CT _) = v +toCT (ZV v) = CT $ zvToCT' v + +toZV :: (Fact m) => CT m r -> CT m r +toZV (CT (CT' v)) = ZV $ fromMaybe (error "toZV: internal error") $ + iZipVector $ convert v +toZV v@(ZV _) = v + +zvToCT' :: forall m r . (Storable r) => IZipVector m r -> CT' m r +zvToCT' v = coerce $ (convert $ unIZipVector v :: Vector r) + +wrap :: (Storable r) => (CT' l r -> CT' m r) -> (CT l r -> CT m r) +wrap f (CT v) = CT $ f v +wrap f (ZV v) = CT $ f $ zvToCT' v + +wrapM :: (Storable r, Monad mon) => (CT' l r -> mon (CT' m r)) + -> (CT l r -> mon (CT m r)) +wrapM f (CT v) = liftM CT $ f v +wrapM f (ZV v) = liftM CT $ f $ zvToCT' v + +-- convert an CT' *twace* signature to Tagged one +type family Tw (r :: *) :: * where + Tw (CT' m' r -> CT' m r) = Tagged '(m,m') (Vector r -> Vector r) + Tw (Maybe (CT' m' r -> CT' m r)) = TaggedT '(m,m') Maybe (Vector r -> Vector r) + +type family Em r where + Em (CT' m r -> CT' m' r) = Tagged '(m,m') (Vector r -> Vector r) + Em (Maybe (CT' m r -> CT' m' r)) = TaggedT '(m,m') Maybe (Vector r -> Vector r) + + +---------- NUMERIC PRELUDE INSTANCES ---------- +instance (Additive r, Storable r, CRNS r, Fact m) + => Additive.C (CT m r) where + (CT a@(CT' _)) + (CT b@(CT' _)) = CT $ (zipWrapper $ untag $ cZipDispatch dadd) a b --pack $ SV.zipWith (+) (unpack a) (unpack b) -- Vector code -- + a + b = (toCT a) + (toCT b) + negate (CT (CT' a)) = CT $ CT' $ SV.map negate a -- EAC: This probably should be converted to C code + negate a = negate $ toCT a + + zero = CT $ repl zero + +instance (Fact m, Ring r, Storable r, CRNS r) + => Ring.C (CT m r) where + (CT a@(CT' _)) * (CT b@(CT' _)) = CT $ (zipWrapper $ untag $ cZipDispatch dmul) a b --pack $ SV.zipWith (*) (unpack a) (unpack b) -- Vector code -- + a * b = (toCT a) * (toCT b) + + fromInteger = CT . repl . fromInteger + +instance (ZeroTestable r, Storable r, Fact m) + => ZeroTestable.C (CT m r) where + --{-# INLINABLE isZero #-} + isZero (CT (CT' a)) = SV.foldl' (\ b x -> b && isZero x) True a + isZero (ZV v) = isZero v + +---------- "Container" instances ---------- + +instance Fact m => Functor (CT m) where + -- Functor instance is implied by Applicative laws + fmap f x = pure f <*> x + +instance Fact m => Applicative (CT m) where + pure = ZV . pure + + (ZV f) <*> (ZV a) = ZV (f <*> a) + f@(ZV _) <*> v@(CT _) = f <*> toZV v + +instance Fact m => Foldable (CT m) where + -- Foldable instance is implied by Traversable + foldMap = foldMapDefault + +instance Fact m => Traversable (CT m) where + traverse f r@(CT _) = T.traverse f $ toZV r + traverse f (ZV v) = ZV <$> T.traverse f v + +instance Tensor CT where + + type TElt CT r = (IntegralDomain r, ZeroTestable r, + Eq r, Random r, NFData r, + Storable r, CRNS r) + + entailIndexT = tag $ Sub Dict + entailFullT = tag $ Sub Dict + + scalarPow = CT . scalarPow' -- Vector code + + l = wrap $ lgWrapper $ untag $ lgDispatch dl + lInv = wrap $ lgWrapper $ untag $ lgDispatch dlinv + + mulGPow = wrap mulGPow' -- mulGPow' already has lgWrapper + mulGDec = wrap $ lgWrapper $ untag $ lgDispatch dmulgdec + + divGPow = wrapM $ divGPow' + -- we divide by p in the C code (for divGDec only(?)), do NOT call checkDiv! + divGDec = wrapM $ divGWrapper $ Just . (untag $ lgDispatch dginvdec) + + crtFuncs = (,,,,) <$> + Just (CT . repl) <*> + (liftM wrap $ crtWrapper $ (untag $ cZipDispatch dmul) <$> untagT gCoeffsCRT) <*> + (liftM wrap $ crtWrapper $ (untag $ cZipDispatch dmul) <$> untagT gInvCoeffsCRT) <*> + (liftM wrap $ untagT $ crt') <*> + (liftM wrap $ crtWrapper $ untagT ctCRTInv) + + twacePowDec = wrap $ runIdentity $ coerceTw twacePowDec' + embedPow = wrap $ runIdentity $ coerceEm embedPow' + embedDec = wrap $ runIdentity $ coerceEm embedDec' + + tGaussianDec v = liftM CT $ gaussWrapper $ cDispatchGaussian v + --tGaussianDec v = liftM CT $ coerceT' $ gaussianDec v + + crtExtFuncs = (,) <$> (liftM wrap $ coerceTw twaceCRT') + <*> (liftM wrap $ coerceEm embedCRT') + + coeffs = wrapM $ coerceCoeffs $ coeffs' + + powBasisPow = (CT <$>) <$> coerceBasis powBasisPow' + + crtSetDec = (CT <$>) <$> coerceBasis crtSetDec' + + fmapT f (CT v) = CT $ coerce (SV.map f) v + fmapT f v@(ZV _) = fmapT f $ toCT v + + fmapTM f (CT (CT' arr)) = liftM (CT . CT') $ SV.mapM f arr + fmapTM f v@(ZV _) = fmapTM f $ toCT v + +coerceTw :: (Functor mon) => (TaggedT '(m, m') mon (Vector r -> Vector r)) -> mon (CT' m' r -> CT' m r) +coerceTw = (coerce <$>) . untagT + +coerceEm :: (Functor mon) => (TaggedT '(m, m') mon (Vector r -> Vector r)) -> mon (CT' m r -> CT' m' r) +coerceEm = (coerce <$>) . untagT + +-- | Useful coersion for defining @coeffs@ in the @Tensor@ +-- interface. Using 'coerce' alone is insufficient for type inference. +coerceCoeffs :: (Fact m, Fact m') + => Tagged '(m,m') (Vector r -> [Vector r]) -> CT' m' r -> [CT' m r] +coerceCoeffs = coerce + +-- | Useful coersion for defining @powBasisPow@ and @crtSetDec@ in the @Tensor@ +-- interface. Using 'coerce' alone is insufficient for type inference. +coerceBasis :: + (Fact m, Fact m') + => Tagged '(m,m') ([Vector r]) -> Tagged m [CT' m' r] +coerceBasis = coerce + +-- | Class to dispatch to the C backend for various element types. +class CRNS r where + + zipWrapper :: (Fact m) => + (forall a . (TElt CT a, Dispatch a) => CT' m a -> CT' m a -> CT' m a) + -> CT' m r -> CT' m r -> CT' m r + + crtWrapper :: (Fact m, CRTrans r) => + (forall a . (TElt CT a, CRTrans a, Dispatch a) => Maybe (CT' m a -> CT' m a)) + -> Maybe (CT' m r -> CT' m r) + + lgWrapper :: (Fact m) => + (forall a . (TElt CT a, Dispatch a) => CT' m a -> CT' m a) + -> CT' m r -> CT' m r + + divGWrapper :: (Fact m) => + (forall a . (TElt CT a, Dispatch a) => CT' m a -> Maybe (CT' m a)) + -> CT' m r -> Maybe (CT' m r) + + gaussWrapper :: (Fact m, MonadRandom rnd) => + (forall a . (TElt CT a, Dispatch a, OrdFloat a, MonadRandom rnd) => rnd (CT' m a)) + -> rnd (CT' m r) + +instance CRNS Double where + zipWrapper f = f + crtWrapper f = f + lgWrapper f = f + divGWrapper f = f + gaussWrapper f = f + +instance CRNS Int64 where + zipWrapper f = f + crtWrapper f = f + lgWrapper f = f + divGWrapper f = f + gaussWrapper = error "Cannot call gaussianDec for Int64" + +instance (TElt CT (Complex a), Dispatch (Complex a)) => CRNS (Complex a) where + zipWrapper f = f + crtWrapper f = f + lgWrapper f = f + divGWrapper f = f + gaussWrapper = error "Cannot call gaussianDec for Complex" + +-- EAC: we need PolyKinds in paritcular for this instance +instance (TElt CT (ZqBasic q i), Dispatch (ZqBasic q i)) => CRNS (ZqBasic q i) where + zipWrapper f = f + crtWrapper f = f + lgWrapper f = f + divGWrapper f = f + gaussWrapper = error "Cannot call gaussianDec for ZqBasic" + +instance (Storable a, Storable b, CRNS a, CRNS b, CRTrans a, CRTrans b) + => CRNS (a,b) where + zipWrapper f (CT' x :: CT' m (a,b)) (CT' y) = + let (a,b) = unzip x + (c,d) = unzip y + (CT' ac) = zipWrapper f (CT' a :: CT' m a) (CT' c) + (CT' bd) = zipWrapper f (CT' b :: CT' m b) (CT' d) + in CT' $ zip ac bd + + crtWrapper f = do + fa <- crtWrapper f + fb <- crtWrapper f + return $ \ (CT' x :: CT' m (a,b)) -> + let (a,b) = unzip x + (CT' a') = fa (CT' a :: CT' m a) + (CT' b') = fb (CT' b :: CT' m b) + in CT' $ zip a' b' + + lgWrapper f (CT' x :: CT' m (a,b)) = + let (a, b) = unzip x + (CT' a') = lgWrapper f (CT' a :: CT' m a) + (CT' b') = lgWrapper f (CT' b :: CT' m b) + in CT' $ zip a' b' + + divGWrapper f (CT' x :: CT' m (a,b)) = + let (a, b) = unzip x + in do -- in Maybe + (CT' a') <- divGWrapper f (CT' a :: CT' m a) + (CT' b') <- divGWrapper f (CT' b :: CT' m b) + return $ CT' $ zip a' b' + + gaussWrapper f = do + (CT' a) <- gaussWrapper f + (CT' b) <- gaussWrapper f + return $ CT' $ zip a b + +mulGPow' :: (TElt CT r, Fact m) => CT' m r -> CT' m r +mulGPow' = lgWrapper $ untag $ lgDispatch dmulgpow + +divGPow' :: forall m r . (TElt CT r, Fact m) => CT' m r -> Maybe (CT' m r) +divGPow' = divGWrapper $ untag $ checkDiv $ lgDispatch dginvpow + +crt' :: forall m r . (TElt CT r, Fact m, CRTrans r) + => TaggedT m Maybe (CT' m r -> CT' m r) +crt' = tagT $ crtWrapper $ do + f <- proxyT ctCRT (Proxy::Proxy m) + return $ CT' . f . unCT + +--{-# INLINE lgDispatch #-} +lgDispatch :: forall m r . + (Storable r, Fact m, Additive r) + => (Ptr r -> Int64 -> Ptr CPP -> Int16 -> IO ()) + -> Tagged m (CT' m r -> CT' m r) +lgDispatch f = do + factors <- liftM marshalFactors ppsFact + totm <- liftM fromIntegral totientFact + let numFacts = fromIntegral $ SV.length factors + return $ coerce $ \yin -> unsafePerformIO $ do -- in IO + yout <- SV.thaw yin + SM.unsafeWith yout (\pout -> + SV.unsafeWith factors (\pfac -> + f pout totm pfac numFacts)) + unsafeFreeze yout + +--{-# INLINE ctCRT #-} +ctCRT :: forall m r . + (Storable r, CRTrans r, Dispatch r, + Fact m) + => TaggedT m Maybe (Vector r -> Vector r) +ctCRT = do -- in TaggedT m Maybe + ru' <- ru + factors <- pureT $ liftM marshalFactors ppsFact + totm <- pureT $ liftM fromIntegral totientFact + let numFacts = fromIntegral $ SV.length factors + return $ \yin -> unsafePerformIO $ do -- in IO + yout <- SV.thaw yin + SM.unsafeWith yout (\pout -> + SV.unsafeWith factors (\pfac -> + withPtrArray ru' (\ruptr -> + dcrt pout totm pfac numFacts ruptr))) + unsafeFreeze yout + +-- CTensor CRT^(-1) functions take inverse rus +--{-# INLINE ctCRTInv #-} +ctCRTInv :: (Storable r, CRTrans r, Dispatch r, + Fact m) + => TaggedT m Maybe (CT' m r -> CT' m r) +ctCRTInv = do -- in Maybe + mhatInv <- liftM snd $ crtInfoFact + ruinv' <- ruInv + factors <- pureT $ liftM marshalFactors ppsFact + totm <- pureT $ liftM fromIntegral totientFact + let numFacts = fromIntegral $ SV.length factors + -- EAC: can't use coerce here? + return $ \(CT' yin) -> unsafePerformIO $ do + yout <- SV.thaw yin + SM.unsafeWith yout (\pout -> + SV.unsafeWith factors (\pfac -> + withPtrArray ruinv' (\ruptr -> + dcrtinv pout totm pfac numFacts ruptr mhatInv))) + CT' <$> unsafeFreeze yout + +checkDiv :: forall m r . + (IntegralDomain r, Storable r, ZeroTestable r, + Fact m) + => Tagged m (CT' m r -> CT' m r) -> Tagged m (CT' m r -> Maybe (CT' m r)) +checkDiv f = do + f' <- f + oddRad' <- liftM fromIntegral oddRadicalFact + return $ \x -> + let (CT' y) = f' x + in CT' <$> (SV.mapM (`divIfDivis` oddRad')) y + +divIfDivis :: (IntegralDomain r, ZeroTestable r) => r -> r -> Maybe r +divIfDivis num den = let (q,r) = num `divMod` den + in if isZero r then Just q else Nothing + +cZipDispatch :: (Storable r, Fact m, Additive r) + => (Ptr r -> Ptr r -> Int64 -> IO ()) + -> Tagged m (CT' m r -> CT' m r -> CT' m r) +cZipDispatch f = do -- in Tagged m + totm <- liftM fromIntegral $ totientFact + return $ coerce $ \a b -> unsafePerformIO $ do + yout <- SV.thaw a + SM.unsafeWith yout (\pout -> + SV.unsafeWith b (\pin -> + f pout pin totm)) + unsafeFreeze yout + +cDispatchGaussian :: forall m r var rnd . + (Storable r, Transcendental r, Dispatch r, Ord r, + Fact m, ToRational var, Random r, MonadRandom rnd) + => var -> rnd (CT' m r) +cDispatchGaussian var = liftM CT' $ flip proxyT (Proxy::Proxy m) $ do -- in TaggedT m rnd + -- get rus for (Complex r) + ruinv' <- mapTaggedT (return . fromMaybe (error "complexGaussianRoots")) $ ruInv + factors <- liftM marshalFactors $ pureT ppsFact + totm <- pureT totientFact + m <- pureT valueFact + rad <- pureT radicalFact + yin <- lift $ realGaussians (var * fromIntegral (m `div` rad)) totm + let numFacts = fromIntegral $ SV.length factors + return $ unsafePerformIO $ do -- in IO + --let yin = create $ SM.new totm :: Vector r -- contents will be overwritten, so no need to initialize + yout <- SV.thaw yin + SM.unsafeWith yout (\pout -> + SV.unsafeWith factors (\pfac -> + withPtrArray ruinv' (\ruptr -> + dgaussdec pout (fromIntegral totm) pfac numFacts ruptr))) + unsafeFreeze yout + +instance (Arbitrary r, Fact m, Storable r) => Arbitrary (CT' m r) where + arbitrary = replM arbitrary + shrink = shrinkNothing + +instance (Storable r, Arbitrary (CT' m r)) => Arbitrary (CT m r) where + arbitrary = CT <$> arbitrary + +instance (Storable r, Random r, Fact m) => Random (CT' m r) where + --{-# INLINABLE random #-} + random = runRand $ replM (liftRand random) + + randomR = error "randomR nonsensical for CT'" + +instance (Storable r, Random (CT' m r)) => Random (CT m r) where + --{-# INLINABLE random #-} + random = runRand $ liftM CT (liftRand random) + + randomR = error "randomR nonsensical for CT" + +instance (NFData r) => NFData (CT m r) where + rnf (CT v) = rnf v + rnf (ZV v) = rnf v + +repl :: forall m r . (Fact m, Storable r) => r -> CT' m r +repl = let n = proxy totientFact (Proxy::Proxy m) + in coerce . SV.replicate n + +replM :: forall m r mon . (Fact m, Storable r, Monad mon) + => mon r -> mon (CT' m r) +replM = let n = proxy totientFact (Proxy::Proxy m) + in liftM coerce . SV.replicateM n + +--{-# INLINE scalarPow' #-} +scalarPow' :: forall t m r v . + (Fact m, Additive r, Storable r) + => r -> CT' m r +-- constant-term coefficient is first entry wrt powerful basis +scalarPow' = + let n = proxy totientFact (Proxy::Proxy m) + in \r -> CT' $ generate n (\i -> if i == 0 then r else zero) + +ru, ruInv :: forall r m . + (CRTrans r, Fact m, Storable r) + => TaggedT m Maybe [Vector r] +--{-# INLINE ru #-} +ru = do + mval <- pureT valueFact + wPow <- liftM fst $ crtInfoFact + liftM (LP.map + (\(p,e) -> do + let pp = p^e + pow = mval `div` pp + generate pp (wPow . (*pow)))) $ + pureT ppsFact + +--{-# INLINE ruInv #-} +ruInv = do + mval <- pureT valueFact + wPow <- liftM fst $ crtInfoFact + liftM (LP.map + (\(p,e) -> do + let pp = p^e + pow = mval `div` pp + generate pp (\i -> wPow $ (-i*pow)))) $ + pureT ppsFact + +gCoeffsCRT, gInvCoeffsCRT :: (TElt CT r, CRTrans r, Fact m) + => TaggedT m Maybe (CT' m r) +gCoeffsCRT = crt' <*> (return $ mulGPow' $ scalarPow' LP.one) +-- It's necessary to call 'fromJust' here: otherwise +-- sequencing functions in 'crtFuncs' relies on 'divGPow' having an +-- implementation in C, which is not true for all types which have a C +-- implementation of, e.g. 'crt'. In particular, 'Complex Double' has C support +-- for 'crt', but not for 'divGPow'. +-- This really breaks the contract of Tensor, so it's probably a bad idea. +-- Someone can get the "crt" and can even pull the function "divGCRT" from Tensor, +-- but it will fail when they try to apply it. +-- As an implementation note if I ever do fix this: the division by rad(m) can be +-- tricky for Double/Complex Doubles, so be careful! This is why we have a custom +-- Complex wrapper around NP.Complex. +gInvCoeffsCRT = ($ fromJust $ divGPow' $ scalarPow' LP.one) <$> crt' + +-- we can't put this in Extension with the rest of the twace/embed fucntions because it needs access to +-- the C backend +twaceCRT' :: forall m m' r . + (TElt CT r, CRTrans r, m `Divides` m') + => TaggedT '(m, m') Maybe (Vector r -> Vector r) +twaceCRT' = tagT $ do -- Maybe monad + (CT' g') <- proxyT gCoeffsCRT (Proxy::Proxy m') + (CT' gInv) <- proxyT gInvCoeffsCRT (Proxy::Proxy m) + embed <- proxyT embedCRT' (Proxy::Proxy '(m,m')) + indices <- pure $ proxy extIndicesCRT (Proxy::Proxy '(m,m')) + (_, m'hatinv) <- proxyT crtInfoFact (Proxy::Proxy m') + let phi = proxy totientFact (Proxy::Proxy m) + phi' = proxy totientFact (Proxy::Proxy m') + mhat = fromIntegral $ proxy valueHatFact (Proxy::Proxy m) + hatRatioInv = m'hatinv * mhat + reltot = phi' `div` phi + -- tweak = mhat * g' / (m'hat * g) + tweak = SV.map (* hatRatioInv) $ SV.zipWith (*) (embed gInv) g' + return $ \ arr -> -- take true trace after mul-by-tweak + let v = backpermute' indices (SV.zipWith (*) tweak arr) + in generate phi $ \i -> foldl1' (+) $ SV.unsafeSlice (i*reltot) reltot v + + + + + + + + + + + + +-- C-backend support + +marshalFactors :: [PP] -> Vector CPP +marshalFactors = SV.fromList . LP.map (\(p,e) -> CPP (fromIntegral p) (fromIntegral e)) + +-- http://stackoverflow.com/questions/6517387/vector-vector-foo-ptr-ptr-foo-io-a-io-a +withPtrArray :: (Storable a) => [Vector a] -> (Ptr (Ptr a) -> IO b) -> IO b +withPtrArray v f = do + let vs = LP.map SV.unsafeToForeignPtr0 v + ptrV = LP.map (\(fp,_) -> getPtr fp) vs + res <- withArray ptrV f + LP.mapM_ (\(fp,_) -> touchForeignPtr fp) vs + return res + +data CPP = CPP {p' :: !Int32, e' :: !Int16} +-- stolen from http://hackage.haskell.org/packages/archive/numeric-prelude/0.4.0.3/doc/html/src/Number-Complex.html#T +-- the NumericPrelude Storable instance for complex numbers +instance Storable CPP where + sizeOf = Store.sizeOf store + alignment = Store.alignment store + peek = Store.peek store + poke = Store.poke store + +store :: Store.Dictionary CPP +store = Store.run $ + liftA2 CPP + (Store.element p') + (Store.element e') + +instance Show CPP where + show (CPP p e) = "(" LP.++ (show p) LP.++ "," LP.++ (show e) LP.++ ")" + +foreign import ccall unsafe "tensorLR" tensorLR :: Ptr Int64 -> Int64 -> Ptr CPP -> Int16 -> IO () +foreign import ccall unsafe "tensorLInvR" tensorLInvR :: Ptr Int64 -> Int64 -> Ptr CPP -> Int16 -> IO () +foreign import ccall unsafe "tensorLRq" tensorLRq :: Ptr (ZqBasic q Int64) -> Int64 -> Ptr CPP -> Int16 -> Int64 -> IO () +foreign import ccall unsafe "tensorLInvRq" tensorLInvRq :: Ptr (ZqBasic q Int64) -> Int64 -> Ptr CPP -> Int16 -> Int64 -> IO () +foreign import ccall unsafe "tensorLDouble" tensorLDouble :: Ptr Double -> Int64 -> Ptr CPP -> Int16 -> IO () +foreign import ccall unsafe "tensorLInvDouble" tensorLInvDouble :: Ptr Double -> Int64 -> Ptr CPP -> Int16 -> IO () +foreign import ccall unsafe "tensorLC" tensorLC :: Ptr (Complex Double) -> Int64 -> Ptr CPP -> Int16 -> IO () +foreign import ccall unsafe "tensorLInvC" tensorLInvC :: Ptr (Complex Double) -> Int64 -> Ptr CPP -> Int16 -> IO () + +foreign import ccall unsafe "tensorGPowR" tensorGPowR :: Ptr Int64 -> Int64 -> Ptr CPP -> Int16 -> IO () +foreign import ccall unsafe "tensorGPowRq" tensorGPowRq :: Ptr (ZqBasic q Int64) -> Int64 -> Ptr CPP -> Int16 -> Int64 -> IO () +foreign import ccall unsafe "tensorGDecR" tensorGDecR :: Ptr Int64 -> Int64 -> Ptr CPP -> Int16 -> IO () +foreign import ccall unsafe "tensorGDecRq" tensorGDecRq :: Ptr (ZqBasic q Int64) -> Int64 -> Ptr CPP -> Int16 -> Int64 -> IO () +foreign import ccall unsafe "tensorGInvPowR" tensorGInvPowR :: Ptr Int64 -> Int64 -> Ptr CPP -> Int16 -> IO () +foreign import ccall unsafe "tensorGInvPowRq" tensorGInvPowRq :: Ptr (ZqBasic q Int64) -> Int64 -> Ptr CPP -> Int16 -> Int64 -> IO () +foreign import ccall unsafe "tensorGInvDecR" tensorGInvDecR :: Ptr Int64 -> Int64 -> Ptr CPP -> Int16 -> IO () +foreign import ccall unsafe "tensorGInvDecRq" tensorGInvDecRq :: Ptr (ZqBasic q Int64) -> Int64 -> Ptr CPP -> Int16 -> Int64 -> IO () +--foreign import ccall unsafe "tensorGCRTRq" tensorGCRTRq :: Ptr (ZqBasic q Int64) -> Int64 -> Ptr CPP -> Int16 -> Ptr (Ptr (ZqBasic q Int64)) -> Int64 -> IO () +--foreign import ccall unsafe "tensorGCRTC" tensorGCRTC :: Ptr (Complex Double) -> Int64 -> Ptr CPP -> Int16 -> Ptr (Ptr (Complex Double)) -> IO () +--foreign import ccall unsafe "tensorGInvCRTRq" tensorGInvCRTRq :: Ptr (ZqBasic q Int64) -> Int64 -> Ptr CPP -> Int16 -> Ptr (Ptr (ZqBasic q Int64)) -> Int64 -> IO () +--foreign import ccall unsafe "tensorGInvCRTC" tensorGInvCRTC :: Ptr (Complex Double) -> Int64 -> Ptr CPP -> Int16 -> Ptr (Ptr (Complex Double)) -> IO () + +foreign import ccall unsafe "tensorCRTRq" tensorCRTRq :: Ptr (ZqBasic q Int64) -> Int64 -> Ptr CPP -> Int16 -> Ptr (Ptr (ZqBasic q Int64)) -> Int64 -> IO () +foreign import ccall unsafe "tensorCRTC" tensorCRTC :: Ptr (Complex Double) -> Int64 -> Ptr CPP -> Int16 -> Ptr (Ptr (Complex Double)) -> IO () +foreign import ccall unsafe "tensorCRTInvRq" tensorCRTInvRq :: Ptr (ZqBasic q Int64) -> Int64 -> Ptr CPP -> Int16 -> Ptr (Ptr (ZqBasic q Int64)) -> Int64 -> Int64 -> IO () +foreign import ccall unsafe "tensorCRTInvC" tensorCRTInvC :: Ptr (Complex Double) -> Int64 -> Ptr CPP -> Int16 -> Ptr (Ptr (Complex Double)) -> Double -> IO () + +foreign import ccall unsafe "tensorGaussianDec" tensorGaussianDec :: Ptr Double -> Int64 -> Ptr CPP -> Int16 -> Ptr (Ptr (Complex Double)) -> IO () + +foreign import ccall unsafe "mulRq" mulRq :: Ptr (ZqBasic q Int64) -> Ptr (ZqBasic q Int64) -> Int64 -> Int64 -> IO () +foreign import ccall unsafe "mulC" mulC :: Ptr (Complex Double) -> Ptr (Complex Double) -> Int64 -> IO () + +foreign import ccall unsafe "addRq" addRq :: Ptr (ZqBasic q Int64) -> Ptr (ZqBasic q Int64) -> Int64 -> Int64 -> IO () +foreign import ccall unsafe "addR" addR :: Ptr Int64 -> Ptr Int64 -> Int64 -> IO () +foreign import ccall unsafe "addC" addC :: Ptr (Complex Double) -> Ptr (Complex Double) -> Int64 -> IO () +foreign import ccall unsafe "addD" addD :: Ptr Double -> Ptr Double -> Int64 -> IO () + +-- | Class to safely match Haskell types with the appropriate C function. +class Dispatch r where + dcrt :: Ptr r -> Int64 -> Ptr CPP -> Int16 -> Ptr (Ptr r) -> IO () + dcrtinv :: Ptr r -> Int64 -> Ptr CPP -> Int16 -> Ptr (Ptr r) -> r -> IO () + dl :: Ptr r -> Int64 -> Ptr CPP -> Int16 -> IO () + dlinv :: Ptr r -> Int64 -> Ptr CPP -> Int16 -> IO () + dmulgpow :: Ptr r -> Int64 -> Ptr CPP -> Int16 -> IO () + dmulgdec :: Ptr r -> Int64 -> Ptr CPP -> Int16 -> IO () + dginvpow :: Ptr r -> Int64 -> Ptr CPP -> Int16 -> IO () + dginvdec :: Ptr r -> Int64 -> Ptr CPP -> Int16 -> IO () + dadd :: Ptr r -> Ptr r -> Int64 -> IO () + dmul :: Ptr r -> Ptr r -> Int64 -> IO () + dgcrt :: Ptr r -> Int64 -> Ptr CPP -> Int16 -> Ptr (Ptr r) -> IO () + dginvcrt :: Ptr r -> Int64 -> Ptr CPP -> Int16 -> Ptr (Ptr r) -> IO () + dgaussdec :: Ptr r -> Int64 -> Ptr CPP -> Int16 -> Ptr (Ptr (Complex r)) -> IO () + +instance (Reflects q Int64) => Dispatch (ZqBasic q Int64) where + dcrt pout totm pfac numFacts ruptr = + let q = proxy value (Proxy::Proxy q) + in tensorCRTRq pout totm pfac numFacts ruptr q + dcrtinv pout totm pfac numFacts ruptr minv = + let q = proxy value (Proxy::Proxy q) + --EAC: GHC doesn't like it if I change the type of minv to ZqBasic in the + -- signature of tensorCRTInvRq, and the constructor of ZqBasic isn't exposed + -- so using unsafeCoerce for now + in tensorCRTInvRq pout totm pfac numFacts ruptr (unsafeCoerce minv) q + dl pout totm pfac numFacts = + let q = proxy value (Proxy::Proxy q) + in tensorLRq pout totm pfac numFacts q + dlinv pout totm pfac numFacts = + let q = proxy value (Proxy::Proxy q) + in tensorLInvRq pout totm pfac numFacts q + dmulgpow pout totm pfac numFacts = + let q = proxy value (Proxy::Proxy q) + in tensorGPowRq pout totm pfac numFacts q + dmulgdec pout totm pfac numFacts = + let q = proxy value (Proxy::Proxy q) + in tensorGDecRq pout totm pfac numFacts q + dginvpow pout totm pfac numFacts = + let q = proxy value (Proxy::Proxy q) + in tensorGInvPowRq pout totm pfac numFacts q + dginvdec pout totm pfac numFacts = + let q = proxy value (Proxy::Proxy q) + in tensorGInvDecRq pout totm pfac numFacts q + dadd aout bout totm = + let q = proxy value (Proxy::Proxy q) + in addRq aout bout totm q + dmul aout bout totm = + let q = proxy value (Proxy::Proxy q) + in mulRq aout bout totm q + dgcrt pout totm pfac numFacts gcoeffs' = error "dgcrt zq" + --let q = proxy value (Proxy::Proxy q) + --in tensorGCRTRq pout totm pfac numFacts gcoeffs' q + dginvcrt pout totm pfac numFacts gcoeffs' = error "dginvcrt zq" + --let q = proxy value (Proxy::Proxy q) + --in tensorGInvCRTRq pout totm pfac numFacts gcoeffs' q + dgaussdec = error "cannot call CT gaussianDec on type ZqBasic" + +instance Dispatch (Complex Double) where + dcrt = tensorCRTC + dcrtinv pout totm pfac numFacts ruptr minv = + tensorCRTInvC pout totm pfac numFacts ruptr (real minv) + dl = tensorLC + dlinv = tensorLInvC + dmulgpow = error "cannot call CT mulGPow on type Complex Double" + dmulgdec = error "cannot call CT mulGDec on type Complex Double" + dginvpow = error "cannot call CT divGPow on type Complex Double" + dginvdec = error "cannot call CT divGDec on type Complex Double" + dadd = addC + dmul = mulC + dgcrt = error "tensorGCRTC" + dginvcrt = error "tensorGInvCRTC" + dgaussdec = error "cannot call CT gaussianDec on type Comple Double" + +instance Dispatch Double where + dcrt = error "cannot call CT Crt on type Double" + dcrtinv = error "cannot call CT CrtInv on type Double" + dl = tensorLDouble + dlinv = tensorLInvDouble + dmulgpow = error "cannot call CT mulGPow on type Double" + dmulgdec = error "cannot call CT mulGDec on type Double" + dginvpow = error "cannot call CT divGPow on type Double" + dginvdec = error "cannot call CT divGDec on type Double" + dadd = addD + dmul = error "cannot call CT (*) on type Double" + dgcrt = error "cannot call CT mulGCRT on type Double" + dginvcrt = error "cannot call CT divGCRT on type Double" + dgaussdec = tensorGaussianDec + +instance Dispatch Int64 where + dcrt = error "cannot call CT Crt on type Int64" + dcrtinv = error "cannot call CT CrtInv on type Int64" + dl = tensorLR + dlinv = tensorLInvR + dmulgpow = tensorGPowR + dmulgdec = tensorGDecR + dginvpow = tensorGInvPowR + dginvdec = tensorGInvDecR + dadd = addR + dmul = error "cannot call CT (*) on type Int64" + dgcrt = error "cannot call CT mulGCRT on type Int64" + dginvcrt = error "cannot call CT divGCRT on type Int64" + dgaussdec = error "cannot call CT gaussianDec on type Int64" diff --git a/src/Crypto/Lol/Cyclotomic/Tensor/CTensor/Extension.hs b/src/Crypto/Lol/Cyclotomic/Tensor/CTensor/Extension.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/Lol/Cyclotomic/Tensor/CTensor/Extension.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE ConstraintKinds, FlexibleContexts, MultiParamTypeClasses, + NoImplicitPrelude, RebindableSyntax, ScopedTypeVariables, + TypeFamilies, TypeOperators, DataKinds #-} + +-- | CT-specific functions for embedding/twacing in various bases + +module Crypto.Lol.Cyclotomic.Tensor.CTensor.Extension +( embedPow', embedDec', embedCRT' +, twacePowDec' -- , twaceCRT' +, coeffs', powBasisPow' +, crtSetDec' +, backpermute' +) where + +import Crypto.Lol.CRTrans +import Crypto.Lol.LatticePrelude as LP hiding (null, lift) +import Crypto.Lol.Cyclotomic.Tensor as T +import Crypto.Lol.Types.FiniteField +import Crypto.Lol.Types.ZmStar +import Crypto.Lol.Reflects + +import Control.Applicative hiding (empty) +import Control.Monad.Trans (lift) + +import Data.Maybe +import Data.Reflection (reify) +import qualified Data.Vector as V +import Data.Vector.Generic as G (generate, Vector, (!), length) +import qualified Data.Vector.Unboxed as U +import qualified Data.Vector.Storable as SV + + +-- | /O(n)/ Yield the vector obtained by replacing each element @i@ of the +-- index vector by @xs'!'i@. This is equivalent to @'map' (xs'!') is@ but is +-- often much more efficient. +-- +-- > backpermute <0,3,2,3,1,0> = +backpermute' :: (Vector v a) + => U.Vector Int -- ^ @is@ index vector (of length @n@) + -> v a -- ^ @xs@ value vector + -> v a +--{-# INLINE backpermute' #-} +backpermute' is v = generate (G.length is) (\i -> v ! (is ! i)) + +embedPow', embedDec' :: (Additive r, Vector v r, m `Divides` m') + => Tagged '(m, m') (v r -> v r) +-- | Embeds an vector in the powerful basis of the the mth cyclotomic ring +-- to an vector in the powerful basis of the m'th cyclotomic ring when @m | m'@ +embedPow' = (\indices arr -> generate (U.length indices) $ \idx -> + let (j0,j1) = indices ! idx + in if j0 == 0 + then arr ! j1 + else zero) <$> baseIndicesPow +-- | Embeds an vector in the decoding basis of the the mth cyclotomic ring +-- to an vector in the decoding basis of the m'th cyclotomic ring when @m | m'@ +embedDec' = (\indices arr -> generate (U.length indices) + (\idx -> maybe LP.zero + (\(sh,b) -> if b then negate (arr ! sh) else arr ! sh) + (indices U.! idx))) <$> baseIndicesDec + +-- | Embeds an vector in the CRT basis of the the mth cyclotomic ring +-- to an vector in the CRT basis of the m'th cyclotomic ring when @m | m'@ +embedCRT' :: forall m m' v r . (CRTrans r, Vector v r, m `Divides` m') + => TaggedT '(m, m') Maybe (v r -> v r) +embedCRT' = + (lift (proxyT crtInfoFact (Proxy::Proxy m') :: Maybe (CRTInfo r))) >> + (pureT $ backpermute' <$> baseIndicesCRT) + +-- | maps a vector in the powerful/decoding basis, representing an +-- O_m' element, to a vector of arrays representing O_m elements in +-- the same type of basis +coeffs' :: (Vector v r, m `Divides` m') + => Tagged '(m, m') (v r -> [v r]) +coeffs' = flip (\x -> V.toList . V.map (`backpermute'` x)) + <$> extIndicesCoeffs + +-- | The "tweaked trace" function in either the powerful or decoding +-- basis of the m'th cyclotomic ring to the mth cyclotomic ring when +-- @m | m'@. +twacePowDec' :: forall m m' r v . (Vector v r, m `Divides` m') + => Tagged '(m, m') (v r -> v r) +twacePowDec' = backpermute' <$> extIndicesPowDec + + +-- EAC: twaceCRT is defined in CTensor because it needs access to C-backend functions + + +-- | The powerful extension basis, wrt the powerful basis. +-- Outputs a list of vectors in O_m' that are an O_m basis for O_m' +powBasisPow' :: forall m m' r . (m `Divides` m', Ring r, SV.Storable r) + => Tagged '(m, m') [SV.Vector r] +powBasisPow' = do + (_, phi, phi', _) <- indexInfo + idxs <- baseIndicesPow + return $ LP.map (\k -> generate phi' $ \j -> + let (j0,j1) = idxs U.! j + in if j0==k && j1==0 then one else zero) + [0..phi' `div` phi - 1] + +-- | A list of vectors representing the mod-p CRT set of the +-- extension O_m'/O_m +crtSetDec' :: forall m m' fp . + (m `Divides` m', PrimeField fp, Coprime (PToF (CharOf fp)) m', + SV.Storable fp) + => Tagged '(m, m') [SV.Vector fp] +crtSetDec' = + let m'p = Proxy :: Proxy m' + p = proxy value (Proxy::Proxy (CharOf fp)) + phi = proxy totientFact m'p + d = proxy (order p) m'p + h :: Int = proxy valueHatFact m'p + hinv = recip $ fromIntegral h + in reify d $ \(_::Proxy d) -> do + let twCRTs' :: Matrix (GF fp d) + = fromMaybe (error "internal error: crtSetDec': twCRTs") $ proxyT twCRTs m'p + zmsToIdx = proxy T.zmsToIndexFact m'p + elt j i = indexM twCRTs' j (zmsToIdx i) + trace' = trace :: GF fp d -> fp -- to avoid recomputing powTraces + cosets <- partitionCosets p + return $ LP.map (\is -> generate phi + (\j -> hinv * trace' + (sum $ LP.map (elt j) is))) cosets diff --git a/src/Crypto/Lol/Cyclotomic/Tensor/CTensor/basic.c b/src/Crypto/Lol/Cyclotomic/Tensor/CTensor/basic.c new file mode 100644 --- /dev/null +++ b/src/Crypto/Lol/Cyclotomic/Tensor/CTensor/basic.c @@ -0,0 +1,162 @@ +#include "tensorTypes.h" +#ifdef CINTRIN +#include +#endif + +#ifdef STATS +int mulCtr = 0; +struct timespec mulTime = {0,0}; + +int addCtr = 0; +struct timespec addTime = {0,0}; +#endif + +//a = zipWith (*) a b +void mulRq (hInt_t* a, hInt_t* b, hDim_t totm, hInt_t q) { +#ifdef STATS + mulCtr++; + struct timespec s1,t1; + clock_gettime(CLOCK_REALTIME, &s1); +#endif + for(int i = 0; i < totm; i++) { + a[i] = (a[i]*b[i])%q; + } +#ifdef STATS + clock_gettime(CLOCK_REALTIME, &t1); + mulTime = tsAdd(mulTime, tsSubtract(t1,s1)); +#endif +} + +void mulMq (hInt_t* a, const hInt_t* b, const hDim_t totm, const hByte_t logr, const hInt_t k, const hInt_t q) { +#ifdef STATS + mulCtr++; + struct timespec s1,t1; + clock_gettime(CLOCK_REALTIME, &s1); +#endif + hInt_t mask = (1<>logr; + } + +#ifdef STATS + clock_gettime(CLOCK_REALTIME, &t1); + mulTime = tsAdd(mulTime, tsSubtract(t1,s1)); +#endif +} + +void mulC (complex_t* a, complex_t* b, hDim_t totm) { +#ifdef STATS + mulCtr++; + struct timespec s1,t1; + clock_gettime(CLOCK_REALTIME, &s1); +#endif + for(int i = 0; i < totm; i++) + { + CMPLX_IMUL(a[i],b[i]); + } +#ifdef STATS + clock_gettime(CLOCK_REALTIME, &t1); + mulTime = tsAdd(mulTime, tsSubtract(t1,s1)); +#endif +} + +//a = zipWith (+) a b +void addRq (hInt_t* a, const hInt_t* b, const hDim_t totm, const hInt_t q) { +#ifdef STATS + addCtr++; + struct timespec s1,t1; + clock_gettime(CLOCK_REALTIME, &s1); +#endif +#ifdef CINTRIN + __m128i qs = _mm_set1_epi64x(q); + for(int i = 0; i < totm; i+=2) { + __m128i xs = _mm_load_si128((const __m128i*)(a+i)); + __m128i ys = _mm_load_si128((const __m128i*)(b+i)); + __m128i zs = _mm_add_epi64(xs,ys); + zs = _mm_rem_epi64(zs,qs); + _mm_store_si128((__m128i*)(a+i),zs); + } +#else + for(int i = 0; i < totm; i++) { + hInt_t temp = a[i]+b[i]; + if (temp >= q) a[i]=temp-q; + else a[i] = temp; + } +#endif +#ifdef STATS + clock_gettime(CLOCK_REALTIME, &t1); + addTime = tsAdd(addTime, tsSubtract(t1,s1)); +#endif +} + +void addMq (hInt_t* a, const hInt_t* b, const hDim_t totm, const hByte_t logr, const hInt_t k, const hInt_t q) { +#ifdef STATS + addCtr++; + struct timespec s1,t1; + clock_gettime(CLOCK_REALTIME, &s1); +#endif + hInt_t twoq = q<<1; + for(int i = 0; i < totm; i++) { + hInt_t temp = (a[i]+b[i]); + if (temp >= twoq) a[i]=temp-twoq; + else a[i] = temp; + } + +#ifdef STATS + clock_gettime(CLOCK_REALTIME, &t1); + addTime = tsAdd(addTime, tsSubtract(t1,s1)); +#endif +} + +//a = zipWith (+) a b +void addR (hInt_t* a, hInt_t* b, hDim_t totm) { +#ifdef STATS + addCtr++; + struct timespec s1,t1; + clock_gettime(CLOCK_REALTIME, &s1); +#endif + for(int i = 0; i < totm; i++) { + a[i] += b[i]; + } +#ifdef STATS + clock_gettime(CLOCK_REALTIME, &t1); + addTime = tsAdd(addTime, tsSubtract(t1,s1)); +#endif +} + +void addC (complex_t* a, complex_t* b, hDim_t totm) { +#ifdef STATS + addCtr++; + struct timespec s1,t1; + clock_gettime(CLOCK_REALTIME, &s1); +#endif + for(int i = 0; i < totm; i++) + { + CMPLX_IADD(a[i],b[i]); + } +#ifdef STATS + clock_gettime(CLOCK_REALTIME, &t1); + addTime = tsAdd(addTime, tsSubtract(t1,s1)); +#endif +} + +void addD (double* a, double* b, hDim_t totm) { +#ifdef STATS + addCtr++; + struct timespec s1,t1; + clock_gettime(CLOCK_REALTIME, &s1); +#endif + for(int i = 0; i < totm; i++) + { + a[i]+=b[i]; + } +#ifdef STATS + clock_gettime(CLOCK_REALTIME, &t1); + addTime = tsAdd(addTime, tsSubtract(t1,s1)); +#endif +} + diff --git a/src/Crypto/Lol/Cyclotomic/Tensor/CTensor/crt.c b/src/Crypto/Lol/Cyclotomic/Tensor/CTensor/crt.c new file mode 100644 --- /dev/null +++ b/src/Crypto/Lol/Cyclotomic/Tensor/CTensor/crt.c @@ -0,0 +1,1305 @@ +#include "tensorTypes.h" +#include +#include + +// there should be a special cases that do NOT require temp space to be allocated for all primes *smaller* than DFTP_GENERIC_SIZE +#define DFTP_GENERIC_SIZE 11 + +#ifdef STATS +int crtRqCtr = 0; +int crtInvRqCtr = 0; +int crtCCtr = 0; +int crtInvCCtr = 0; + +struct timespec crttime1 = {0,0}; +struct timespec crttime2 = {0,0}; +struct timespec crttime3 = {0,0}; +struct timespec crttime4 = {0,0}; + +struct timespec crtInvRqTime = {0,0}; +struct timespec crtCTime = {0,0}; +struct timespec crtInvCTime = {0,0}; +#endif + +hDim_t bitrev (PrimeExponent pe, hDim_t j) { + hShort_t e; + hDim_t p = pe.prime; + hDim_t tempj = j; + hDim_t acc = 0; + + for(e = pe.exponent-1; e >= 0; e--) { + div_t qr = div(tempj,p); + acc += qr.rem * ipow(p,e); + tempj = qr.quot; + } + return acc; +} + +void crtTwiddleRq (hInt_t* y, hDim_t lts, hDim_t rts, PrimeExponent pe, hInt_t* ru, hInt_t q) +{ + hDim_t p = pe.prime; + hShort_t e = pe.exponent; + +#ifdef DEBUG_MODE + ASSERT(e != 0); +#endif + pe.exponent -= 1; // used for an argument to bitrev + + if(p == 2) + { + hDim_t mprime = 1<<(e-1); + hDim_t blockDim = rts*mprime; // size of block in block diagonal tensor matrix + + for(hDim_t i0 = 1; i0 < mprime; i0++) // loops over i/(p-1) for i = 0..(m'-1), we can skip i0 = 0 + { + hDim_t temp2 = i0*rts; + hInt_t twid = ru[bitrev(pe, i0)]; + + for(hDim_t blockIdx = 0; blockIdx < lts; blockIdx++) + { + hDim_t temp3 = blockIdx*blockDim + temp2; + for(hDim_t modOffset = 0; modOffset < rts; modOffset++) + { + hDim_t idx = temp3 + modOffset; + y[idx] = (y[idx]*twid) % q; + } + } + } + } + else // This loop is faster, probably due to the division in the loop above. + // cilk also slows it down + { + hDim_t mprime = ipow(p,e-1); + hDim_t blockDim = rts*(p-1)*mprime; // size of block in block diagonal tensor matrix + + for(hDim_t i0 = 1; i0 < mprime; i0++) // loops over i/(p-1) for i = 0..(m'-1), we can skip i0 = 0 + { + hDim_t temp1 = i0*(p-1); + for(hDim_t i1 = 0; i1 < (p-1); i1++) // loops over i%(p-1) for i = 0..(m'-1) + { + hDim_t temp2 = (temp1+i1)*rts; + hInt_t twid = ru[bitrev(pe, i0)*(i1+1)]; + + for(hDim_t blockIdx = 0; blockIdx < lts; blockIdx++) + { + hDim_t temp3 = blockIdx*blockDim + temp2; + for(hDim_t modOffset = 0; modOffset < rts; modOffset++) + { + hDim_t idx = temp3 + modOffset; + y[idx] = (y[idx]*twid) % q; + } + } + } + } + } +} + +// dim is power of p +void dftptwidRq (hInt_t* y, hDim_t lts, hDim_t rts, PrimeExponent pe, hDim_t dim, hDim_t rustride, hInt_t* ru, hInt_t q) +{ + hDim_t idx; + hDim_t p = pe.prime; + + pe.exponent -= 1; // used for an argument to bitrev + + if(p == 2) { + hDim_t mprime = dim>>1; // divides evenly + hDim_t temp1 = rts*dim; // for use in computing [modified] tensorOffset + for(hDim_t i0 = 1; i0 < mprime; i0++) // loops over i/p for i = 0..(dim-1), but we skip i0=0 + { + hDim_t temp3 = rts*(i0*p+1); + hInt_t twid = ru[bitrev(pe,i0)*rustride]; + + for(hDim_t blockOffset = 0; blockOffset < lts; blockOffset++) + { + hDim_t temp2 = blockOffset*temp1 + temp3; + for(hDim_t modOffset = 0; modOffset < rts; modOffset++) + { + idx = temp2 + modOffset; + y[idx] = (y[idx]*twid) % q; + } + } + } + } + else + { + hDim_t mprime = dim/p; // divides evenly + hDim_t temp1 = rts*dim; // for use in computing [modified] tensorOffset + for(hDim_t i0 = 1; i0 < mprime; i0++) // loops over i/p for i = 0..(dim-1), but we skip i0=0 + { + for(hDim_t i1 = 1; i1 < p; i1++) // loops over i%p for i = 0..(dim-1), but we skip i1=0 + { + hDim_t temp3 = rts*(i0*p+i1); + hInt_t twid = ru[bitrev(pe,i0)*i1*rustride]; + + for(hDim_t blockOffset = 0; blockOffset < lts; blockOffset++) + { + hDim_t temp2 = blockOffset*temp1 + temp3; + for(hDim_t modOffset = 0; modOffset < rts; modOffset++) + { + idx = temp2 + modOffset; + y[idx] = (y[idx]*twid) % q; + } + } + } + } + } +} + +//implied length of ru is rustride*p +//implied length of tempSpace is p, if p is not a special case +// temp is allowed to be NULL if p < DFTP_GENERIC_SIZE +void dftpRq (hInt_t* y, hDim_t lts, hDim_t rts, hDim_t p, hDim_t rustride, hInt_t* ru, hInt_t* tempSpace, hInt_t q) +{ + hDim_t tensorOffset; + + if(p == 2) + { + hDim_t temp1 = rts<<1; + + for(hDim_t blockOffset = 0; blockOffset < lts; blockOffset++) + { + hDim_t temp2 = blockOffset*temp1; + for(hDim_t modOffset = 0; modOffset < rts; modOffset++) + { + tensorOffset = temp2 + modOffset; + hInt_t u = y[tensorOffset]; + hInt_t t = y[tensorOffset+rts]; + y[tensorOffset] = (u + t) % q; + y[tensorOffset+rts] = (u - t) % q; + } + } + } + else if(p == 3) + { + hInt_t ru1 = ru[rustride]; + hInt_t ru2 = ru[rustride<<1]; + hDim_t temp1 = rts*3; + + for(hDim_t blockOffset = 0; blockOffset < lts; blockOffset++) + { + hDim_t temp2 = blockOffset*temp1; + for(hDim_t modOffset = 0; modOffset < rts; modOffset++) + { + tensorOffset = temp2 + modOffset; + hInt_t y1, y2, y3; + y1 = y[tensorOffset]; + y2 = y[tensorOffset+rts]; + y3 = y[tensorOffset+(rts<<1)]; + //q is <32 bits, so we can do 3 additions without overflow + y[tensorOffset] = (y1 + y2 + y3) % q; + y[tensorOffset+rts] = (y1 + ((ru1*y2) % q) + ((ru2*y3) % q)) % q; + y[tensorOffset+(rts<<1)] = (y1 + ((ru2*y2) % q) + ((ru1*y3) % q)) % q; + } + } + + } + else if(p == 5) + { + hDim_t temp1 = rts*5; + hInt_t ru1 = ru[rustride]; + hInt_t ru2 = ru[rustride<<1]; + hInt_t ru3 = ru[rustride*3]; + hInt_t ru4 = ru[rustride<<2]; + + for(hDim_t blockOffset = 0; blockOffset < lts; blockOffset++) + { + hDim_t temp2 = blockOffset*temp1; + for(hDim_t modOffset = 0; modOffset < rts; modOffset++) + { + tensorOffset = temp2 + modOffset; + hInt_t y1, y2, y3, y4, y5; + y1 = y[tensorOffset]; + y2 = y[tensorOffset+rts]; + y3 = y[tensorOffset+(rts<<1)]; + y4 = y[tensorOffset+3*rts]; + y5 = y[tensorOffset+(rts<<2)]; + y[tensorOffset] = (y1 + y2 + y3 + y4 + y5) % q; + y[tensorOffset+rts] = (y1 + ((ru1*y2) % q) + ((ru2*y3) % q) + ((ru3*y4) % q) + ((ru4*y5) % q)) % q; + y[tensorOffset+(rts<<1)] = (y1 + ((ru2*y2) % q) + ((ru4*y3) % q) + ((ru1*y4) % q) + ((ru3*y5) % q)) % q; + y[tensorOffset+rts*3] = (y1 + ((ru3*y2) % q) + ((ru1*y3) % q) + ((ru4*y4) % q) + ((ru2*y5) % q)) % q; + y[tensorOffset+(rts<<2)] = (y1 + ((ru4*y2) % q) + ((ru3*y3) % q) + ((ru2*y4) % q) + ((ru1*y5) % q)) % q; + } + } + } + else if(p == 7) + { + hDim_t temp1 = rts*7; + hInt_t ru1 = ru[rustride]; + hInt_t ru2 = ru[rustride<<1]; + hInt_t ru3 = ru[rustride*3]; + hInt_t ru4 = ru[rustride<<2]; + hInt_t ru5 = ru[rustride*5]; + hInt_t ru6 = ru[rustride*6]; + + for(hDim_t blockOffset = 0; blockOffset < lts; blockOffset++) + { + hDim_t temp2 = blockOffset*temp1; + for(hDim_t modOffset = 0; modOffset < rts; modOffset++) + { + tensorOffset = temp2 + modOffset; + hInt_t y1, y2, y3, y4, y5, y6, y7; + y1 = y[tensorOffset]; + y2 = y[tensorOffset+rts]; + y3 = y[tensorOffset+(rts<<1)]; + y4 = y[tensorOffset+3*rts]; + y5 = y[tensorOffset+(rts<<2)]; + y6 = y[tensorOffset+rts*5]; + y7 = y[tensorOffset+rts*6]; + y[tensorOffset] = (y1 + y2 + y3 + y4 + y5 + y6 + y7) % q; + y[tensorOffset+rts] = (y1 + ((ru1*y2) % q) + ((ru2*y3) % q) + ((ru3*y4) % q) + ((ru4*y5) % q) + ((ru5*y6) % q) + ((ru6*y7) % q)) % q; + y[tensorOffset+(rts<<1)] = (y1 + ((ru2*y2) % q) + ((ru4*y3) % q) + ((ru6*y4) % q) + ((ru1*y5) % q) + ((ru3*y6) % q) + ((ru5*y7) % q)) % q; + y[tensorOffset+rts*3] = (y1 + ((ru3*y2) % q) + ((ru6*y3) % q) + ((ru2*y4) % q) + ((ru5*y5) % q) + ((ru1*y6) % q) + ((ru4*y7) % q)) % q; + y[tensorOffset+(rts<<2)] = (y1 + ((ru4*y2) % q) + ((ru1*y3) % q) + ((ru5*y4) % q) + ((ru2*y5) % q) + ((ru6*y6) % q) + ((ru3*y7) % q)) % q; + y[tensorOffset+rts*5] = (y1 + ((ru5*y2) % q) + ((ru3*y3) % q) + ((ru1*y4) % q) + ((ru6*y5) % q) + ((ru4*y6) % q) + ((ru2*y7) % q)) % q; + y[tensorOffset+rts*6] = (y1 + ((ru6*y2) % q) + ((ru5*y3) % q) + ((ru4*y4) % q) + ((ru3*y5) % q) + ((ru2*y6) % q) + ((ru1*y7) % q)) % q; + } + } + } + else + { + hDim_t temp1 = rts*p; + for(hDim_t blockOffset = 0; blockOffset < lts; blockOffset++) + { + hDim_t temp2 = blockOffset*temp1; + for(hDim_t modOffset = 0; modOffset < rts; modOffset++) + { + tensorOffset = temp2 + modOffset; + for(hDim_t row = 0; row < p; row++) + { + hInt_t acc = 0; + //p is small (<< 30 bits), so we can do p additions of mod-q values without overflow + for(hDim_t col = 0; col < p; col++) + { + acc += ((y[tensorOffset+col*rts]*ru[((col*row) % p)*rustride])%q); + } + tempSpace[row] = acc % q; + } + + for(hDim_t row = 0; row < p; row++) + { + y[tensorOffset+rts*row] = tempSpace[row]; + } + } + } + } +} + +void crtpRq (hInt_t* y, hDim_t lts, hDim_t rts, hDim_t p, hDim_t rustride, hInt_t* ru, hInt_t q) +{ + hDim_t tensorOffset; + if(p == 2) + { + return; + } + else if(p == 3) + { + hDim_t temp1 = rts*2; + hInt_t ru1 = ru[rustride]; + hInt_t ru2 = ru[rustride<<1]; + + for(hDim_t blockOffset = 0; blockOffset < lts; blockOffset++) + { + hDim_t temp2 = blockOffset*temp1; + for(hDim_t modOffset = 0; modOffset < rts; modOffset++) + { + tensorOffset = temp2 + modOffset; + hInt_t y1, y2; + y1 = y[tensorOffset]; + y2 = y[tensorOffset+rts]; + y[tensorOffset] = (y1 + ((ru1*y2)%q)) % q; + y[tensorOffset+rts] = (y1 + ((ru2*y2)%q)) % q; + } + } + } + else if(p == 5) + { + hDim_t temp1 = rts*4; + hInt_t ru1 = ru[rustride]; + hInt_t ru2 = ru[rustride<<1]; + hInt_t ru3 = ru[rustride*3]; + hInt_t ru4 = ru[rustride<<2]; + + for(hDim_t blockOffset = 0; blockOffset < lts; blockOffset++) + { + hDim_t temp2 = blockOffset*temp1; + for(hDim_t modOffset = 0; modOffset < rts; modOffset++) + { + tensorOffset = temp2 + modOffset; + hInt_t y1, y2, y3, y4; + y1 = y[tensorOffset]; + y2 = y[tensorOffset+rts]; + y3 = y[tensorOffset+(rts<<1)]; + y4 = y[tensorOffset+3*rts]; + + y[tensorOffset] = (y1 + ((ru1*y2) % q) + ((ru2*y3) % q) + ((ru3*y4) % q)) % q; + y[tensorOffset+rts] = (y1 + ((ru2*y2) % q) + ((ru4*y3) % q) + ((ru1*y4) % q)) % q; + y[tensorOffset+(rts<<1)] = (y1 + ((ru3*y2) % q) + ((ru1*y3) % q) + ((ru4*y4) % q)) % q; + y[tensorOffset+rts*3] = (y1 + ((ru4*y2) % q) + ((ru3*y3) % q) + ((ru2*y4) % q)) % q; + } + } + } + else if(p == 7) + { + hDim_t temp1 = rts*6; + hInt_t ru1 = ru[rustride]; + hInt_t ru2 = ru[rustride<<1]; + hInt_t ru3 = ru[rustride*3]; + hInt_t ru4 = ru[rustride<<2]; + hInt_t ru5 = ru[rustride*5]; + hInt_t ru6 = ru[rustride*6]; + + for(hDim_t blockOffset = 0; blockOffset < lts; blockOffset++) + { + hDim_t temp2 = blockOffset*temp1; + for(hDim_t modOffset = 0; modOffset < rts; modOffset++) + { + tensorOffset = temp2 + modOffset; + hInt_t y1, y2, y3, y4, y5, y6; + y1 = y[tensorOffset]; + y2 = y[tensorOffset+rts]; + y3 = y[tensorOffset+(rts<<1)]; + y4 = y[tensorOffset+3*rts]; + y5 = y[tensorOffset+(rts<<2)]; + y6 = y[tensorOffset+rts*5]; + y[tensorOffset] = (y1 + ((ru1*y2) % q) + ((ru2*y3) % q) + ((ru3*y4) % q) + ((ru4*y5) % q) + ((ru5*y6) % q)) % q; + y[tensorOffset+rts] = (y1 + ((ru2*y2) % q) + ((ru4*y3) % q) + ((ru6*y4) % q) + ((ru1*y5) % q) + ((ru3*y6) % q)) % q; + y[tensorOffset+(rts<<1)] = (y1 + ((ru3*y2) % q) + ((ru6*y3) % q) + ((ru2*y4) % q) + ((ru5*y5) % q) + ((ru1*y6) % q)) % q; + y[tensorOffset+rts*3] = (y1 + ((ru4*y2) % q) + ((ru1*y3) % q) + ((ru5*y4) % q) + ((ru2*y5) % q) + ((ru6*y6) % q)) % q; + y[tensorOffset+(rts<<2)] = (y1 + ((ru5*y2) % q) + ((ru3*y3) % q) + ((ru1*y4) % q) + ((ru6*y5) % q) + ((ru4*y6) % q)) % q; + y[tensorOffset+rts*5] = (y1 + ((ru6*y2) % q) + ((ru5*y3) % q) + ((ru4*y4) % q) + ((ru3*y5) % q) + ((ru2*y6) % q)) % q; + } + } + } + else + { + hInt_t* tempSpace = (hInt_t*)malloc((p-1)*sizeof(hInt_t)); + hDim_t temp1 = rts*(p-1); + for(hDim_t blockOffset = 0; blockOffset < lts; blockOffset++) + { + hDim_t temp2 = blockOffset*temp1; + for(hDim_t modOffset = 0; modOffset < rts; modOffset++) + { + tensorOffset = temp2 + modOffset; + + for(hDim_t row = 1; row < p; row++) + { + hInt_t acc = 0; + for(hDim_t col = 0; col < p-1; col++) + { + acc += ((y[tensorOffset+col*rts]*ru[((col*row) % p)*rustride]) % q); + } + tempSpace[row-1] = acc % q; + } + + for(hDim_t row = 0; row < p-1; row++) + { + y[tensorOffset+rts*row] = tempSpace[row]; + } + } + } + free(tempSpace); + } +} + +//takes inverse rus +void crtpinvRq (hInt_t* y, hDim_t lts, hDim_t rts, hDim_t p, hDim_t rustride, hInt_t* ruinv, hInt_t q) +{ + if(p ==2) + { + // need this case so that we can divide overall by mhat^(-1) + return; + } + else + { + hDim_t tensorOffset,i; + hInt_t* tempSpace = (hInt_t*)malloc((p-1)*sizeof(hInt_t)); + hDim_t temp1 = rts*(p-1); + for(hDim_t blockOffset = 0; blockOffset < lts; blockOffset++) + { + hDim_t temp2 = blockOffset*temp1; + for(hDim_t modOffset = 0; modOffset < rts; modOffset++) + { + tensorOffset = temp2 + modOffset; + + for(i = 0; i < p-1; i++) + { + hInt_t sum = 0; + int j; + for(j = 0; j < p-1; j++) + { + int ruIdx = ((j+1)*i) % p; + sum += ((y[tensorOffset+j*rts] * ruinv[ruIdx*rustride]) % q); + } + tempSpace[i] = sum % q; + } + + hInt_t shift = 0; + for(i = 0; i < p-1; i++) + { + // we were given the inverse rus, so we need to negate the indices + shift += ((y[tensorOffset+i*rts] * ruinv[rustride*(p-(i+1))]) % q); + } + + for(i = 0; i < p-1; i++) + { + y[tensorOffset+i*rts] = (tempSpace[i] - shift) % q; + } + } + } + } +} + +void ppDFTRq (hInt_t* y, hDim_t lts, hDim_t rts, PrimeExponent pe, hDim_t rustride, hInt_t* ru, hInt_t q) +{ + hDim_t p = pe.prime; + hShort_t e = pe.exponent; + + if(e == 0) + { + return; + } + + hDim_t primeRuStride = rustride*ipow(p,e-1); + hInt_t* temp = 0; + if(p >= DFTP_GENERIC_SIZE) + { + temp = (hInt_t*)malloc(p*sizeof(hInt_t)); + } + hShort_t i; + + hDim_t ltsScale = ipow(p,e-1); + hDim_t rtsScale = 1; + hDim_t twidRuStride = rustride; + for(i = 0; i < e; i++) + { + hDim_t rtsDim = rts*rtsScale; + dftpRq (y, lts*ltsScale, rtsDim, p, primeRuStride, ru, temp, q); + dftptwidRq (y, lts, rtsDim, pe, ltsScale*p, twidRuStride, ru, q); + + ltsScale /= p; + rtsScale *= p; + twidRuStride *= p; + pe.exponent -= 1; + } + + if(p >= DFTP_GENERIC_SIZE) + { + free(temp); + } +} + +void ppDFTInvRq (hInt_t* y, hDim_t lts, hDim_t rts, PrimeExponent pe, hDim_t rustride, hInt_t* ru, hInt_t q) +{ + hDim_t p = pe.prime; + hShort_t e = pe.exponent; + + if(e == 0) + { + return; + } + hDim_t primeRuStride = rustride*ipow(p,e-1); + hInt_t* temp = 0; + if(p >= DFTP_GENERIC_SIZE) + { + temp = (hInt_t*)malloc(p*sizeof(hInt_t)); + } + hShort_t i; + + hDim_t ltsScale = 1; + hDim_t rtsScale = ipow(p,e-1); + hDim_t twidRuStride = primeRuStride; + pe.exponent = 1; + for(i = 0; i < e; i++) + { + hDim_t rtsDim = rts*rtsScale; + hDim_t ltsScaleP = ltsScale*p; + dftptwidRq (y, lts, rtsDim, pe, ltsScaleP, twidRuStride, ru, q); + dftpRq (y, lts*ltsScale, rtsDim, p, primeRuStride, ru, temp, q); + + ltsScale = ltsScaleP; + rtsScale /= p; + twidRuStride /= p; + pe.exponent += 1; + } + + if(p >= DFTP_GENERIC_SIZE) + { + free(temp); + } +} + +void ppcrtRq (void* y, hDim_t lts, hDim_t rts, PrimeExponent pe, void* ru, hInt_t q) +{ + hDim_t p = pe.prime; + hDim_t e = pe.exponent; +#ifdef DEBUG_MODE + ASSERT(e != 0); +#endif + hDim_t mprime = ipow(p,e-1); + +#ifdef DEBUG_MODE + printf("lts is %" PRId32 "\trts is %" PRId32 "\n", lts, rts); + printf("rus for p=%" PRId32 ", e=%" PRId16 "\t[", pe.prime, pe.exponent); + hDim_t i; + for(i = 0; i < ipow(p,e); i++) { + printf("%" PRId64 ",", ((hInt_t*)ru)[i]); + } + printf("]\n"); +#endif + + crtpRq ((hInt_t*)y, lts*mprime, rts, p, mprime, (hInt_t*)ru, q); + crtTwiddleRq ((hInt_t*)y, lts, rts, pe, (hInt_t*)ru, q); + pe.exponent -= 1; + ppDFTRq ((hInt_t*)y, lts, rts*(p-1), pe, p, (hInt_t*)ru, q); +} + +void ppcrtinvRq (void* y, hDim_t lts, hDim_t rts, PrimeExponent pe, void* ru, hInt_t q) +{ + hDim_t p = pe.prime; + hDim_t e = pe.exponent; +#ifdef DEBUG_MODE + ASSERT(e != 0); +#endif + hDim_t mprime = ipow(p,e-1); +#ifdef DEBUG_MODE + printf("lts is %" PRId32 "\trts is %" PRId32 "\n", lts, rts); + printf("rus for p=%" PRId32 ", e=%" PRId16 "\t[", pe.prime, pe.exponent); + hDim_t i; + for(i = 0; i < ipow(p,e); i++) { + printf("%" PRId64 ",", ((hInt_t*)ru)[i]); + } + printf("]\n"); +#endif + pe.exponent -= 1; + ppDFTInvRq ((hInt_t*)y, lts, rts*(p-1), pe, p, (hInt_t*)ru, q); + pe.exponent += 1; + crtTwiddleRq ((hInt_t*)y, lts, rts, pe, (hInt_t*)ru, q); + crtpinvRq ((hInt_t*)y, lts*mprime, rts, p, mprime, (hInt_t*)ru, q); +} + +// EAC: Somebody who knows C/C++ should find a better way to handle pointers-to-pointers in a generic way +void tensorCRTRq (hInt_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, hInt_t** ru, hInt_t q) +{ + + hDim_t i; +#ifdef STATS + struct timespec s1,s2,s3,s4,t1,t2,t3,t4; + + crtRqCtr++; + + clock_gettime(CLOCK_REALTIME, &s1); + clock_gettime(CLOCK_MONOTONIC, &s2); + clock_gettime(CLOCK_PROCESS_CPUTIME_ID, &s3); + clock_gettime(CLOCK_THREAD_CPUTIME_ID, &s4); +#endif +#ifdef DEBUG_MODE + printf("\n\nEntered tensorCRTRq\ttotm=%" PRId32 "\tnumFacts=%" PRId16 "\tq=%" PRId64 "\n[", totm, sizeOfPE, q); + + for(i = 0; i < totm; i++) { + printf("%" PRId64 ",", y[i]); + } + printf("]\n["); + for(i = 0; i < sizeOfPE; i++) { + printf("(%" PRId32 ",%" PRId16 "),", peArr[i].prime, peArr[i].exponent); + } + printf("]\n"); +#endif + void** rus = (void**)malloc(sizeOfPE*sizeof(void*)); + + for(i = 0; i < sizeOfPE; i++) + { + rus[i] = (void*) (ru[i]); + } + tensorFuserCRT (y, ppcrtRq, totm, peArr, sizeOfPE, rus, q); + + for(hDim_t j = 0; j < totm; j++) + { + if(y[j]<0) + { + y[j]+=q; + } +#ifdef DEBUG_MODE + if(y[j]<0) + { + printf("TENSOR CRT^T INV\n"); + } +#endif + } + + free(rus); +#ifdef STATS + clock_gettime(CLOCK_REALTIME, &t1); + clock_gettime(CLOCK_MONOTONIC, &t2); + clock_gettime(CLOCK_PROCESS_CPUTIME_ID, &t3); + clock_gettime(CLOCK_THREAD_CPUTIME_ID, &t4); + + crttime1 = tsAdd(crttime1, tsSubtract(t1,s1)); + crttime2 = tsAdd(crttime2, tsSubtract(t2,s2)); + crttime3 = tsAdd(crttime3, tsSubtract(t3,s3)); + crttime4 = tsAdd(crttime4, tsSubtract(t4,s4)); +#endif +} + +//takes inverse rus +void tensorCRTInvRq (hInt_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, hInt_t** ruinv, hInt_t mhatInv, hInt_t q) +{ + hDim_t i; +#ifdef STATS + struct timespec s1,t1; + crtInvRqCtr++; + clock_gettime(CLOCK_REALTIME, &s1); +#endif +#ifdef DEBUG_MODE + printf("\n\nEntered tensorCRTInvRq\ttotm=%" PRId32 "\tnumFacts=%" PRId16 "\tminv=%" PRId64 "\tq=%" PRId64 "\n[", totm, sizeOfPE, mhatInv, q); + for(i = 0; i < totm; i++) { + printf("%" PRId64 ",", y[i]); + } + printf("]\n["); + for(i = 0; i < sizeOfPE; i++) { + printf("(%" PRId32 ",%" PRId16 "),", peArr[i].prime, peArr[i].exponent); + } + printf("]\n"); +#endif + + void** rus = (void**)malloc(sizeOfPE*sizeof(void*)); + for(i = 0; i < sizeOfPE; i++) + { + rus[i] = (void*) (ruinv[i]); + } + + tensorFuserCRT (y, ppcrtinvRq, totm, peArr, sizeOfPE, rus, q); + + for (hDim_t j = 0; j < totm; j++) + { + y[j] = (y[j]*mhatInv)%q; + if(y[j] < 0) + { + y[j] +=q; + } +#ifdef DEBUG_MODE + if(y[j]<0) + { + printf("TENSOR CRT INV\n"); + } +#endif + } + + free(rus); +#ifdef STATS + clock_gettime(CLOCK_REALTIME, &t1); + crtInvRqTime = tsAdd(crtInvRqTime, tsSubtract(t1,s1)); +#endif +} + + + + + + + + + + + + + + +void crtTwiddleC (complex_t* y, hDim_t lts, hDim_t rts, PrimeExponent pe, complex_t* ru) +{ + hDim_t idx; + hDim_t p = pe.prime; + hShort_t e = pe.exponent; + +#ifdef DEBUG_MODE + ASSERT(e != 0); +#endif + + pe.exponent -= 1; // used for an argument to bitrev + + if(p == 2) + { + hDim_t mprime = 1<<(e-1); + hDim_t blockDim = rts*mprime; // size of block in block diagonal tensor matrix + + for(hDim_t i0 = 1; i0 < mprime; i0++) // loops over i/(p-1) for i = 0..(m'-1), we can skip i0 = 0 + { + hDim_t temp2 = i0*rts; + complex_t twid = ru[bitrev(pe,i0)]; + + for(hDim_t blockIdx = 0; blockIdx < lts; blockIdx++) + { + hDim_t temp3 = blockIdx*blockDim + temp2; + for(hDim_t modOffset = 0; modOffset < rts; modOffset++) + { + idx = temp3 + modOffset; + CMPLX_IMUL(y[idx],twid); + } + } + } + } + else + { + hDim_t mprime = ipow(p,e-1); + hDim_t blockDim = rts*(p-1)*mprime; // size of block in block diagonal tensor matrix + + for(hDim_t i0 = 1; i0 < mprime; i0++) // loops over i/(p-1) for i = 0..(m'-1), we can skip i0 = 0 + { + hDim_t temp1 = i0*(p-1); + for(hDim_t i1 = 0; i1 < (p-1); i1++) // loops over i%(p-1) for i = 0..(m'-1) + { + hDim_t temp2 = (temp1+i1)*rts; + complex_t twid = ru[bitrev(pe,i0)*(i1+1)]; + + for(hDim_t blockIdx = 0; blockIdx < lts; blockIdx++) + { + hDim_t temp3 = blockIdx*blockDim + temp2; + for(hDim_t modOffset = 0; modOffset < rts; modOffset++) + { + idx = temp3 + modOffset; + CMPLX_IMUL(y[idx],twid); + } + } + } + } + } +} + +// dim is power of p +void dftptwidC (complex_t* y, hDim_t lts, hDim_t rts, PrimeExponent pe, hDim_t dim, hDim_t rustride, complex_t* ru) +{ + hDim_t idx; + hDim_t p = pe.prime; + pe.exponent -= 1; // used for an argument to bitrev + + if(p == 2) + { + hDim_t mprime = dim>>1; // divides evenly + hDim_t temp1 = rts*dim; // for use in computing [modified] tensorOffset + for(hDim_t i0 = 1; i0 < mprime; i0++) // loops over i/p for i = 0..(dim-1), but we skip i0=0 + { + hDim_t temp3 = rts*(i0*p+1); + complex_t twid = ru[bitrev(pe,i0)*rustride]; + + for(hDim_t blockOffset = 0; blockOffset < lts; blockOffset++) + { + hDim_t temp2 = blockOffset*temp1 + temp3; + for(hDim_t modOffset = 0; modOffset < rts; modOffset++) + { + idx = temp2 + modOffset; + CMPLX_IMUL(y[idx],twid); + } + } + } + } + else + { + hDim_t mprime = dim/p; // divides evenly + hDim_t temp1 = rts*dim; // for use in computing [modified] tensorOffset + for(hDim_t i0 = 1; i0 < mprime; i0++) // loops over i/p for i = 0..(dim-1), but we skip i0=0 + { + for(hDim_t i1 = 1; i1 < p; i1++) // loops over i%p for i = 0..(dim-1), but we skip i1=0 + { + hDim_t temp3 = rts*(i0*p+i1); + complex_t twid = ru[bitrev(pe,i0)*i1*rustride]; + + for(hDim_t blockOffset = 0; blockOffset < lts; blockOffset++) + { + hDim_t temp2 = blockOffset*temp1 + temp3; + for(hDim_t modOffset = 0; modOffset < rts; modOffset++) + { + idx = temp2 + modOffset; + CMPLX_IMUL(y[idx],twid); + } + } + } + } + } +} + +//implied length of ru is rustride*p +//implied length of tempSpace is p, if p is not a special case +void dftpC (complex_t* y, hDim_t lts, hDim_t rts, hDim_t p, hDim_t rustride, complex_t* ru, complex_t* tempSpace) +{ + hDim_t blockOffset, modOffset, tensorOffset; + + if(p == 2) + { + hDim_t temp1 = rts<<1; + for(blockOffset = 0; blockOffset < lts; blockOffset++) + { + hDim_t temp2 = blockOffset*temp1; + for(modOffset = 0; modOffset < rts; modOffset++) + { + tensorOffset = temp2 + modOffset; + complex_t u = y[tensorOffset]; + complex_t t = y[tensorOffset+rts]; + y[tensorOffset] = CMPLX_ADD(u,t); + y[tensorOffset+rts] = CMPLX_SUB(u,t); + } + } + } + else if(p == 3) + { + hDim_t temp1 = rts*3; + complex_t ru1 = ru[rustride]; + complex_t ru2 = ru[rustride<<1]; + + for(blockOffset = 0; blockOffset < lts; blockOffset++) + { + hDim_t temp2 = blockOffset*temp1; + for(modOffset = 0; modOffset < rts; modOffset++) + { + tensorOffset = temp2 + modOffset; + complex_t y1, y2, y3; + y1 = y[tensorOffset]; + y2 = y[tensorOffset+rts]; + y3 = y[tensorOffset+(rts<<1)]; + y[tensorOffset] = CMPLX_ADD3(y1, y2, y3); + y[tensorOffset+rts] = CMPLX_ADD3(y1, CMPLX_MUL(ru1,y2), CMPLX_MUL(ru2,y3)); + y[tensorOffset+(rts<<1)] = CMPLX_ADD3(y1, CMPLX_MUL(ru2,y2), CMPLX_MUL(ru1,y3)); + } + } + } + else if(p == 5) + { + hDim_t temp1 = rts*5; + complex_t ru1 = ru[rustride]; + complex_t ru2 = ru[rustride<<1]; + complex_t ru3 = ru[rustride*3]; + complex_t ru4 = ru[rustride<<2]; + + for(blockOffset = 0; blockOffset < lts; blockOffset++) + { + hDim_t temp2 = blockOffset*temp1; + for(modOffset = 0; modOffset < rts; modOffset++) + { + tensorOffset = temp2 + modOffset; + complex_t y1, y2, y3, y4, y5; + y1 = y[tensorOffset]; + y2 = y[tensorOffset+rts]; + y3 = y[tensorOffset+(rts<<1)]; + y4 = y[tensorOffset+3*rts]; + y5 = y[tensorOffset+(rts<<2)]; + y[tensorOffset] = CMPLX_ADD5(y1, y2, y3, y4, y5); + y[tensorOffset+rts] = CMPLX_ADD5(y1, CMPLX_MUL(ru1,y2), CMPLX_MUL(ru2,y3), CMPLX_MUL(ru3,y4), CMPLX_MUL(ru4,y5)); + y[tensorOffset+(rts<<1)] = CMPLX_ADD5(y1, CMPLX_MUL(ru2,y2), CMPLX_MUL(ru4,y3), CMPLX_MUL(ru1,y4), CMPLX_MUL(ru3,y5)); + y[tensorOffset+rts*3] = CMPLX_ADD5(y1, CMPLX_MUL(ru3,y2), CMPLX_MUL(ru1,y3), CMPLX_MUL(ru4,y4), CMPLX_MUL(ru2,y5)); + y[tensorOffset+(rts<<2)] = CMPLX_ADD5(y1, CMPLX_MUL(ru4,y2), CMPLX_MUL(ru3,y3), CMPLX_MUL(ru2,y4), CMPLX_MUL(ru1,y5)); + } + } + } + else if(p == 7) + { + hDim_t temp1 = rts*7; + complex_t ru1 = ru[rustride]; + complex_t ru2 = ru[rustride<<1]; + complex_t ru3 = ru[rustride*3]; + complex_t ru4 = ru[rustride<<2]; + complex_t ru5 = ru[rustride*5]; + complex_t ru6 = ru[rustride*6]; + + for(blockOffset = 0; blockOffset < lts; blockOffset++) + { + hDim_t temp2 = blockOffset*temp1; + for(modOffset = 0; modOffset < rts; modOffset++) + { + tensorOffset = temp2 + modOffset; + complex_t y1, y2, y3, y4, y5, y6, y7; + y1 = y[tensorOffset]; + y2 = y[tensorOffset+rts]; + y3 = y[tensorOffset+(rts<<1)]; + y4 = y[tensorOffset+3*rts]; + y5 = y[tensorOffset+(rts<<2)]; + y6 = y[tensorOffset+rts*5]; + y7 = y[tensorOffset+rts*6]; + y[tensorOffset] = CMPLX_ADD7(y1, y2, y3, y4, y5, y6, y7); + y[tensorOffset+rts] = CMPLX_ADD7(y1, CMPLX_MUL(ru1,y2), CMPLX_MUL(ru2,y3), CMPLX_MUL(ru3,y4), CMPLX_MUL(ru4,y5), CMPLX_MUL(ru5,y6), CMPLX_MUL(ru6,y7)); + y[tensorOffset+(rts<<1)] = CMPLX_ADD7(y1, CMPLX_MUL(ru2,y2), CMPLX_MUL(ru4,y3), CMPLX_MUL(ru6,y4), CMPLX_MUL(ru1,y5), CMPLX_MUL(ru3,y6), CMPLX_MUL(ru5,y7)); + y[tensorOffset+rts*3] = CMPLX_ADD7(y1, CMPLX_MUL(ru3,y2), CMPLX_MUL(ru6,y3), CMPLX_MUL(ru2,y4), CMPLX_MUL(ru5,y5), CMPLX_MUL(ru1,y6), CMPLX_MUL(ru4,y7)); + y[tensorOffset+(rts<<2)] = CMPLX_ADD7(y1, CMPLX_MUL(ru4,y2), CMPLX_MUL(ru1,y3), CMPLX_MUL(ru5,y4), CMPLX_MUL(ru2,y5), CMPLX_MUL(ru6,y6), CMPLX_MUL(ru3,y7)); + y[tensorOffset+rts*5] = CMPLX_ADD7(y1, CMPLX_MUL(ru5,y2), CMPLX_MUL(ru3,y3), CMPLX_MUL(ru1,y4), CMPLX_MUL(ru6,y5), CMPLX_MUL(ru4,y6), CMPLX_MUL(ru2,y7)); + y[tensorOffset+rts*6] = CMPLX_ADD7(y1, CMPLX_MUL(ru6,y2), CMPLX_MUL(ru5,y3), CMPLX_MUL(ru4,y4), CMPLX_MUL(ru3,y5), CMPLX_MUL(ru2,y6), CMPLX_MUL(ru1,y7)); + } + } + } + else + { + hDim_t temp1 = rts*p; + for(blockOffset = 0; blockOffset < lts; blockOffset++) + { + hDim_t temp2 = blockOffset*temp1; + for(modOffset = 0; modOffset < rts; modOffset++) + { + tensorOffset = temp2 + modOffset; + hDim_t row, col; + + for(row = 0; row < p; row++) + { + complex_t acc = ((complex_t){0,0}); + for(col = 0; col < p; col++) + { + CMPLX_IADD(acc, CMPLX_MUL(y[tensorOffset+col*rts], ru[((col*row) % p)*rustride])); + } + tempSpace[row] = acc; + } + + for(row = 0; row < p; row++) + { + y[tensorOffset+rts*row] = tempSpace[row]; + } + } + } + } +} + +void crtpC (complex_t* y, hDim_t lts, hDim_t rts, hDim_t p, hDim_t rustride, complex_t* ru) +{ + hDim_t blockOffset, modOffset, tensorOffset; + + if(p == 2) + { + return; + } + else if(p == 3) + { + hDim_t temp1 = rts*2; + complex_t ru1 = ru[rustride]; + complex_t ru2 = ru[rustride<<1]; + + for(blockOffset = 0; blockOffset < lts; blockOffset++) + { + hDim_t temp2 = blockOffset*temp1; + for(modOffset = 0; modOffset < rts; modOffset++) + { + tensorOffset = temp2 + modOffset; + complex_t y1, y2; + y1 = y[tensorOffset]; + y2 = y[tensorOffset+rts]; + y[tensorOffset] = CMPLX_ADD(y1, CMPLX_MUL(ru1,y2)); + y[tensorOffset+rts] = CMPLX_ADD(y1, CMPLX_MUL(ru2,y2)); + } + } + } + else if(p == 5) + { + hDim_t temp1 = rts*4; + complex_t ru1 = ru[rustride]; + complex_t ru2 = ru[rustride<<1]; + complex_t ru3 = ru[rustride*3]; + complex_t ru4 = ru[rustride<<2]; + + for(blockOffset = 0; blockOffset < lts; blockOffset++) + { + hDim_t temp2 = blockOffset*temp1; + for(modOffset = 0; modOffset < rts; modOffset++) + { + tensorOffset = temp2 + modOffset; + complex_t y1, y2, y3, y4; + y1 = y[tensorOffset]; + y2 = y[tensorOffset+rts]; + y3 = y[tensorOffset+(rts<<1)]; + y4 = y[tensorOffset+3*rts]; + y[tensorOffset] = CMPLX_ADD4(y1, CMPLX_MUL(ru1,y2), CMPLX_MUL(ru2,y3), CMPLX_MUL(ru3,y4)); + y[tensorOffset+rts] = CMPLX_ADD4(y1, CMPLX_MUL(ru2,y2), CMPLX_MUL(ru4,y3), CMPLX_MUL(ru1,y4)); + y[tensorOffset+(rts<<1)] = CMPLX_ADD4(y1, CMPLX_MUL(ru3,y2), CMPLX_MUL(ru1,y3), CMPLX_MUL(ru4,y4)); + y[tensorOffset+rts*3] = CMPLX_ADD4(y1, CMPLX_MUL(ru4,y2), CMPLX_MUL(ru3,y3), CMPLX_MUL(ru2,y4)); + } + } + } + else if(p == 7) + { + hDim_t temp1 = rts*6; + complex_t ru1 = ru[rustride]; + complex_t ru2 = ru[rustride<<1]; + complex_t ru3 = ru[rustride*3]; + complex_t ru4 = ru[rustride<<2]; + complex_t ru5 = ru[rustride*5]; + complex_t ru6 = ru[rustride*6]; + + for(blockOffset = 0; blockOffset < lts; blockOffset++) + { + hDim_t temp2 = blockOffset*temp1; + for(modOffset = 0; modOffset < rts; modOffset++) + { + tensorOffset = temp2 + modOffset; + complex_t y1, y2, y3, y4, y5, y6; + y1 = y[tensorOffset]; + y2 = y[tensorOffset+rts]; + y3 = y[tensorOffset+(rts<<1)]; + y4 = y[tensorOffset+3*rts]; + y5 = y[tensorOffset+(rts<<2)]; + y6 = y[tensorOffset+rts*5]; + y[tensorOffset] = CMPLX_ADD6(y1, CMPLX_MUL(ru1,y2), CMPLX_MUL(ru2,y3), CMPLX_MUL(ru3,y4), CMPLX_MUL(ru4,y5), CMPLX_MUL(ru5,y6)); + y[tensorOffset+rts] = CMPLX_ADD6(y1, CMPLX_MUL(ru2,y2), CMPLX_MUL(ru4,y3), CMPLX_MUL(ru6,y4), CMPLX_MUL(ru1,y5), CMPLX_MUL(ru3,y6)); + y[tensorOffset+(rts<<1)] = CMPLX_ADD6(y1, CMPLX_MUL(ru3,y2), CMPLX_MUL(ru6,y3), CMPLX_MUL(ru2,y4), CMPLX_MUL(ru5,y5), CMPLX_MUL(ru1,y6)); + y[tensorOffset+rts*3] = CMPLX_ADD6(y1, CMPLX_MUL(ru4,y2), CMPLX_MUL(ru1,y3), CMPLX_MUL(ru5,y4), CMPLX_MUL(ru2,y5), CMPLX_MUL(ru6,y6)); + y[tensorOffset+(rts<<2)] = CMPLX_ADD6(y1, CMPLX_MUL(ru5,y2), CMPLX_MUL(ru3,y3), CMPLX_MUL(ru1,y4), CMPLX_MUL(ru6,y5), CMPLX_MUL(ru4,y6)); + y[tensorOffset+rts*5] = CMPLX_ADD6(y1, CMPLX_MUL(ru6,y2), CMPLX_MUL(ru5,y3), CMPLX_MUL(ru4,y4), CMPLX_MUL(ru3,y5), CMPLX_MUL(ru2,y6)); + } + } + } + else + { + complex_t* tempSpace = (complex_t*)malloc((p-1)*sizeof(complex_t)); + hDim_t temp1 = rts*(p-1); + for(blockOffset = 0; blockOffset < lts; blockOffset++) + { + hDim_t temp2 = blockOffset*temp1; + for(modOffset = 0; modOffset < rts; modOffset++) + { + tensorOffset = temp2 + modOffset; + hDim_t row, col; + + for(row = 1; row < p; row++) + { + complex_t acc = ((complex_t){0,0}); + for(col = 0; col < p-1; col++) + { + CMPLX_IADD(acc, CMPLX_MUL(y[tensorOffset+col*rts], ru[((col*row) % p)*rustride])); + } + tempSpace[row-1] = acc; + } + + for(row = 0; row < p-1; row++) + { + y[tensorOffset+rts*row] = tempSpace[row]; + } + } + } + free(tempSpace); + } +} + +//takes inverse rus +void crtpinvC (complex_t* y, hDim_t lts, hDim_t rts, hDim_t p, hDim_t rustride, complex_t* ruinv) +{ + if(p ==2) + { + // need this case so that we can divide overall by mhat^(-1) + return; + } + else + { + hDim_t tensorOffset,i; + complex_t* tempSpace = (complex_t*)malloc(p*sizeof(complex_t)); + hDim_t temp1 = rts*(p-1); + for(hDim_t blockOffset = 0; blockOffset < lts; blockOffset++) + { + hDim_t temp2 = blockOffset*temp1; + for(hDim_t modOffset = 0; modOffset < rts; modOffset++) + { + tensorOffset = temp2 + modOffset; + + for(i = 0; i < p-1; i++) + { + complex_t sum = ((complex_t){0,0}); + int j; + for(j = 0; j < p-1; j++) + { + int ruIdx = (((j+1)*i) % p)*rustride; + CMPLX_IADD(sum, CMPLX_MUL(y[tensorOffset+j*rts],ruinv[ruIdx])); + } + tempSpace[i] = sum; + } + + complex_t shift = ((complex_t){0,0}); + for(i = 0; i < p-1; i++) + { + // we were given the inverse rus, so we need to negate the indices + int ruIdx = p-(i+1); + CMPLX_IADD(shift, CMPLX_MUL(y[tensorOffset+i*rts], ruinv[rustride*ruIdx])); + } + + for(i = 0; i < p-1; i++) + { + y[tensorOffset+i*rts] = CMPLX_SUB(tempSpace[i], shift); + } + } + } + } +} + +void ppDFTC (complex_t* y, hDim_t lts, hDim_t rts, PrimeExponent pe, hDim_t rustride, complex_t* ru) +{ + hDim_t p = pe.prime; + hShort_t e = pe.exponent; + + if(e == 0) + { + return; + } + + hDim_t primeRuStride = rustride*ipow(p,e-1); + complex_t* temp = 0; + if(p >= DFTP_GENERIC_SIZE) + { + temp = (complex_t*)malloc(p*sizeof(complex_t)); + } + hShort_t i; + + hDim_t ltsScale = ipow(p,e-1); + hDim_t rtsScale = 1; + hDim_t twidRuStride = rustride; + for(i = 0; i < e; i++) + { + hDim_t rtsDim = rts*rtsScale; + dftpC (y, lts*ltsScale, rtsDim, p, primeRuStride, ru, temp); + dftptwidC (y, lts, rtsDim, pe, ltsScale*p, twidRuStride, ru); + + ltsScale /= p; + rtsScale *= p; + twidRuStride *= p; + pe.exponent -= 1; + } + + if(p >= DFTP_GENERIC_SIZE) + { + free(temp); + } +} + +void ppDFTInvC (complex_t* y, hDim_t lts, hDim_t rts, PrimeExponent pe, hDim_t rustride, complex_t* ru) +{ + + hDim_t p = pe.prime; + hShort_t e = pe.exponent; + + if(e == 0) + { + return; + } + hDim_t primeRuStride = rustride*ipow(p,e-1); + complex_t* temp = 0; + if(p >= DFTP_GENERIC_SIZE) + { + temp = (complex_t*)malloc(p*sizeof(complex_t)); + } + hShort_t i; + + hDim_t ltsScale = 1; + hDim_t rtsScale = ipow(p,e-1); + hDim_t twidRuStride = primeRuStride; + pe.exponent = 1; + for(i = 0; i < e; i++) + { + hDim_t rtsDim = rts*rtsScale; + hDim_t ltsScaleP = ltsScale*p; + dftptwidC (y, lts, rtsDim, pe, ltsScaleP, twidRuStride, ru); + dftpC (y, lts*ltsScale, rtsDim, p, primeRuStride, ru, temp); + + ltsScale = ltsScaleP; + rtsScale /= p; + twidRuStride /= p; + pe.exponent += 1; + } + + if(p >= DFTP_GENERIC_SIZE) + { + free(temp); + } +} + +void ppcrtC (void* y, hDim_t lts, hDim_t rts, PrimeExponent pe, void* ru, hInt_t q) +{ + hDim_t p = pe.prime; + hDim_t e = pe.exponent; +#ifdef DEBUG_MODE + ASSERT(e != 0); +#endif + hDim_t mprime = ipow(p,e-1); + +#ifdef DEBUG_MODE + printf("rus for p=%" PRId32 ", e=%" PRId16 "\t[", pe.prime, pe.exponent); + hDim_t i; + for(i = 0; i < ipow(p,e); i++) { + printf("(%f,%f),", ((complex_t*)ru)[i].real, ((complex_t*)ru)[i].imag); + } + printf("]\n"); +#endif + + crtpC ((complex_t*)y, lts*mprime, rts, p, mprime, (complex_t*)ru); + crtTwiddleC ((complex_t*)y, lts, rts, pe, (complex_t*)ru); + pe.exponent -= 1; + ppDFTC ((complex_t*)y, lts, rts*(p-1), pe, p, (complex_t*)ru); +} + +void ppcrtinvC (void* y, hDim_t lts, hDim_t rts, PrimeExponent pe, void* ru, hInt_t q) +{ + hDim_t p = pe.prime; + hDim_t e = pe.exponent; +#ifdef DEBUG_MODE + ASSERT(e != 0); +#endif + hDim_t mprime = ipow(p,e-1); + + pe.exponent -= 1; + ppDFTInvC ((complex_t*)y, lts, rts*(p-1), pe, p, (complex_t*)ru); + pe.exponent += 1; + crtTwiddleC ((complex_t*)y, lts, rts, pe, (complex_t*)ru); + crtpinvC ((complex_t*)y, lts*mprime, rts, p, mprime, (complex_t*)ru); +} + +void tensorCRTC (complex_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, complex_t** ru) +{ +#ifdef STATS + struct timespec s1,t1; + crtCCtr++; + clock_gettime(CLOCK_REALTIME, &s1); +#endif +#ifdef DEBUG_MODE + printf("\n\nEntered tensorCRTC\ttotm=%" PRId32 "\tnumFacts=%" PRId16 "\n[", totm, sizeOfPE); + hDim_t j; + for(j = 0; j < totm; j++) { + printf("(%f,%f),", y[j].real, y[j].imag); + } + printf("]\n["); + for(j = 0; j < sizeOfPE; j++) { + printf("(%" PRId32 ",%" PRId16 "),", peArr[j].prime, peArr[j].exponent); + } + printf("]\n"); +#endif + void** rus = (void**)malloc(sizeOfPE*sizeof(void*)); + hShort_t i; + for(i = 0; i < sizeOfPE; i++) + { + rus[i] = (void*) (ru[i]); + } + tensorFuserCRT (y, ppcrtC, totm, peArr, sizeOfPE, rus, 0); + free(rus); +#ifdef STATS + clock_gettime(CLOCK_REALTIME, &t1); + crtCTime = tsAdd(crtCTime, tsSubtract(t1,s1)); +#endif +} + +//takes inverse rus +void tensorCRTInvC (complex_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, complex_t** ruinv, double mhatInv) +{ +#ifdef STATS + struct timespec s1,t1; + crtInvCCtr++; + clock_gettime(CLOCK_REALTIME, &s1); +#endif + hDim_t i; + + void** rus = (void**)malloc(sizeOfPE*sizeof(void*)); + for(i = 0; i < sizeOfPE; i++) + { + rus[i] = (void*) (ruinv[i]); + } + + tensorFuserCRT (y, ppcrtinvC, totm, peArr, sizeOfPE, rus, 0); + complex_t minvcmplx = ((complex_t){mhatInv,0}); + + for (hDim_t j = 0; j < totm; j++) + { + CMPLX_IMUL(y[j], minvcmplx); + } + + free(rus); +#ifdef STATS + clock_gettime(CLOCK_REALTIME, &t1); + crtInvCTime = tsAdd(crtInvCTime, tsSubtract(t1,s1)); +#endif +} diff --git a/src/Crypto/Lol/Cyclotomic/Tensor/CTensor/g.c b/src/Crypto/Lol/Cyclotomic/Tensor/CTensor/g.c new file mode 100644 --- /dev/null +++ b/src/Crypto/Lol/Cyclotomic/Tensor/CTensor/g.c @@ -0,0 +1,685 @@ +#include "tensorTypes.h" + + +void gPowR (hInt_t* y, hDim_t lts, hDim_t rts, hDim_t p) +{ + hDim_t tmp1 = rts*(p-1); + hDim_t tmp2 = tmp1 - rts; + hDim_t blockOffset, modOffset; + hDim_t i; + for (blockOffset = 0; blockOffset < lts; ++blockOffset) + { + hDim_t tmp3 = blockOffset * tmp1; + for (modOffset = 0; modOffset < rts; ++modOffset) + { + hDim_t tensorOffset = tmp3 + modOffset; + hInt_t last = y[tensorOffset + tmp2]; + for (i = p-2; i != 0; --i) + { + hDim_t idx = tensorOffset + i * rts; + y[idx] += last - y[idx-rts]; + } + y[tensorOffset] += last; + } + } +} + +void gPowRq (hInt_t* y, hDim_t lts, hDim_t rts, hDim_t p, hInt_t q) +{ + hDim_t tmp1 = rts*(p-1); + hDim_t tmp2 = tmp1 - rts; + hDim_t blockOffset, modOffset; + hDim_t i; + for (blockOffset = 0; blockOffset < lts; ++blockOffset) + { + hDim_t tmp3 = blockOffset * tmp1; + for (modOffset = 0; modOffset < rts; ++modOffset) + { + hDim_t tensorOffset = tmp3 + modOffset; + hInt_t last = y[tensorOffset + tmp2]; + for (i = p-2; i != 0; --i) + { + hDim_t idx = tensorOffset + i * rts; + y[idx] = (y[idx] + last - y[idx-rts]) % q; + } + y[tensorOffset] = (y[tensorOffset] + last) % q; + } + } +} + + +void ppGPowR (void* y, PrimeExponent pe, hDim_t lts, hDim_t rts, hInt_t q) +{ +#ifdef DEBUG_MODE + ASSERT (q==0); +#endif + hDim_t p = pe.prime; + hShort_t e = pe.exponent; + + if (p != 2) + { + gPowR ((hInt_t*)y, lts*ipow(p,e-1), rts, p); + } +} + + +void ppGPowRq (void* y, PrimeExponent pe, hDim_t lts, hDim_t rts, hInt_t q) +{ + hDim_t p = pe.prime; + hShort_t e = pe.exponent; + if (p != 2) + { + gPowRq ((hInt_t*)y, lts*ipow(p,e-1), rts, p, q); + } +} + + + +void gDecR (hInt_t* y, hDim_t lts, hDim_t rts, hDim_t p) +{ + hDim_t tmp1 = rts*(p-1); + hDim_t blockOffset; + hDim_t modOffset; + hDim_t i; + + for (blockOffset = 0; blockOffset < lts; ++blockOffset) + { + hDim_t tmp2 = blockOffset * tmp1; + for (modOffset = 0; modOffset < rts; ++modOffset) + { + hDim_t tensorOffset = tmp2 + modOffset; + hInt_t acc = y[tensorOffset]; + for (i = p-2; i != 0; --i) + { + hDim_t idx = tensorOffset + i * rts; + acc += y[idx]; + y[idx] -= y[idx-rts]; + } + y[tensorOffset] += acc; + } + } +} + +void gDecRq (hInt_t* y, hDim_t lts, hDim_t rts, hDim_t p, hInt_t q) +{ + hDim_t tmp1 = rts*(p-1); + hDim_t blockOffset; + hDim_t modOffset; + hDim_t i; + + for (blockOffset = 0; blockOffset < lts; ++blockOffset) + { + hDim_t tmp2 = blockOffset * tmp1; + for (modOffset = 0; modOffset < rts; ++modOffset) + { + hDim_t tensorOffset = tmp2 + modOffset; + hInt_t acc = y[tensorOffset]; + for (i = p-2; i != 0; --i) + { + hDim_t idx = tensorOffset + i * rts; + // acc is at most p*q << 64 bits, so no need to mod + acc = acc + y[idx]; + y[idx] = (y[idx] - y[idx-rts]) % q; + } + y[tensorOffset] = (y[tensorOffset] + acc) % q; + } + } +} + +void ppGDecR (void* y, PrimeExponent pe, hDim_t lts, hDim_t rts, hInt_t q) +{ +#ifdef DEBUG_MODE + ASSERT (q==0); +#endif + hDim_t p = pe.prime; + hShort_t e = pe.exponent; + if (p != 2) + { + gDecR ((hInt_t*)y, lts*ipow(p,e-1), rts, p); + } +} + +void ppGDecRq (void* y, PrimeExponent pe, hDim_t lts, hDim_t rts, hInt_t q) +{ + hDim_t p = pe.prime; + hShort_t e = pe.exponent; + if (p != 2) + { + gDecRq ((hInt_t*)y, lts*ipow(p,e-1), rts, p, q); + } +} + + +void gInvPowR (hInt_t* y, hDim_t lts, hDim_t rts, hDim_t p) +{ + hDim_t tmp1 = rts * (p-1); + hDim_t blockOffset, modOffset; + hDim_t i; + + for (blockOffset = 0; blockOffset < lts; ++blockOffset) + { + hDim_t tmp2 = blockOffset * tmp1; + for (modOffset = 0; modOffset < rts; ++modOffset) + { + hDim_t tensorOffset = tmp2 + modOffset; + hInt_t lelts = 0; + for (i = 0; i < p-1; ++i) + { + lelts += y[tensorOffset + i*rts]; + } + hInt_t relts = 0; + for (i = p-2; i >= 0; --i) + { + hDim_t idx = tensorOffset + i*rts; + hInt_t z = y[idx]; + y[idx] = (p-1-i) * lelts - (i+1)*relts; + lelts -= z; + relts += z; + } + } + } +} + +void gInvPowRq (hInt_t* y, hDim_t lts, hDim_t rts, hDim_t p, hInt_t q) +{ + hDim_t tmp1 = rts * (p-1); + hDim_t blockOffset, modOffset; + hDim_t i; + + for (blockOffset = 0; blockOffset < lts; ++blockOffset) + { + hDim_t tmp2 = blockOffset * tmp1; + for (modOffset = 0; modOffset < rts; ++modOffset) + { + hDim_t tensorOffset = tmp2 + modOffset; + hInt_t lelts = 0; + //lelts is at most p*q, so we can mod once at the end + for (i = 0; i < p-1; ++i) + { + lelts = lelts + y[tensorOffset + i*rts]; + } + lelts = lelts % q; + //in the next loop, lelts <= p*q and relts <= p*q + //products are <= p*p*q, and diff is <= 2*p*p*q + //so we assume 2*p^2 << 31 bits + hInt_t relts = 0; + for (i = p-2; i >= 0; --i) + { + hDim_t idx = tensorOffset + i*rts; + hInt_t z = y[idx]; + y[idx] = (((p-1-i) * lelts) - ((i+1)*relts)) % q; + lelts -= z; + relts += z; + } + } + } +} + + +void ppGInvPowR (void* y, PrimeExponent pe, hDim_t lts, hDim_t rts, hInt_t q) +{ +#ifdef DEBUG_MODE + ASSERT (q==0); +#endif + hDim_t p = pe.prime; + hShort_t e = pe.exponent; + if (p != 2) + { + gInvPowR ((hInt_t*)y, lts*ipow(p,e-1), rts, p); + } +} + +void ppGInvPowRq (void* y, PrimeExponent pe, hDim_t lts, hDim_t rts, hInt_t q) +{ + hDim_t p = pe.prime; + hShort_t e = pe.exponent; + if (p != 2) + { + gInvPowRq ((hInt_t*)y, lts*ipow(p,e-1), rts, p, q); + } +} + +//do not call for p=2! +void gCRTRq (hInt_t* y, hDim_t lts, hDim_t rts, hDim_t p, hInt_t* gcoeffs, hInt_t q) +{ + hDim_t gindex; + hDim_t blockOffset, modOffset, idx; + hDim_t temp1 = rts*(p-1); + + for(gindex = 0; gindex < p-1; gindex++) + { + hInt_t coeff = gcoeffs[gindex]; + hDim_t temp3 = gindex*rts; + for(blockOffset = 0; blockOffset < lts; blockOffset++) + { + hDim_t temp2 = blockOffset*temp1 + temp3; + for(modOffset = 0; modOffset < rts; modOffset++) + { + idx = temp2 + modOffset; + y[idx] = (y[idx]*coeff)%q; + } + } + } +} + +//do not call for p=2! +void gCRTC (complex_t* y, hDim_t lts, hDim_t rts, hDim_t p, complex_t* gcoeffs) +{ + hDim_t gindex; + hDim_t blockOffset, modOffset, idx; + hDim_t temp1 = rts*(p-1); + + for(gindex = 0; gindex < p-1; gindex++) + { + complex_t coeff = gcoeffs[gindex]; + hDim_t temp3 = gindex*rts; + for(blockOffset = 0; blockOffset < lts; blockOffset++) + { + hDim_t temp2 = blockOffset*temp1 + temp3; + for(modOffset = 0; modOffset < rts; modOffset++) + { + idx = temp2 + modOffset; + CMPLX_IMUL(y[idx],coeff); + } + } + } +} + +void ppGCRTRq (void* y, hDim_t lts, hDim_t rts, PrimeExponent pe, void* gcoeffs, hInt_t q) +{ + hDim_t p = pe.prime; + hShort_t e = pe.exponent; + +#ifdef DEBUG_MODE + printf("gcoeffs for p=%" PRId32 ", e=%" PRId16 "\t[", pe.prime, pe.exponent); + int i; + for(i = 0; i < ((p-1)*ipow(p,e-1)); i++) { + printf("%" PRId64 ",", ((hInt_t*)gcoeffs)[i]); + } + printf("]\n"); +#endif + + if (p != 2) + { + gCRTRq ((hInt_t*)y, lts*ipow(p,e-1), rts, p, (hInt_t*)gcoeffs, q); + } +} + +void ppGCRTC (void* y, hDim_t lts, hDim_t rts, PrimeExponent pe, void* gcoeffs, hInt_t q) +{ + hDim_t p = pe.prime; + hShort_t e = pe.exponent; + +#ifdef DEBUG_MODE + printf("gcoeffs for p=%" PRId32 ", e=%" PRId16 "\t[", pe.prime, pe.exponent); + int i; + for(i = 0; i < ((p-1)*ipow(p,e-1)); i++) { + printf("(%f,%f),", ((complex_t*)gcoeffs)[i].real, ((complex_t*)gcoeffs)[i].imag); + } + printf("]\n"); +#endif + + if (p != 2) + { + gCRTC ((complex_t*)y, lts*ipow(p,e-1), rts, p, (complex_t*)gcoeffs); + } +} + +void gInvDecR (hInt_t* y, hDim_t lts, hDim_t rts, hDim_t p) +{ + hDim_t blockOffset; + hDim_t modOffset; + hDim_t i; + hDim_t tmp1 = rts*(p-1); + + for (blockOffset = 0; blockOffset < lts; ++blockOffset) + { + hDim_t tmp2 = blockOffset*tmp1; + for (modOffset = 0; modOffset < rts; ++modOffset) + { + hDim_t tensorOffset = tmp2 + modOffset; + hInt_t lastOut = 0; + for (i=1; i < p; ++i) + { + lastOut += i * y[tensorOffset + (i-1)*rts]; + } + hInt_t acc = lastOut / p; + ASSERT (acc * p == lastOut); // this line asserts that lastOut % p == 0, without calling % operator + for (i = p-2; i > 0; --i) + { + hDim_t idx = tensorOffset + i*rts; + hInt_t tmp = acc; + acc -= y[idx]; // we already divided acc by p, do not multiply y[idx] by p + y[idx] = tmp; + } + y[tensorOffset] = acc; + } + } +} + +void gInvDecRq (hInt_t* y, hDim_t lts, hDim_t rts, hDim_t p, hInt_t q) +{ + hDim_t blockOffset; + hDim_t modOffset; + hDim_t i; + hDim_t tmp1 = rts*(p-1); + hInt_t reciprocalOfP = reciprocal (q,p); + + for (blockOffset = 0; blockOffset < lts; ++blockOffset) + { + hDim_t tmp2 = blockOffset*tmp1; + for (modOffset = 0; modOffset < rts; ++modOffset) + { + hDim_t tensorOffset = tmp2 + modOffset; + hInt_t lastOut = 0; + for (i=1; i < p; ++i) + { + lastOut += (i * y[tensorOffset + (i-1)*rts]); + } + //in the previous loop, |lastOut| <= p*p*q + lastOut = lastOut % q; + hInt_t acc = (lastOut * reciprocalOfP) % q; + // |acc| <= p*q + for (i = p-2; i > 0; --i) + { + hDim_t idx = tensorOffset + i*rts; + hInt_t tmp = acc; + acc = acc - y[idx]; + y[idx] = tmp % q; + } + y[tensorOffset] = acc % q; + } + } +} + +void ppGInvDecR (void* y, PrimeExponent pe, hDim_t lts, hDim_t rts, hInt_t q) +{ +#ifdef DEBUG_MODE + ASSERT (q==0); +#endif + hDim_t p = pe.prime; + hShort_t e = pe.exponent; + if (p != 2) + { + gInvDecR ((hInt_t*)y, lts*ipow(p,e-1), rts, p); + } +} + +void ppGInvDecRq (void* y, PrimeExponent pe, hDim_t lts, hDim_t rts, hInt_t q) +{ + hDim_t p = pe.prime; + hShort_t e = pe.exponent; + if (p != 2) + { + gInvDecRq ((hInt_t*)y, lts*ipow(p,e-1), rts, p, q); + } +} + +#ifdef STATS +int gprCtr = 0; +int gprqCtr = 0; +int gdrCtr = 0; +int gdrqCtr = 0; +int giprCtr = 0; +int giprqCtr = 0; +int gidrCtr = 0; +int gidrqCtr = 0; +int gcrqCtr = 0; +int gccCtr = 0; +int gicrqCtr = 0; +int giccCtr = 0; + +struct timespec gprTime = {0,0}; +struct timespec gprqTime = {0,0}; +struct timespec gdrTime = {0,0}; +struct timespec gdrqTime = {0,0}; +struct timespec giprTime = {0,0}; +struct timespec giprqTime = {0,0}; +struct timespec gidrTime = {0,0}; +struct timespec gidrqTime = {0,0}; +struct timespec gcrqTime = {0,0}; +struct timespec gccTime = {0,0}; +#endif + +void tensorGPowR (hInt_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE) +{ +#ifdef STATS + gprCtr++; + struct timespec s1,t1; + clock_gettime(CLOCK_REALTIME, &s1); +#endif + tensorFuser (y, ppGPowR, totm, peArr, sizeOfPE, 0); + +#ifdef STATS + clock_gettime(CLOCK_REALTIME, &t1); + gprTime = tsAdd(gprTime, tsSubtract(t1,s1)); +#endif +} + +void tensorGPowRq (hInt_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, hInt_t q) +{ +#ifdef STATS + gprqCtr++; + struct timespec s1,t1; + clock_gettime(CLOCK_REALTIME, &s1); +#endif + tensorFuser (y, ppGPowRq, totm, peArr, sizeOfPE, q); + + hDim_t j; + for(j = 0; j < totm; j++) + { + if(y[j]<0) + { + y[j]+=q; + } + } + +#ifdef STATS + clock_gettime(CLOCK_REALTIME, &t1); + gprqTime = tsAdd(gprqTime, tsSubtract(t1,s1)); +#endif +} + +void tensorGDecR (hInt_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE) +{ +#ifdef STATS + gdrCtr++; + struct timespec s1,t1; + clock_gettime(CLOCK_REALTIME, &s1); +#endif + tensorFuser (y, ppGDecR, totm, peArr, sizeOfPE, 0); +#ifdef STATS + clock_gettime(CLOCK_REALTIME, &t1); + gdrTime = tsAdd(gdrTime, tsSubtract(t1,s1)); +#endif +} + +void tensorGDecRq (hInt_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, hInt_t q) +{ +#ifdef STATS + gdrqCtr++; + struct timespec s1,t1; + clock_gettime(CLOCK_REALTIME, &s1); +#endif + tensorFuser (y, ppGDecRq, totm, peArr, sizeOfPE, q); + + hDim_t j; + for(j = 0; j < totm; j++) + { + if(y[j]<0) + { + y[j]+=q; + } + } +#ifdef STATS + clock_gettime(CLOCK_REALTIME, &t1); + gdrqTime = tsAdd(gdrqTime, tsSubtract(t1,s1)); +#endif +} + +void tensorGInvPowR (hInt_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE) +{ +#ifdef STATS + giprCtr++; + struct timespec s1,t1; + clock_gettime(CLOCK_REALTIME, &s1); +#endif + tensorFuser (y, ppGInvPowR, totm, peArr, sizeOfPE, 0); + +#ifdef STATS + clock_gettime(CLOCK_REALTIME, &t1); + giprTime = tsAdd(giprTime, tsSubtract(t1,s1)); +#endif +} + +void tensorGInvPowRq (hInt_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, hInt_t q) +{ +#ifdef STATS + giprqCtr++; + struct timespec s1,t1; + clock_gettime(CLOCK_REALTIME, &s1); +#endif + tensorFuser (y, ppGInvPowRq, totm, peArr, sizeOfPE, q); + + hDim_t j; + for(j = 0; j < totm; j++) + { + if(y[j]<0) + { + y[j]+=q; + } + } +#ifdef STATS + clock_gettime(CLOCK_REALTIME, &t1); + giprqTime = tsAdd(giprqTime, tsSubtract(t1,s1)); +#endif +} + +void tensorGInvDecR (hInt_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE) +{ +#ifdef STATS + gidrCtr++; + struct timespec s1,t1; + clock_gettime(CLOCK_REALTIME, &s1); +#endif + tensorFuser (y, ppGInvDecR, totm, peArr, sizeOfPE, 0); +#ifdef STATS + clock_gettime(CLOCK_REALTIME, &t1); + gidrTime = tsAdd(gidrTime, tsSubtract(t1,s1)); +#endif +} + +void tensorGInvDecRq (hInt_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, hInt_t q) +{ +#ifdef STATS + gidrqCtr++; + struct timespec s1,t1; + clock_gettime(CLOCK_REALTIME, &s1); +#endif + tensorFuser (y, ppGInvDecRq, totm, peArr, sizeOfPE, q); + + hDim_t j; + for(j = 0; j < totm; j++) + { + if(y[j]<0) + { + y[j]+=q; + } + } + +#ifdef STATS + clock_gettime(CLOCK_REALTIME, &t1); + gidrqTime = tsAdd(gidrqTime, tsSubtract(t1,s1)); +#endif +} + +void tensorGCRTRq (hInt_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, hInt_t** gcoeffs, hInt_t q) +{ +#ifdef STATS + gcrqCtr++; + struct timespec s1,t1; + clock_gettime(CLOCK_REALTIME, &s1); +#endif +#ifdef DEBUG_MODE + printf("\n\nEntered tensorGCRTRq\ttotm=%" PRId32 "\tnumFacts=%" PRId16 "\tq=%" PRId64 "\n[", totm, sizeOfPE, q); + hDim_t j; + for(j = 0; j < totm; j++) { + printf("%" PRId64 ",", y[j]); + } + printf("]\n["); + for(j = 0; j < sizeOfPE; j++) { + printf("(%" PRId32 ",%" PRId16 "),", peArr[j].prime, peArr[j].exponent); + } + printf("]\n"); +#endif + void** vgcoeffs = (void**)malloc(sizeOfPE*sizeof(void*)); + hDim_t i; + for(i = 0; i < sizeOfPE; i++) + { + vgcoeffs[i] = (void*) (gcoeffs[i]); + } + + tensorFuserCRT (y, ppGCRTRq, totm, peArr, sizeOfPE, vgcoeffs, q); + +#ifdef DEBUG_MODE + for(j = 0; j < totm; j++) + { + if(y[j]<0) + { + printf("tensorGCRTRq\n"); + } + } +#endif +#ifdef STATS + clock_gettime(CLOCK_REALTIME, &t1); + gcrqTime = tsAdd(gcrqTime, tsSubtract(t1,s1)); +#endif +} +void tensorGCRTC (complex_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, complex_t** gcoeffs) +{ +#ifdef STATS + gccCtr++; + struct timespec s1,t1; + clock_gettime(CLOCK_REALTIME, &s1); +#endif +#ifdef DEBUG_MODE + printf("\n\nEntered tensorGCRTC\ttotm=%" PRId32 "\tnumFacts=%" PRId16 "\n[", totm, sizeOfPE); + hDim_t j; + for(j = 0; j < totm; j++) { + printf("(%f,%f),", (y[j]).real, (y[j]).imag); + } + printf("]\n["); + for(j = 0; j < sizeOfPE; j++) { + printf("(%" PRId32 ",%" PRId16 "),", peArr[j].prime, peArr[j].exponent); + } + printf("]\n"); +#endif + void** vgcoeffs = (void**)malloc(sizeOfPE*sizeof(void*)); + hDim_t i; + for(i = 0; i < sizeOfPE; i++) + { + vgcoeffs[i] = (void*) (gcoeffs[i]); + } + + tensorFuserCRT (y, ppGCRTC, totm, peArr, sizeOfPE, vgcoeffs, 0); + +#ifdef STATS + clock_gettime(CLOCK_REALTIME, &t1); + gccTime = tsAdd(gccTime, tsSubtract(t1,s1)); +#endif +} +void tensorGInvCRTRq (hInt_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, hInt_t** gcoeffs, hInt_t q) +{ +#ifdef STATS + gicrqCtr++; +#endif + tensorGCRTRq (y, totm, peArr, sizeOfPE, gcoeffs, q); //output is already shifted +} +void tensorGInvCRTC (complex_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, complex_t** gcoeffs) +{ +#ifdef STATS + giccCtr++; +#endif + tensorGCRTC (y, totm, peArr, sizeOfPE, gcoeffs); +} + diff --git a/src/Crypto/Lol/Cyclotomic/Tensor/CTensor/generalfuncs.c b/src/Crypto/Lol/Cyclotomic/Tensor/CTensor/generalfuncs.c new file mode 100644 --- /dev/null +++ b/src/Crypto/Lol/Cyclotomic/Tensor/CTensor/generalfuncs.c @@ -0,0 +1,293 @@ +#include "tensorTypes.h" + +hDim_t ipow(hDim_t base, hShort_t exp) +{ +#ifdef DEBUG_MODE + ASSERT(exp >= 0); +#endif + hDim_t result = 1; + while (exp) + { + if (exp & 1) + { + result *= base; + } + exp >>= 1; + base *= base; + } + return result; +} + +complex_t cmplxpow(complex_t base, hShort_t exp) +{ + complex_t result = (complex_t){1,0}; + while (exp) + { + if (exp & 1) + { + CMPLX_IMUL(result,base); + } + exp >>= 1; + CMPLX_IMUL(base,base); + } + return result; +} + +hInt_t qpow(hInt_t base, hShort_t exp, hInt_t q) +{ + hInt_t result = 1; + while (exp) + { + if (exp & 1) + { + result = (result*base)%q; + } + exp >>= 1; + base = (base*base)%q; + } + return result; +} + +// a is the field size. we are looking for reciprocal of b +hInt_t reciprocal (hInt_t a, hInt_t b) +{ + hInt_t fieldSize = a; + + hInt_t y = 1; + hInt_t lasty = 0; + while (b != 0) + { + hInt_t quotient = a / b; + hInt_t tmp = a % b; + a = b; + b = tmp; + tmp = y; + y = lasty - quotient*y; + lasty = tmp; + } + ASSERT (a==1); // if this one fails, then b is not invertible mod a + + // this actually returns EITHER the reciprocal OR reciprocal + fieldSize + hInt_t res = lasty + fieldSize; +#ifdef DEBUG_MODE + ASSERT (0); + ASSERT ((res >= 0) && (res < fieldSize + fieldSize)); + hInt_t test = res * b % fieldSize; + ASSERT (test == 1); +#endif + return res; + +} + +//for square transforms +void tensorFuser (void* y, funcPtr f, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, hInt_t q) +{ + hDim_t lts = totm; + hDim_t rts = 1; + hShort_t i; + + for (i = 0; i < sizeOfPE; ++i) + { + PrimeExponent pe = peArr[i]; + hDim_t ipow_pe = ipow(pe.prime, (pe.exponent-1)); + hDim_t dim = (pe.prime-1) * ipow_pe; // the totient of pe + lts /= dim; + (*f) (y, pe, lts, rts, q); + rts *= dim; + } +} + +void tensorFuserCRT (void* y, crtFuncPtr f, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, void** ru, hInt_t q) +{ + hDim_t lts = totm; + hDim_t rts = 1; + hShort_t i; + + for (i = 0; i < sizeOfPE; ++i) + { + PrimeExponent pe = peArr[i]; + hDim_t ipow_pe = ipow(pe.prime, (pe.exponent-1)); + hDim_t dim = (pe.prime-1) * ipow_pe; // the totient of pe + lts /= dim; + (*f) (y, lts, rts, pe, ru[i], q); + rts *= dim; + } +} + +struct timespec tsSubtract (struct timespec time1, struct timespec time2) +{ /* Local variables. */ + struct timespec result ; + +/* Subtract the second time from the first. */ + + if ((time1.tv_sec < time2.tv_sec) || + ((time1.tv_sec == time2.tv_sec) && + (time1.tv_nsec <= time2.tv_nsec))) { /* TIME1 <= TIME2? */ + result.tv_sec = result.tv_nsec = 0 ; + } else { /* TIME1 > TIME2 */ + result.tv_sec = time1.tv_sec - time2.tv_sec ; + if (time1.tv_nsec < time2.tv_nsec) { + result.tv_nsec = time1.tv_nsec + 1000000000L - time2.tv_nsec ; + result.tv_sec-- ; /* Borrow a second. */ + } else { + result.tv_nsec = time1.tv_nsec - time2.tv_nsec ; + } + } + + return (result) ; +} + +struct timespec tsAdd (struct timespec time1, struct timespec time2) +{ /* Local variables. */ + struct timespec result ; + +/* Add the two times together. */ + + result.tv_sec = time1.tv_sec + time2.tv_sec ; + result.tv_nsec = time1.tv_nsec + time2.tv_nsec ; + if (result.tv_nsec >= 1000000000L) { /* Carry? */ + result.tv_sec++ ; result.tv_nsec = result.tv_nsec - 1000000000L ; + } + + return (result) ; +} + +const char *tsShow (struct timespec binaryTime, bool inLocal, const char *format) +{ /* Local variables. */ + struct tm calendarTime ; +#define MAX_TIMES 4 + static char asciiTime[MAX_TIMES][64] ; + static int current = 0 ; + +/* Convert the TIMESPEC to calendar time: year, month, day, etc. */ + +#ifdef VXWORKS + if (inLocal) + localtime_r ((time_t *) &binaryTime.tv_sec, &calendarTime) ; + else + gmtime_r ((time_t *) &binaryTime.tv_sec, &calendarTime) ; +#else + if (inLocal) + calendarTime = *(localtime ((time_t *) &binaryTime.tv_sec)) ; + else + calendarTime = *(gmtime ((time_t *) &binaryTime.tv_sec)) ; +#endif + +/* Format the time in ASCII. */ + + current = (current + 1) % MAX_TIMES ; + + if (format == NULL) { + strftime (asciiTime[current], 64, "%Y-%j-%H:%M:%S", &calendarTime) ; + sprintf (asciiTime[current] + strlen (asciiTime[current]), + ".%06ld", (binaryTime.tv_nsec % 1000000000L) / 1000L) ; + } else { + strftime (asciiTime[current], 64, format, &calendarTime) ; + sprintf (asciiTime[current] + strlen (asciiTime[current]), + ".%06ld", (binaryTime.tv_nsec % 1000000000L) / 1000L) ; + } + + return (asciiTime[current]); +} + + + +const char* timeformat = "%M:%S"; + +void getStats() { + +#ifdef STATS + struct timespec total; + printf("CRT Stats:\n"); + printf("CRT_Rq times: Real:%s\tMono:%s\tProc:%s\tThread:%s\n", tsShow(crttime1, false, timeformat),tsShow(crttime2, false, timeformat),tsShow(crttime3, false, timeformat),tsShow(crttime4, false, timeformat)); + printf("CTR_Rq: %d\t%s\t%d\t%s\n", crtRqCtr, tsShow(crttime1, false, timeformat), crtInvRqCtr, tsShow(crtInvRqTime, false, timeformat)); + printf("CTR_C: %d\t%s\t%d\t%s\n", crtCCtr, tsShow(crtCTime, false, timeformat), crtInvCCtr, tsShow(crtInvCTime, false, timeformat)); + + printf("\nG Stats:\n"); + printf("GPow_R: %d\t%s\t%d\t%s\n", gprCtr, tsShow(gprTime, false, timeformat), giprCtr, tsShow(giprTime, false, timeformat)); + printf("GPow_Rq: %d\t%s\t%d\t%s\n", gprqCtr, tsShow(gprqTime, false, timeformat), giprqCtr, tsShow(giprqTime, false, timeformat)); + printf("GDec_R: %d\t%s\t%d\t%s\n", gdrCtr, tsShow(gdrTime, false, timeformat), gidrCtr, tsShow(gidrTime, false, timeformat)); + printf("GDec_Rq: %d\t%s\t%d\t%s\n", gdrqCtr, tsShow(gdrqTime, false, timeformat), gidrqCtr, tsShow(gidrqTime, false, timeformat)); + printf("GCRT_Rq: %d\t%d\t%s\n", gcrqCtr, gicrqCtr, tsShow(gcrqTime, false, timeformat)); + printf("GCRT_C: %d\t%d\t%s\n", gccCtr, giccCtr, tsShow(gccTime, false, timeformat)); + + printf("\nL Stats:\n"); + printf("L_R: %d\t%s\t%d\t%s\n", lrCtr, tsShow(lrTime, false, timeformat), lirCtr, tsShow(lirTime, false, timeformat)); + printf("L_Rq: %d\t%s\t%d\t%s\n", lrqCtr, tsShow(lrqTime, false, timeformat), lirqCtr, tsShow(lirqTime, false, timeformat)); + printf("L_D: %d\t%s\t%d\t%s\n", ldCtr, tsShow(ldTime, false, timeformat), lidCtr, tsShow(lidTime, false, timeformat)); + printf("L_C: %d\t%s\t%d\t%s\n", lcCtr, tsShow(lcTime, false, timeformat), licCtr, tsShow(licTime, false, timeformat)); + + printf("\nBasic Stats:\n"); + printf("Mul: %d\t%s\n", mulCtr, tsShow(mulTime, false, timeformat)); + printf("Add: %d\t%s\n", addCtr, tsShow(addTime, false, timeformat)); + + total = tsAdd(crttime1, tsAdd(crtInvRqTime, tsAdd(crtCTime, tsAdd(crtInvCTime, tsAdd(gprTime, tsAdd(giprTime, tsAdd(gdrTime, tsAdd(gidrTime, tsAdd(gprqTime, tsAdd(giprqTime, tsAdd(gdrqTime, tsAdd(gidrqTime, tsAdd(gcrqTime, tsAdd(gccTime, tsAdd(lrTime, tsAdd(lirTime, tsAdd(lrqTime, tsAdd(lirqTime, tsAdd(ldTime, tsAdd(lidTime, tsAdd(lcTime, tsAdd(licTime, tsAdd(mulTime,addTime))))))))))))))))))))))); + + printf("\nTotal C Time: %s\n\n", tsShow(total, false, timeformat)); + + crtRqCtr = 0; + crtInvRqCtr = 0; + crtCCtr = 0; + crtInvCCtr = 0; + + gprCtr = 0; + gprqCtr = 0; + gdrCtr = 0; + gdrqCtr = 0; + giprCtr = 0; + giprqCtr = 0; + gidrCtr = 0; + gidrqCtr = 0; + gcrqCtr = 0; + gccCtr = 0; + gicrqCtr = 0; + giccCtr = 0; + + lrqCtr = 0; + lrCtr = 0; + ldCtr = 0; + lcCtr = 0; + lirqCtr = 0; + lirCtr = 0; + lidCtr = 0; + licCtr = 0; + + mulCtr = 0; + addCtr = 0; + + mulTime = (struct timespec){0,0}; + addTime = (struct timespec){0,0}; + + lrqTime = (struct timespec){0,0}; + lrTime = (struct timespec){0,0}; + ldTime = (struct timespec){0,0}; + lcTime = (struct timespec){0,0}; + lirqTime = (struct timespec){0,0}; + lirTime = (struct timespec){0,0}; + lidTime = (struct timespec){0,0}; + licTime = (struct timespec){0,0}; + + gprTime = (struct timespec){0,0}; + gprqTime = (struct timespec){0,0}; + gdrTime = (struct timespec){0,0}; + gdrqTime = (struct timespec){0,0}; + giprTime = (struct timespec){0,0}; + giprqTime = (struct timespec){0,0}; + gidrTime = (struct timespec){0,0}; + gidrqTime = (struct timespec){0,0}; + gcrqTime = (struct timespec){0,0}; + gccTime = (struct timespec){0,0}; + + crttime1 = (struct timespec){0,0}; + crttime2 = (struct timespec){0,0}; + crttime3 = (struct timespec){0,0}; + crttime4 = (struct timespec){0,0}; + + crtInvRqTime = (struct timespec){0,0}; + crtCTime = (struct timespec){0,0}; + crtInvCTime = (struct timespec){0,0}; +#endif + fflush(stdout); +} + + diff --git a/src/Crypto/Lol/Cyclotomic/Tensor/CTensor/l.c b/src/Crypto/Lol/Cyclotomic/Tensor/CTensor/l.c new file mode 100644 --- /dev/null +++ b/src/Crypto/Lol/Cyclotomic/Tensor/CTensor/l.c @@ -0,0 +1,410 @@ +#include "tensorTypes.h" + +void lpRq (hInt_t* y, hDim_t lts, hDim_t rts, hDim_t p, hInt_t q) { + hDim_t blockOffset; + hDim_t modOffset; + int i; + hDim_t tmp1 = rts*(p-1); + for (blockOffset = 0; blockOffset < lts; ++blockOffset) { + hDim_t tmp2 = blockOffset*tmp1; + for (modOffset = 0; modOffset < rts; ++modOffset) { + hDim_t idx = tmp2 + modOffset + rts; + for (i = 1; i < p-1; ++i) { + hInt_t temp = y[idx-rts] + y[idx]; + if (temp >= q) y[idx]=temp-q; + else y[idx] = temp; + idx += rts; + } + } + } +} + +void lpR (hInt_t* y, hDim_t lts, hDim_t rts, hDim_t p) { + hDim_t blockOffset; + hDim_t modOffset; + int i; + + hDim_t tmp1 = rts*(p-1); + for (blockOffset = 0; blockOffset < lts; ++blockOffset) { + hDim_t tmp2 = blockOffset*tmp1; + for (modOffset = 0; modOffset < rts; ++modOffset) { + hDim_t idx = tmp2 + modOffset + rts; + for (i = 1; i < p-1; ++i) { + y[idx] += y[idx-rts]; + idx += rts; + } + } + } +} + +void lpDouble (double* y, hDim_t lts, hDim_t rts, hDim_t p) { + hDim_t blockOffset; + hDim_t modOffset; + int i; + + hDim_t tmp1 = rts*(p-1); + for (blockOffset = 0; blockOffset < lts; ++blockOffset) { + hDim_t tmp2 = blockOffset*tmp1; + for (modOffset = 0; modOffset < rts; ++modOffset) { + hDim_t idx = tmp2 + modOffset + rts; + for (i = 1; i < p-1; ++i) { + y[idx] += y[idx-rts]; + idx += rts; + } + } + } +} + +void lpC (complex_t* y, hDim_t lts, hDim_t rts, hDim_t p) { + hDim_t blockOffset; + hDim_t modOffset; + int i; + + hDim_t tmp1 = rts*(p-1); + for (blockOffset = 0; blockOffset < lts; ++blockOffset) { + hDim_t tmp2 = blockOffset*tmp1; + for (modOffset = 0; modOffset < rts; ++modOffset) { + hDim_t idx = tmp2 + modOffset + rts; + for (i = 1; i < p-1; ++i) { + CMPLX_IADD (y[idx], y[idx-rts]); + idx += rts; + } + } + } +} + +void lpInvRq (hInt_t* y, hDim_t lts, hDim_t rts, hDim_t p, hInt_t q) { + hDim_t blockOffset; + hDim_t modOffset; + int i; + + hDim_t tmp1 = rts*(p-1); + for (blockOffset = 0; blockOffset < lts; ++blockOffset) { + hDim_t tmp2 = blockOffset*tmp1; + for (modOffset = 0; modOffset < rts; ++ modOffset) { + hDim_t tensorOffset = tmp2 + modOffset; + hDim_t idx = tensorOffset + (p-2) * rts; + for (i = p-2; i != 0; --i) { + hInt_t temp = y[idx] - y[idx-rts] + q; + if (temp >= q) y[idx]=temp-q; + else y[idx] = temp; + idx -= rts; + } + } + } +} + +void lpInvR (hInt_t* y, hDim_t lts, hDim_t rts, hDim_t p) { + hDim_t blockOffset; + hDim_t modOffset; + int i; + + hDim_t tmp1 = rts*(p-1); + for (blockOffset = 0; blockOffset < lts; ++blockOffset) { + hDim_t tmp2 = blockOffset*tmp1; + for (modOffset = 0; modOffset < rts; ++ modOffset) { + hDim_t tensorOffset = tmp2 + modOffset; + hDim_t idx = tensorOffset + (p-2) * rts; + for (i = p-2; i != 0; --i) { + y[idx] -= y[idx-rts] ; + idx -= rts; + } + } + } +} + +void lpInvDouble (double* y, hDim_t lts, hDim_t rts, hDim_t p) { + hDim_t blockOffset; + hDim_t modOffset; + int i; + + hDim_t tmp1 = rts*(p-1); + for (blockOffset = 0; blockOffset < lts; ++blockOffset) { + hDim_t tmp2 = blockOffset*tmp1; + for (modOffset = 0; modOffset < rts; ++ modOffset) { + hDim_t tensorOffset = tmp2 + modOffset; + hDim_t idx = tensorOffset + (p-2) * rts; + for (i = p-2; i != 0; --i) { + y[idx] -= y[idx-rts] ; + idx -= rts; + } + } + } +} + +void lpInvC (complex_t* y, hDim_t lts, hDim_t rts, hDim_t p) { + hDim_t blockOffset; + hDim_t modOffset; + int i; + + hDim_t tmp1 = rts*(p-1); + for (blockOffset = 0; blockOffset < lts; ++blockOffset) { + hDim_t tmp2 = blockOffset*tmp1; + for (modOffset = 0; modOffset < rts; ++ modOffset) { + hDim_t tensorOffset = tmp2 + modOffset; + hDim_t idx = tensorOffset + (p-2) * rts; + for (i = p-2; i != 0; --i) { + CMPLX_ISUB (y[idx], y[idx-rts]); + idx -= rts; + } + } + } +} + +void ppLRq (void* y, PrimeExponent pe, hDim_t lts, hDim_t rts, hInt_t q) { + hDim_t p = pe.prime; + hShort_t e = pe.exponent; + lpRq ((hInt_t*)y, lts*ipow(p,e-1), rts, p, q); +} + +void ppLR (void* y, PrimeExponent pe, hDim_t lts, hDim_t rts, hInt_t q) { +#ifdef DEBUG_MODE + ASSERT (q==0); +#endif + hDim_t p = pe.prime; + hShort_t e = pe.exponent; + lpR ((hInt_t*)y, lts*ipow(p,e-1), rts, p); +} + +void ppLDouble (void* y, PrimeExponent pe, hDim_t lts, hDim_t rts, hInt_t q) { +#ifdef DEBUG_MODE + ASSERT (q==0); +#endif + hDim_t p = pe.prime; + hShort_t e = pe.exponent; + lpDouble ((double*)y, lts*ipow(p,e-1), rts, p); +} + +void ppLC (void* y, PrimeExponent pe, hDim_t lts, hDim_t rts, hInt_t q) { +#ifdef DEBUG_MODE + ASSERT (q==0); +#endif + hDim_t p = pe.prime; + hShort_t e = pe.exponent; + lpC ((complex_t*)y, lts*ipow(p,e-1), rts, p); +} + + +void ppLInvRq (void* y, PrimeExponent pe, hDim_t lts, hDim_t rts, hInt_t q) { + hDim_t p = pe.prime; + hShort_t e = pe.exponent; + lpInvRq ((hInt_t*)y, lts*ipow(p,e-1), rts, p, q); +} + +void ppLInvR (void* y, PrimeExponent pe, hDim_t lts, hDim_t rts, hInt_t q) { +#ifdef DEBUG_MODE + ASSERT (q==0); +#endif + hDim_t p = pe.prime; + hShort_t e = pe.exponent; + lpInvR ((hInt_t*)y, lts*ipow(p,e-1), rts, p); +} + +void ppLInvDouble (void* y, PrimeExponent pe, hDim_t lts, hDim_t rts, hInt_t q) { +#ifdef DEBUG_MODE + ASSERT (q==0); +#endif + hDim_t p = pe.prime; + hShort_t e = pe.exponent; + lpInvDouble ((double*)y, lts*ipow(p,e-1), rts, p); +} + +void ppLInvC (void* y, PrimeExponent pe, hDim_t lts, hDim_t rts, hInt_t q) { +#ifdef DEBUG_MODE + ASSERT (q==0); +#endif + hDim_t p = pe.prime; + hShort_t e = pe.exponent; + lpInvC ((complex_t*)y, lts*ipow(p,e-1), rts, p); +} + +#ifdef STATS +int lrqCtr = 0; +int lrCtr = 0; +int ldCtr = 0; +int lcCtr = 0; +int lirqCtr = 0; +int lirCtr = 0; +int lidCtr = 0; +int licCtr = 0; + +struct timespec lrqTime = {0,0}; +struct timespec lrTime = {0,0}; +struct timespec ldTime = {0,0}; +struct timespec lcTime = {0,0}; +struct timespec lirqTime = {0,0}; +struct timespec lirTime = {0,0}; +struct timespec lidTime = {0,0}; +struct timespec licTime = {0,0}; +#endif + + +void tensorLRq (hInt_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, hInt_t q) { +#ifdef STATS + lrqCtr++; + struct timespec s1,t1; + clock_gettime(CLOCK_REALTIME, &s1); +#endif +#ifdef DEBUG_MODE + hDim_t i; + printf("\n\nEntered tensorLRq\ttotm=%" PRId32 "\tnumFacts=%" PRId16 "\tq=%" PRId64 "\n[", totm, sizeOfPE, q); + /*for(i = 0; i < totm; i++) { + printf("%" PRId64 ",", y[i]); + }*/ + printf("]\n["); + for(i = 0; i < sizeOfPE; i++) { + printf("(%" PRId32 ",%" PRId16 "),", peArr[i].prime, peArr[i].exponent); + } + printf("]\n"); +#endif + tensorFuser (y, ppLRq, totm, peArr, sizeOfPE, q); // don't need to shift here +#ifdef DEBUG_MODE + for(i = 0; i < totm; i++) { + if(y[i]<0) { + printf("tensorLRq\n"); + } + } +#endif +#ifdef STATS + clock_gettime(CLOCK_REALTIME, &t1); + lrqTime = tsAdd(lrqTime, tsSubtract(t1,s1)); +#endif +} + +void tensorLR (hInt_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE) { +#ifdef STATS + lrCtr++; + struct timespec s1,t1; + clock_gettime(CLOCK_REALTIME, &s1); +#endif +#ifdef DEBUG_MODE + printf("\n\nEntered tensorLR\ttotm=%" PRId32 "\tnumFacts=%" PRId16 "\n[", totm, sizeOfPE); + hDim_t i; + for(i = 0; i < totm; i++) { + printf("%" PRId64 ",", y[i]); + } + printf("]\n["); + for(i = 0; i < sizeOfPE; i++) { + printf("(%" PRId32 ",%" PRId16 "),", peArr[i].prime, peArr[i].exponent); + } + printf("]\n"); +#endif + tensorFuser (y, ppLR, totm, peArr, sizeOfPE, 0); +#ifdef STATS + clock_gettime(CLOCK_REALTIME, &t1); + lrTime = tsAdd(lrTime, tsSubtract(t1,s1)); +#endif +} + +void tensorLDouble (double* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE) { +#ifdef STATS + ldCtr++; + struct timespec s1,t1; + clock_gettime(CLOCK_REALTIME, &s1); +#endif +#ifdef DEBUG_MODE + printf("\n\nEntered tensorLDouble\ttotm=%" PRId32 "\tnumFacts=%" PRId16 "\n[", totm, sizeOfPE); + hDim_t i; + for(i = 0; i < totm; i++) { + printf("%f,", y[i]); + } + printf("]\n["); + for(i = 0; i < sizeOfPE; i++) { + printf("(%" PRId32 ",%" PRId16 "),", peArr[i].prime, peArr[i].exponent); + } + printf("]\n"); +#endif + tensorFuser (y, ppLDouble, totm, peArr, sizeOfPE, 0); +#ifdef STATS + clock_gettime(CLOCK_REALTIME, &t1); + ldTime = tsAdd(ldTime, tsSubtract(t1,s1)); +#endif +} + +void tensorLC (complex_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE) { +#ifdef STATS + lcCtr++; + struct timespec s1,t1; + clock_gettime(CLOCK_REALTIME, &s1); +#endif +#ifdef DEBUG_MODE + printf("\n\nEntered tensorLC\ttotm=%" PRId32 "\tnumFacts=%" PRId16 "\n[", totm, sizeOfPE); + hDim_t i; + for(i = 0; i < totm; i++) { + printf("(%f,%f),", y[i].real, y[i].imag); + } + printf("]\n["); + for(i = 0; i < sizeOfPE; i++) { + printf("(%" PRId32 ",%" PRId16 "),", peArr[i].prime, peArr[i].exponent); + } + printf("]\n"); +#endif + tensorFuser (y, ppLC, totm, peArr, sizeOfPE, 0); +#ifdef STATS + clock_gettime(CLOCK_REALTIME, &t1); + lcTime = tsAdd(lcTime, tsSubtract(t1,s1)); +#endif +} + +void tensorLInvRq (hInt_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, hInt_t q) { +#ifdef STATS + lirqCtr++; + struct timespec s1,t1; + clock_gettime(CLOCK_REALTIME, &s1); +#endif + tensorFuser (y, ppLInvRq, totm, peArr, sizeOfPE, q); // don't need to shift here +#ifdef DEBUG_MODE + hDim_t i; + for(i = 0; i < totm; i++) + { + if(y[i]<0) + { + printf("tensorLInvRq\n"); + } + } +#endif +#ifdef STATS + clock_gettime(CLOCK_REALTIME, &t1); + lirqTime = tsAdd(lirqTime, tsSubtract(t1,s1)); +#endif +} + +void tensorLInvR (hInt_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE) { +#ifdef STATS + lirCtr++; + struct timespec s1,t1; + clock_gettime(CLOCK_REALTIME, &s1); +#endif + tensorFuser (y, ppLInvR, totm, peArr, sizeOfPE, 0); +#ifdef STATS + clock_gettime(CLOCK_REALTIME, &t1); + lirTime = tsAdd(lirTime, tsSubtract(t1,s1)); +#endif +} + +void tensorLInvDouble (double* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE) { +#ifdef STATS + lidCtr++; + struct timespec s1,t1; + clock_gettime(CLOCK_REALTIME, &s1); +#endif + tensorFuser (y, ppLInvDouble, totm, peArr, sizeOfPE, 0); +#ifdef STATS + clock_gettime(CLOCK_REALTIME, &t1); + lidTime = tsAdd(lidTime, tsSubtract(t1,s1)); +#endif +} + +void tensorLInvC (complex_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE) { +#ifdef STATS + licCtr++; + struct timespec s1,t1; + clock_gettime(CLOCK_REALTIME, &s1); +#endif + tensorFuser (y, ppLInvC, totm, peArr, sizeOfPE, 0); +#ifdef STATS + clock_gettime(CLOCK_REALTIME, &t1); + licTime = tsAdd(licTime, tsSubtract(t1,s1)); +#endif +} + diff --git a/src/Crypto/Lol/Cyclotomic/Tensor/CTensor/random.c b/src/Crypto/Lol/Cyclotomic/Tensor/CTensor/random.c new file mode 100644 --- /dev/null +++ b/src/Crypto/Lol/Cyclotomic/Tensor/CTensor/random.c @@ -0,0 +1,72 @@ + +#include +#include +#include "tensorTypes.h" + +// this function takes *inverse* RUs, so no negation is needed on the indexing +// I had been negating the ru-idx, but this was causing a *negative* mod, resulting in a hard-to-find bug +void primeD (double *y, hDim_t lts, hDim_t rts, hDim_t p, hDim_t rustride, complex_t* ruinv) +{ + if(p == 2) + { + return; + } + hDim_t blockOffset, modOffset, tensorOffset; + double *tempSpace = (double*)malloc((p-1)*sizeof(double)); + hDim_t temp1 = rts*(p-1); + for(blockOffset = 0; blockOffset < lts; blockOffset++) + { + hDim_t temp2 = blockOffset*temp1; + for(modOffset = 0; modOffset < rts; modOffset++) + { + tensorOffset = temp2 + modOffset; + hDim_t row, col; + + for(row = 0; row < p-1; row++) + { + double acc = 0; + for(col = 1; col <= (p>>1); col++) + { + acc += 2 * ruinv[((row*col) % p)*rustride].real * y[tensorOffset+rts*(col-1)]; + } + for(col = (p>>1)+1; col <= p-1; col++) + { + acc += 2 * ruinv[((row*col) % p)*rustride].imag * y[tensorOffset+rts*(col-1)]; + } + tempSpace[row] = acc/sqrt(2); + } + + for(row = 0; row < p-1; row++) + { + y[tensorOffset+rts*row] = tempSpace[row]; + } + } + } + free(tempSpace); +} + +void ppD (void *y, hDim_t lts, hDim_t rts, PrimeExponent pe, void *ruinv, hInt_t q) +{ + hDim_t p = pe.prime; + hDim_t e = pe.exponent; +#ifdef DEBUG_MODE + ASSERT(e != 0); +#endif + hDim_t mprime = ipow(p,e-1); + primeD (y, lts*mprime, rts, p, mprime, (complex_t*)ruinv); +} + +//the contents of y will be destroyed, but should be initialized in Haskell-land to independent Guassians over the reals +void tensorGaussianDec (double *y, hDim_t totm, PrimeExponent *peArr, hShort_t sizeOfPE, complex_t** ruinv) +{ + void** ruinvs = (void**)malloc(sizeOfPE*sizeof(void*)); + hShort_t i; + for(i = 0; i < sizeOfPE; i++) + { + ruinvs[i] = (void*) (ruinv[i]); + } + + tensorFuserCRT (y, ppD, totm, peArr, sizeOfPE, ruinvs, 0); + + free(ruinvs); +} diff --git a/src/Crypto/Lol/Cyclotomic/Tensor/CTensor/tensorTypes.h b/src/Crypto/Lol/Cyclotomic/Tensor/CTensor/tensorTypes.h new file mode 100644 --- /dev/null +++ b/src/Crypto/Lol/Cyclotomic/Tensor/CTensor/tensorTypes.h @@ -0,0 +1,224 @@ + +#ifndef TENSORTYPES_H_ +#define TENSORTYPES_H_ + + +// remove next line for more efficient code +//#define DEBUG_MODE + + +#include +#include +#include +#include +#include +#include + + +#define ASSERT(EXP) { \ + if (!(EXP)) { \ + fprintf (stderr, "Assertion in file '%s' line %d : " #EXP " is false\n", __FILE__, __LINE__); \ + exit(-1); \ + } \ +} + + +//timers and counters +#ifdef STATS +extern int crtRqCtr; +extern int crtInvRqCtr; +extern int crtCCtr; +extern int crtInvCCtr; + +extern int gprCtr; +extern int gprqCtr; +extern int gdrCtr; +extern int gdrqCtr; +extern int giprCtr; +extern int giprqCtr; +extern int gidrCtr; +extern int gidrqCtr; +extern int gcrqCtr; +extern int gccCtr; +extern int gicrqCtr; +extern int giccCtr; + +extern int lrqCtr; +extern int lrCtr; +extern int ldCtr; +extern int lcCtr; +extern int lirqCtr; +extern int lirCtr; +extern int lidCtr; +extern int licCtr; + +extern int mulCtr; +extern struct timespec mulTime; +extern int addCtr; +extern struct timespec addTime; + +extern struct timespec lrqTime; +extern struct timespec lrTime; +extern struct timespec ldTime; +extern struct timespec lcTime; +extern struct timespec lirqTime; +extern struct timespec lirTime; +extern struct timespec lidTime; +extern struct timespec licTime; + +extern struct timespec crttime1; +extern struct timespec crttime2; +extern struct timespec crttime3; +extern struct timespec crttime4; +extern struct timespec crtInvRqTime; +extern struct timespec crtCTime; +extern struct timespec crtInvCTime; + +extern struct timespec gprTime; +extern struct timespec gprqTime; +extern struct timespec gdrTime; +extern struct timespec gdrqTime; +extern struct timespec giprTime; +extern struct timespec giprqTime; +extern struct timespec gidrTime; +extern struct timespec gidrqTime; +extern struct timespec gcrqTime; +extern struct timespec gccTime; +#endif + +typedef int64_t hInt_t ; +typedef int32_t hDim_t ; +typedef int16_t hShort_t ; +typedef int8_t hByte_t ; + +typedef struct +{ + hDim_t prime; + hShort_t exponent; +} PrimeExponent; + + +typedef struct +{ + double real; + double imag; +} complex_t; + +//complex_t _add (complex_t a, complex_t b); +//complex_t _mul (complex_t a, complex_t b); + +#define CMPLX_ADD(a,b) ((complex_t){((a).real + (b).real), ((a).imag + (b).imag)}) +#define CMPLX_ADD3(a,b,c) ((complex_t){((a).real + (b).real + (c).real), ((a).imag + (b).imag + (c).imag)}) +#define CMPLX_ADD4(a,b,c,d) ((complex_t){((a).real + (b).real + (c).real + (d).real), ((a).imag + (b).imag + (c).imag + (d).imag)}) +#define CMPLX_ADD5(a,b,c,d,e) ((complex_t){((a).real + (b).real + (c).real + (d).real + (e).real), ((a).imag + (b).imag + (c).imag + (d).imag + (e).imag)}) +#define CMPLX_ADD6(a,b,c,d,e,f) ((complex_t){((a).real + (b).real + (c).real + (d).real + (e).real + (f).real), ((a).imag + (b).imag + (c).imag + (d).imag + (e).imag + (f).imag)}) +#define CMPLX_ADD7(a,b,c,d,e,f,g) ((complex_t){((a).real + (b).real + (c).real + (d).real + (e).real + (f).real + (g).real), ((a).imag + (b).imag + (c).imag + (d).imag + (e).imag + (f).imag + (g).imag)}) + +#define CMPLX_SUB(a,b) ((complex_t){((a).real - (b).real), ((a).imag - (b).imag)}) +#define CMPLX_MUL(a,b) ((complex_t){((a).real*(b).real - (a).imag*(b).imag), \ + (a).real*(b).imag + (a).imag*(b).real}) +#define CMPLX_DIV(a,b) ((complex_t){((a).real*(b).real + (a).imag*(b).imag)/((b).real*(b).real+(b).imag*(b).imag), \ + ((a).imag*(b).real - (a).real*(b).imag)/((b).real*(b).real+(b).imag*(b).imag)}) + +// 'inside' operators +#define CMPLX_IADD(a,b) { (a).real += (b).real; (a).imag += (b).imag; } +#define CMPLX_ISUB(a,b) { (a).real -= (b).real; (a).imag -= (b).imag; } +#define CMPLX_IMUL(a,b) { double temp = ((a).real*(b).real - (a).imag*(b).imag); \ + (a).imag = ((a).real*(b).imag + (a).imag*(b).real); \ + (a).real = temp; } + + +/* +// check if both vectors are identical +bool eqInt (hInt_t a[], hInt_t b[], size_t n); +// operations on integer vectors point-wise +void addInt (hInt_t result[], hInt_t a[], hInt_t b[], size_t n); +void mulInt (hInt_t result[], hInt_t a[], hInt_t b[], size_t n); +*/ + +// calculates base ** exp +hDim_t ipow(hDim_t base, hShort_t exp); +complex_t cmplxpow(complex_t base, hShort_t exp); +hInt_t qpow(hInt_t base, hShort_t exp, hInt_t q); + +hInt_t reciprocal (hInt_t a, hInt_t b); + +struct timespec tsSubtract (struct timespec time1, struct timespec time2); +struct timespec tsAdd (struct timespec time1, struct timespec time2); +const char *tsShow (struct timespec binaryTime, bool inLocal, const char *format); + +void getStats(); + +void mulRq (hInt_t* a, hInt_t* b, hDim_t totm, hInt_t q); +void mulMq (hInt_t* a, const hInt_t* b, const hDim_t totm, const hByte_t logr, const hInt_t k, const hInt_t q); +void mulC (complex_t* a, complex_t* b, hDim_t totm); + +void addR (hInt_t* a, hInt_t* b, hDim_t totm); +void addRq (hInt_t* a, const hInt_t* b, const hDim_t totm, const hInt_t q); +void addMq (hInt_t* a, const hInt_t* b, const hDim_t totm, const hByte_t logr, const hInt_t k, const hInt_t q); +void addC (complex_t* a, complex_t* b, hDim_t totm); +void addD (double* a, double* b, hDim_t totm); + +typedef void (*funcPtr) (void* outputVec, PrimeExponent pe, hDim_t lts, hDim_t rts, hInt_t q); +void tensorFuser (void* y, funcPtr f, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, hInt_t q); + +typedef void (*crtFuncPtr) (void* y, hDim_t lts, hDim_t rts, PrimeExponent pe, void* ru, hInt_t q); +void tensorFuserCRT (void* y, crtFuncPtr f, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, void** ru, hInt_t q); + +void tensorGPowR (hInt_t* x, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE); + +void tensorGPowRq (hInt_t* x, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, hInt_t q); + +void tensorGDecR (hInt_t* x, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE); + +void tensorGDecRq (hInt_t* x, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, hInt_t q); + +void tensorGInvPowR (hInt_t* x, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE); + +void tensorGInvPowRq (hInt_t* x, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, hInt_t q); + +void tensorGInvDecR (hInt_t* x, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE); + +void tensorGInvDecRq (hInt_t* x, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, hInt_t q); + +void tensorGCRTRq (hInt_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, hInt_t** gcoeffs, hInt_t q); + +void tensorGInvCRTRq (hInt_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, hInt_t** gcoeffs, hInt_t q); + +void tensorGCRTC (complex_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, complex_t** gcoeffs); + +void tensorGInvCRTC (complex_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, complex_t** gcoeffs); + + + +void tensorLRq (hInt_t* x, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, hInt_t q); + +void tensorLR (hInt_t* x, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE); + +void tensorLDouble (double* x, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE); + +void tensorLC (complex_t* x, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE); + +void tensorLInvRq (hInt_t* x, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, hInt_t q); + +void tensorLInvR (hInt_t* x, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE); + +void tensorLInvDouble (double* x, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE); + +void tensorLInvC (complex_t* x, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE); + + + +void tensorCRTRq (hInt_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, hInt_t** ru, hInt_t q); + +void tensorCRTC (complex_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, complex_t** ru); + +void tensorCRTInvRq (hInt_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, hInt_t** ru, hInt_t minv, hInt_t q); + +void tensorCRTInvC (complex_t* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, complex_t** ru, double minv); + +void tensorGaussianDec (double* y, hDim_t totm, PrimeExponent* peArr, hShort_t sizeOfPE, complex_t** ru); + + +#endif /* TENSORTYPES_H_ */ + diff --git a/src/Crypto/Lol/Cyclotomic/Tensor/RepaTensor.hs b/src/Crypto/Lol/Cyclotomic/Tensor/RepaTensor.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/Lol/Cyclotomic/Tensor/RepaTensor.hs @@ -0,0 +1,197 @@ +{-# LANGUAGE ConstraintKinds, DataKinds, DeriveDataTypeable, + FlexibleContexts, FlexibleInstances, GADTs, InstanceSigs, + MultiParamTypeClasses, NoImplicitPrelude, RebindableSyntax, + RoleAnnotations, ScopedTypeVariables, StandaloneDeriving, + TypeFamilies, TypeOperators, UndecidableInstances #-} + +-- | A pure, repa-based implementation of the Tensor interface. + +module Crypto.Lol.Cyclotomic.Tensor.RepaTensor +( RT ) where + +import Crypto.Lol.Cyclotomic.Tensor as T +import Crypto.Lol.Cyclotomic.Tensor.RepaTensor.CRT +import Crypto.Lol.Cyclotomic.Tensor.RepaTensor.Extension +import Crypto.Lol.Cyclotomic.Tensor.RepaTensor.Gauss +import Crypto.Lol.Cyclotomic.Tensor.RepaTensor.GL +import Crypto.Lol.Cyclotomic.Tensor.RepaTensor.RTCommon as RT +import Crypto.Lol.LatticePrelude as LP hiding + ((!!)) +import Crypto.Lol.Types.IZipVector + +import Algebra.Additive as Additive (C) +import Algebra.Ring as Ring (C) +import Algebra.ZeroTestable as ZeroTestable (C) + +import Control.Applicative +import Control.DeepSeq (NFData (rnf)) +import Control.Monad (liftM) +import Control.Monad.Random +import Data.Coerce +import Data.Constraint +import Data.Foldable as F +import Data.Maybe +import Data.Traversable as T +import Data.Typeable +import Data.Vector.Unboxed as U hiding (force) +import Test.QuickCheck + +-- | An implementation of 'Tensor' backed by repa. +data RT (m :: Factored) r where + RT :: Unbox r => !(Arr m r) -> RT m r + ZV :: IZipVector m r -> RT m r + deriving (Typeable) + +deriving instance Show r => Show (RT m r) + +instance Eq r => Eq (RT m r) where + (ZV a) == (ZV b) = a == b + (RT a) == (RT b) = a == b + a@(RT _) == b = a == toRT b + a == b@(RT _) = toRT a == b + +zvToArr :: Unbox r => IZipVector m r -> Arr m r +zvToArr v = let vec = convert $ unIZipVector v + in Arr $ fromUnboxed (Z :. U.length vec) vec + +-- converts to RT constructor +toRT :: Unbox r => RT m r -> RT m r +toRT v@(RT _) = v +toRT (ZV v) = RT $ zvToArr v + +toZV :: Fact m => RT m r -> RT m r +toZV (RT (Arr v)) = ZV $ fromMaybe (error "toZV: internal error") $ + iZipVector $ convert $ toUnboxed v +toZV v@(ZV _) = v + +wrap :: Unbox r => (Arr l r -> Arr m r) -> RT l r -> RT m r +wrap f (RT v) = RT $ f v +wrap f (ZV v) = RT $ f $ zvToArr v + +wrapM :: (Unbox r, Monad mon) => (Arr l r -> mon (Arr m r)) + -> RT l r -> mon (RT m r) +wrapM f (RT v) = liftM RT $ f v +wrapM f (ZV v) = liftM RT $ f $ zvToArr v + +instance Tensor RT where + + type TElt RT r = (IntegralDomain r, ZeroTestable r, + Eq r, Random r, NFData r, + Unbox r, Elt r) + + entailIndexT = tag $ Sub Dict + entailFullT = tag $ Sub Dict + + scalarPow = RT . scalarPow' + + l = wrap fL + lInv = wrap fLInv + + mulGPow = wrap fGPow + mulGDec = wrap fGDec + + divGPow = wrapM fGInvPow + divGDec = wrapM fGInvDec + + crtFuncs = (,,,,) <$> + (liftM (RT .) scalarCRT') <*> + (wrap <$> mulGCRT') <*> + (wrap <$> divGCRT') <*> + (wrap <$> fCRT) <*> + (wrap <$> fCRTInv) + + -- instance sigs are the cleanest way to handle many weird types + -- coming up + + tGaussianDec :: forall v rnd m q . + (Fact m, OrdFloat q, Random q, TElt RT q, + ToRational v, MonadRandom rnd) => v -> rnd (RT m q) + tGaussianDec = liftM RT . tGaussianDec' + + twacePowDec = wrap twacePowDec' + + embedPow = wrap embedPow' + embedDec = wrap embedDec' + + crtExtFuncs = (,) <$> (liftM wrap twaceCRT') + <*> (liftM wrap embedCRT') + + coeffs = wrapM coeffs' + + powBasisPow = (RT <$>) <$> powBasisPow' + + crtSetDec = (RT <$>) <$> crtSetDec' + + fmapT f (RT v) = RT $ (coerce $ force . RT.map f) v + fmapT f v@(ZV _) = fmapT f $ toRT v + + -- Repa arrays don't have mapM, so apply to underlying Unboxed + -- vector instead + fmapTM f (RT (Arr arr)) = liftM (RT . Arr . fromUnboxed (extent arr)) $ + U.mapM f $ toUnboxed arr + fmapTM f v@(ZV _) = fmapTM f $ toRT v + +---------- "Container" instances ---------- + +instance Fact m => Functor (RT m) where + -- Functor instance is implied by Applicative + fmap f x = pure f <*> x + +instance Fact m => Applicative (RT m) where + pure = ZV . pure + + -- RT can never hold an a -> b + (ZV f) <*> (ZV a) = ZV (f <*> a) + f@(ZV _) <*> v@(RT _) = f <*> toZV v + +instance Fact m => Foldable (RT m) where + -- Foldable instance is implied by Traversable + foldMap = foldMapDefault + +instance Fact m => Traversable (RT m) where + traverse f r@(RT _) = T.traverse f $ toZV r + traverse f (ZV v) = ZV <$> T.traverse f v + + +---------- Numeric Prelude instances ---------- + +-- CJP: should Elt, Unbox be constraints on these instances? It's +-- possible to zipWith on IZipVector, so it's not *necessary* to +-- convert toRT. + +instance (Fact m, Additive r, Unbox r, Elt r) => Additive.C (RT m r) where + (RT a) + (RT b) = RT $ coerce (\x -> force . RT.zipWith (+) x) a b + a + b = toRT a + toRT b + + negate (RT a) = RT $ (coerce $ force . RT.map negate) a + negate a = negate $ toRT a + + zero = RT $ repl zero + +instance (Fact m, Ring r, Unbox r, Elt r) => Ring.C (RT m r) where + (RT a) * (RT b) = RT $ coerce (\x -> force . RT.zipWith (*) x) a b + a * b = (toRT a) * (toRT b) + + fromInteger = RT . repl . fromInteger + +instance (Fact m, ZeroTestable r, Unbox r, Elt r) => ZeroTestable.C (RT m r) where + -- not using 'zero' to avoid Additive r constraint + isZero (RT (Arr a)) = isZero $ foldAllS (\ x y -> if isZero x then y else x) (a RT.! (Z:.0)) a + isZero (ZV v) = isZero v + +---------- Miscellaneous instances ---------- + +-- CJP: shouldn't these instances be defined in RTCommon, where the +-- Arr data type is defined? Here they are orphans. + +instance (Unbox r, Random (Arr m r)) => Random (RT m r) where + random = runRand $ liftM RT (liftRand random) + + randomR = error "randomR nonsensical for RT" + +instance (Unbox r, Arbitrary (Arr m r)) => Arbitrary (RT m r) where + arbitrary = RT <$> arbitrary + +instance (NFData r) => NFData (RT m r) where + rnf (RT v) = rnf v + rnf (ZV v) = rnf v diff --git a/src/Crypto/Lol/Cyclotomic/Tensor/RepaTensor/CRT.hs b/src/Crypto/Lol/Cyclotomic/Tensor/RepaTensor/CRT.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/Lol/Cyclotomic/Tensor/RepaTensor/CRT.hs @@ -0,0 +1,185 @@ +{-# LANGUAGE ConstraintKinds, FlexibleContexts, GADTs, NoImplicitPrelude, + ScopedTypeVariables #-} + +-- | Functions to support the chinese remainder transform on Repa arrays + +module Crypto.Lol.Cyclotomic.Tensor.RepaTensor.CRT +( scalarCRT' +, fCRT, fCRTInv +, mulGCRT', divGCRT' +, gCRT, gInvCRT +) where + +import Crypto.Lol.CRTrans +import Crypto.Lol.Cyclotomic.Tensor +import Crypto.Lol.Cyclotomic.Tensor.RepaTensor.GL +import Crypto.Lol.Cyclotomic.Tensor.RepaTensor.RTCommon as RT +import Crypto.Lol.LatticePrelude as LP + +import Control.Applicative +import Data.Coerce +import Data.Singletons.Prelude +import Data.Type.Natural as N hiding (Z, one, zero) + +-- | Embeds a scalar into the CRT-basis when such basis exists +scalarCRT' :: forall m r . (Fact m, CRTrans r, Unbox r) + => Maybe (r -> Arr m r) +scalarCRT' + = let pps = proxy ppsFact (Proxy::Proxy m) + sz = Z :. totientPPs pps + in pure $ Arr . force . fromFunction sz . const + +-- | Multiplies an array in the CRT basis by 'g', when the CRT basis exists +mulGCRT' :: forall m r . (Fact m, CRTrans r, Unbox r, Elt r) + => Maybe (Arr m r -> Arr m r) +mulGCRT' = (coerce (\x -> force . RT.zipWith (*) x) `asTypeOf` asTypeOf) <$> gCRT + +-- | Divides an array in the CRT basis by 'g', when the CRT basis exists. +divGCRT' :: (Fact m, CRTrans r, IntegralDomain r, ZeroTestable r, + Unbox r, Elt r) => Maybe (Arr m r -> Arr m r) +divGCRT' = (coerce (\x -> force . RT.zipWith (*) x) `asTypeOf` asTypeOf) <$> gInvCRT + +-- | The CRT-basis representation of 'g' +gCRT :: (Fact m, CRTrans r, Unbox r, Elt r) + => Maybe (Arr m r) +gCRT = fCRT <*> pure (fGPow $ scalarPow' LP.one) + +-- EAC: This was defined using (a safe call to) fromJust + +-- | The CRT-basis representation of 'g^{ -1 }' +gInvCRT:: (Fact m, CRTrans r, IntegralDomain r, + ZeroTestable r, Unbox r, Elt r) + => Maybe (Arr m r) +gInvCRT = fCRT <*> fGInvPow (scalarPow' LP.one) + + +fCRT, fCRTInv :: + forall m r . (Fact m, CRTrans r, Unbox r, Elt r) + => Maybe (Arr m r -> Arr m r) +-- | The chinese remainder transform on Repa arrays. +-- Exists if and only if crt exists for all prime powers +fCRT = evalM $ fTensor ppCRT + +-- divide by mhat after doing crtInv' +-- | The inverse chinese remainder transform on Repa arrays. +-- Exists if and only if crt exists for all prime powers +fCRTInv = do -- in Maybe + (_, mhatInv) :: (CRTInfo r) <- proxyT crtInfoFact (Proxy :: Proxy m) + let totm = proxy totientFact (Proxy :: Proxy m) + divMhat = trans totm $ RT.map (*mhatInv) + evalM $ (divMhat .*) <$> fTensor ppCRTInv' + +ppDFT, ppDFTInv', ppCRT, ppCRTInv' :: + forall pp r . (PPow pp, CRTrans r, Unbox r, Elt r) + => TaggedT pp Maybe (Trans r) + +ppDFT = case (sing :: SPrimePower pp) of + (SPP (STuple2 _ SZ)) -> return $ Id 1 + spp@(SPP (STuple2 sp (SS se1))) -> + tagT $ do + let spp' = SPP (STuple2 sp se1) + pp'dft <- withWitnessT ppDFT spp' + pptwid <- withWitnessT (ppTwid False) spp + pdft <- withWitnessT pDFT sp + return $ (pp'dft @* Id (dim pdft)) .* pptwid .* (Id (dim pp'dft) @* pdft) + +ppDFTInv' = case (sing :: SPrimePower pp) of + (SPP (STuple2 _ SZ)) -> return $ Id 1 + spp@(SPP (STuple2 sp (SS se1))) -> + tagT $ do + let spp' = SPP (STuple2 sp se1) + pp'dftInv' <- withWitnessT ppDFTInv' spp' + pptwidInv <- withWitnessT (ppTwid True) spp + pdftInv' <- withWitnessT pDFTInv' sp + return $ + (Id (dim pp'dftInv') @* pdftInv') .* pptwidInv .* + (pp'dftInv' @* Id (dim pdftInv')) + +ppCRT = case (sing :: SPrimePower pp) of + (SPP (STuple2 _ SZ)) -> return $ Id 1 + spp@(SPP (STuple2 sp (SS se1))) -> + tagT $ do + let spp' = SPP (STuple2 sp se1) + pp'dft <- withWitnessT ppDFT spp' + pptwid <- withWitnessT (ppTwidHat False) spp + pcrt <- withWitnessT pCRT sp + return $ + (pp'dft @* Id (dim pcrt)) .* pptwid .* + -- save some work when p=2 + (if dim pcrt > 1 then Id (dim pp'dft) @* pcrt else Id (dim pp'dft)) + +ppCRTInv' = case (sing :: SPrimePower pp) of + (SPP (STuple2 _ SZ)) -> return $ Id 1 + spp@(SPP (STuple2 sp (SS se1))) -> + tagT $ do + let spp' = SPP (STuple2 sp se1) + pp'dftInv' <- withWitnessT ppDFTInv' spp' + pptwidInv <- withWitnessT (ppTwidHat True) spp + pcrtInv' <- withWitnessT pCRTInv' sp + return $ -- special case for p=2 (necessary for scaling!) + (if dim pcrtInv' > 1 + then Id (dim pp'dftInv') @* pcrtInv' else Id (dim pp'dftInv')) .* + pptwidInv .* (pp'dftInv' @* Id (dim pcrtInv')) + +-- DFT_p, CRT_p, (scaled) DFT_p^-1, etc. +pDFT, pDFTInv', pCRT, pCRTInv' :: + forall p r . (NatC p, CRTrans r, Unbox r, Elt r) + => TaggedT p Maybe (Trans r) + +pDFT = let pval = proxy valueNatC (Proxy::Proxy p) + in do (omegaPPow, _) <- crtInfoNatC + return $ trans pval $ mulMat $ force $ + fromFunction (Z :. pval :. pval) + (\(Z:.i:.j) -> omegaPPow (i*j)) + +pDFTInv' = let pval = proxy valueNatC (Proxy::Proxy p) + in do (omegaPPow, _) <- crtInfoNatC + return $ trans pval $ mulMat $ force $ + fromFunction (Z :. pval :. pval) + (\(Z:.i:.j) -> omegaPPow (-i*j)) + +pCRT = let pval = proxy valueNatC (Proxy::Proxy p) + in do (omegaPPow, _) <- crtInfoNatC + return $ trans (pval-1) $ mulMat $ force $ + fromFunction (Z :. pval-1 :. pval-1) + (\(Z:.i:.j) -> omegaPPow ((i+1)*j)) + +-- crt_p * this = pI, for all values of p. For p=2 this isn't the +-- matrix we "want," but it doesn't matter because we don't use it in +-- ppCRTInv' +pCRTInv' = + let pval = proxy valueNatC (Proxy::Proxy p) + in do (omegaPPow, _) <- crtInfoNatC + return $ trans (pval-1) $ mulMat $ force $ + fromFunction (Z :. pval-1 :. pval-1) + (\(Z:.i:.j) -> omegaPPow (negate i*(j+1)) - + omegaPPow (j+1)) + +-- twiddle factors for DFT_pp and CRT_pp decompositions +ppTwid, ppTwidHat :: + forall pp r . (PPow pp, CRTrans r, Unbox r, Elt r) + => Bool -> TaggedT pp Maybe (Trans r) + +ppTwid inv = + let pp@(p,e) = proxy ppPPow (Proxy :: Proxy pp) + ppval = valuePP pp + in do + (omegaPPPow, _) <- crtInfoPPow + return $ trans ppval $ mulDiag $ force $ + fromFunction (Z :. ppval) + (\(Z:.i) -> let (iq,ir) = i `divMod` p + pow = (if inv then negate else id) + ir * digitRev (p,e-1) iq + in omegaPPPow pow) + +ppTwidHat inv = + let pp@(p,e) = proxy ppPPow (Proxy :: Proxy pp) + pptot = totientPP pp + in do + (omegaPPPow, _) <- crtInfoPPow + return $ trans pptot $ mulDiag $ force $ + fromFunction (Z :. pptot) + (\(Z:.i) -> let (iq,ir) = i `divMod` (p-1) + pow = (if inv then negate else id) + (ir+1) * digitRev (p,e-1) iq + in omegaPPPow pow) diff --git a/src/Crypto/Lol/Cyclotomic/Tensor/RepaTensor/Extension.hs b/src/Crypto/Lol/Cyclotomic/Tensor/RepaTensor/Extension.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/Lol/Cyclotomic/Tensor/RepaTensor/Extension.hs @@ -0,0 +1,193 @@ +{-# LANGUAGE BangPatterns, ConstraintKinds, DataKinds, FlexibleContexts, + FlexibleInstances, MultiParamTypeClasses, NoImplicitPrelude, + ScopedTypeVariables, TemplateHaskell, TypeFamilies, + TypeOperators #-} + +-- | RT-specific functions for embedding/twacing in various bases + +module Crypto.Lol.Cyclotomic.Tensor.RepaTensor.Extension +( twacePowDec', twaceCRT', embedPow', embedDec', embedCRT' +, coeffs', powBasisPow', crtSetDec' --, fromCoeffs' +) where + +import Crypto.Lol.LatticePrelude as LP hiding (lift, (!!)) +import Crypto.Lol.CRTrans +import Crypto.Lol.Reflects +import qualified Crypto.Lol.Cyclotomic.Tensor as T +import Crypto.Lol.Cyclotomic.Tensor.RepaTensor.CRT +import Crypto.Lol.Cyclotomic.Tensor.RepaTensor.RTCommon as RT +import Crypto.Lol.Types.FiniteField +import Crypto.Lol.Types.ZmStar + +import Control.Applicative +import Control.Arrow (first, (***)) + +import Data.Coerce +import Data.Default +import Data.Maybe +import Data.Reflection (reify) +import qualified Data.Vector as V +import qualified Data.Vector.Unboxed as U +import Data.Vector.Unboxed.Deriving + +-- Default instances +instance Default Z where def = Z +instance (Default a, Default b) => Default (a:.b) where def = def:.def + +-- derived Unbox instances +derivingUnbox "DIM1" + [t| (Z:.Int) -> Int |] + [| \(Z:.i) -> i |] + [| (Z :.) |] + +-- | The "tweaked trace" function in either the powerful or decoding +-- basis of the m'th cyclotomic ring to the mth cyclotomic ring when +-- @m | m'@. +twacePowDec' :: forall m m' r . (m `Divides` m', Unbox r) + => Arr m' r -> Arr m r +twacePowDec' + = let indices = proxy extIndicesPowDec (Proxy::Proxy '(m, m')) + in coerce $ \ !arr -> force $ backpermute (extent indices) (indices !) arr + +-- | The "tweaked trace" function in the CRT +-- basis of the m'th cyclotomic ring to the mth cyclotomic ring when +-- @m | m'@. +twaceCRT' :: forall m m' r . + (m `Divides` m', CRTrans r, IntegralDomain r, + ZeroTestable r, Unbox r, Elt r) + => Maybe (Arr m' r -> Arr m r) +twaceCRT' = do -- Maybe monad + g' :: Arr m' r <- gCRT + gInv <- gInvCRT + embed :: Arr m r -> Arr m' r <- embedCRT' + (_, m'hatinv) <- proxyT crtInfoFact (Proxy::Proxy m') + let hatRatioInv = m'hatinv * fromIntegral (proxy valueHatFact (Proxy::Proxy m)) + -- tweak = mhat * g' / (m'hat * g) + tweak = (coerce $ \x -> force . RT.map (* hatRatioInv) . RT.zipWith (*) x) (embed gInv) g' :: Arr m' r + indices = proxy extIndicesCRT (Proxy::Proxy '(m, m')) + return $ + -- take true trace after mul-by-tweak + coerce (\ !arr -> sumS . backpermute (extent indices) (indices !) . RT.zipWith (*) arr) tweak + +embedPow', embedDec' :: forall m m' r . + (m `Divides` m', Unbox r, Additive r) + => Arr m r -> Arr m' r +-- | Embeds an array in the powerful basis of the the mth cyclotomic ring +-- to an array in the powerful basis of the m'th cyclotomic ring when @m | m'@ +embedPow' + = let indices = proxy baseIndicesPow (Proxy::Proxy '(m, m')) + in coerce $ \ !arr -> force $ fromFunction (extent indices) + (\idx -> let (j0,j1) = (indices ! idx) + in if j0 == 0 then arr ! j1 else zero) +-- | Embeds an array in the decoding basis of the the mth cyclotomic ring +-- to an array in the decoding basis of the m'th cyclotomic ring when @m | m'@ +embedDec' + = let indices = proxy baseIndicesDec (Proxy::Proxy '(m, m')) + in coerce $ \ !arr -> force $ + fromFunction (extent indices) + (\idx -> maybe zero + (\(sh,b) -> if b then negate (arr ! sh) + else arr ! sh) + (indices ! idx)) + +-- | Embeds an array in the CRT basis of the the mth cyclotomic ring +-- to an array in the CRT basis of the m'th cyclotomic ring when @m | m'@ +embedCRT' :: forall m m' r . (m `Divides` m', CRTrans r, Unbox r) + => Maybe (Arr m r -> Arr m' r) +embedCRT' = do -- in Maybe + -- first check existence of CRT transform of index m' + proxyT crtInfoFact (Proxy::Proxy m') :: Maybe (CRTInfo r) + let idxs = proxy baseIndicesCRT (Proxy::Proxy '(m,m')) + return $ coerce $ \ !arr -> (force $ backpermute (extent idxs) (idxs !) arr) + +-- | maps an array in the powerful/decoding basis, representing an +-- O_m' element, to an array of arrays representing O_m elements in +-- the same type of basis +coeffs' :: forall m m' r . (m `Divides` m', Unbox r) + => Arr m' r -> [Arr m r] +coeffs' = + let indices = proxy extIndicesCoeffs (Proxy::Proxy '(m, m')) + in coerce $ \ !arr -> V.toList $ + V.map (\idxs -> force $ backpermute (extent idxs) (idxs !) arr) indices + +-- | The powerful extension basis, wrt the powerful basis. +-- Outputs a list of arrays in O_m' that are an O_m basis for O_m' +powBasisPow' :: forall m m' r . (m `Divides` m', Ring r, Unbox r) + => Tagged m [Arr m' r] +powBasisPow' = return $ + let (_, phi, phi', _) = proxy T.indexInfo (Proxy::Proxy '(m,m')) + idxs = proxy T.baseIndicesPow (Proxy::Proxy '(m,m')) + in LP.map (\k -> Arr $ force $ fromFunction (Z :. phi') + (\(Z:.j) -> let (j0,j1) = idxs U.! j + in if j0==k && j1==0 then one else zero)) + [0..phi' `div` phi - 1] + +-- | A list of arrays representing the mod-p CRT set of the +-- extension O_m'/O_m +crtSetDec' :: forall m m' fp . + (m `Divides` m', PrimeField fp, + Coprime (PToF (CharOf fp)) m', Unbox fp) + => Tagged m [Arr m' fp] +crtSetDec' = return $ + let m'p = Proxy :: Proxy m' + p = proxy value (Proxy::Proxy (CharOf fp)) + phi = proxy totientFact m'p + + d = proxy (order p) m'p + h :: Int = proxy valueHatFact m'p + hinv = recip $ fromIntegral h + in reify d $ \(_::Proxy d) -> + let twCRTs' :: T.Matrix (GF fp d) + = fromMaybe (error "internal error: crtSetDec': twCRTs") $ proxyT T.twCRTs m'p + zmsToIdx = proxy T.zmsToIndexFact m'p + elt j i = T.indexM twCRTs' j (zmsToIdx i) + trace' = trace :: GF fp d -> fp + cosets = proxy (partitionCosets p) (Proxy::Proxy '(m,m')) + in LP.map (\is -> Arr $ force $ fromFunction (Z :. phi) + (\(Z:.j) -> hinv * trace' + (sum $ LP.map (elt j) is))) cosets + + +-- convert memoized reindexing Vectors to Arrays, for convenience and speed + +extIndicesPowDec :: forall m m' . (m `Divides` m') + => Tagged '(m, m') (Array U DIM1 DIM1) +extIndicesPowDec = do + idxs <- T.extIndicesPowDec + return $ fromUnboxed (Z :. U.length idxs) $ U.map (Z:.) idxs + +extIndicesCRT :: forall m m' . (m `Divides` m') + => Tagged '(m, m') (Array U DIM2 DIM1) +extIndicesCRT = + let phi = proxy totientFact (Proxy::Proxy m) + phi' = proxy totientFact (Proxy::Proxy m') + in do + idxs <- T.extIndicesCRT + return $ fromUnboxed (Z :. phi :. phi' `div` phi) $ U.map (Z:.) idxs + +baseIndicesPow :: forall m m' . (m `Divides` m') + => Tagged '(m, m') (Array U DIM1 (Int,DIM1)) + +baseIndicesDec :: forall m m' . (m `Divides` m') + => Tagged '(m, m') (Array U DIM1 (Maybe (DIM1, Bool))) + +baseIndicesCRT :: forall m m' . (m `Divides` m') + => Tagged '(m, m') (Array U DIM1 DIM1) + +baseIndicesPow = do + idxs <- T.baseIndicesPow + return $ fromUnboxed (Z :. U.length idxs) $ U.map (id *** (Z:.)) idxs + +baseIndicesDec = do + idxs <- T.baseIndicesDec + return $ fromUnboxed (Z :. U.length idxs) $ U.map (liftA (first (Z:.))) idxs + +baseIndicesCRT = do + idxs <- T.baseIndicesCRT + return $ fromUnboxed (Z :. U.length idxs) $ U.map (Z:.) idxs + +extIndicesCoeffs :: forall m m' . (m `Divides` m') + => Tagged '(m, m') (V.Vector (Array U DIM1 DIM1)) +extIndicesCoeffs = + V.map (\arr -> fromUnboxed (Z :. U.length arr) $ + U.map (Z:.) arr) <$> T.extIndicesCoeffs diff --git a/src/Crypto/Lol/Cyclotomic/Tensor/RepaTensor/GL.hs b/src/Crypto/Lol/Cyclotomic/Tensor/RepaTensor/GL.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/Lol/Cyclotomic/Tensor/RepaTensor/GL.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE BangPatterns, ConstraintKinds, FlexibleContexts, GADTs, + MultiParamTypeClasses, NoImplicitPrelude, RankNTypes, + RebindableSyntax, ScopedTypeVariables #-} + +-- | The G and L transforms for Repa arrays + +module Crypto.Lol.Cyclotomic.Tensor.RepaTensor.GL +( fL, fLInv, fGPow, fGDec, fGInvPow, fGInvDec +) where + +import Crypto.Lol.Cyclotomic.Tensor.RepaTensor.RTCommon as RT +import Crypto.Lol.LatticePrelude as LP +import Data.Coerce + +fL, fLInv, fGPow, fGDec :: (Fact m, Additive r, Unbox r, Elt r) + => Arr m r -> Arr m r + +fGInvPow, fGInvDec :: + (Fact m, IntegralDomain r, ZeroTestable r, Unbox r, Elt r) + => Arr m r -> Maybe (Arr m r) +-- | Arbitrary-index L transform to convert a dec-basis Repa array to its powerful-basis representation +fL = eval $ fTensor $ ppTensor pL +-- | Arbitrary-index L^{ -1 } transform to convert a powerful-basis Repa array to its dec-basis representation +fLInv = eval $ fTensor $ ppTensor pLInv +-- | Arbitrary-index multiplication by the ring element g in the powerful basis +fGPow = eval $ fTensor $ ppTensor pGPow +-- | Arbitrary-index multiplication by the ring element g in the dec basis +fGDec = eval $ fTensor $ ppTensor pGDec +-- | Arbitrary-index division by the ring element g in the powerful basis. May fail if the input is not a multiple of g. +fGInvPow = wrapGInv' pGInvPow' +-- | Arbitrary-index multiplication by the ring element g in the dec basis. May fail if the input is not a multiple of g. +fGInvDec = wrapGInv' pGInvDec' + +wrapGInv' :: forall m r . + (Fact m, IntegralDomain r, ZeroTestable r, Unbox r, Elt r) + => (forall p . (NatC p) => Tagged p (Trans r)) + -> Arr m r -> Maybe (Arr m r) +wrapGInv' ginv = + let fGInv = eval $ fTensor $ ppTensor ginv + oddrad = fromIntegral $ proxy oddRadicalFact (Proxy::Proxy m) + in (`divCheck` oddrad) . fGInv + +-- | This is not a constant-time algorithm! Depending on its usage, +-- it might provide a timing side-channel. +divCheck :: (IntegralDomain r, ZeroTestable r, Unbox r) + => Arr m r -> r -> Maybe (Arr m r) +divCheck = coerce $ \ !arr den -> + let qrs = force $ RT.map (`divMod` den) arr + pass = foldAllS (&&) True $ RT.map (isZero . snd) qrs + out = force $ RT.map fst qrs + in if pass then Just out else Nothing + +pWrap :: forall p r . (NatC p) + => (forall rep . Source rep r => Int -> Array rep DIM2 r -> Array D DIM2 r) + -> Tagged p (Trans r) +pWrap f = let pval = proxy valueNatC (Proxy::Proxy p) + -- special case: return identity function for p=2 + in return $ if pval > 2 + then trans (pval-1) $ f pval + else Id 1 + + +pL, pLInv, pGPow, pGDec :: (NatC p, Additive r, Unbox r, Elt r) + => Tagged p (Trans r) + +pGInvPow', pGInvDec' :: (NatC p, Ring r, Unbox r, Elt r) + => Tagged p (Trans r) + +pL = pWrap (\_ !arr -> + fromFunction (extent arr) $ + \ (i':.i) -> sumAllS $ extract (Z:.0) (Z:.(i+1)) $ slice arr (i':.All)) + +pLInv = pWrap (\_ !arr -> + let f (i' :. 0) = arr! (i' :. 0) + f (i' :. i) = arr! (i' :. i) - arr! (i' :. i-1) + in fromFunction (extent arr) f) + + +-- multiplicaton by g_p=1-zeta_p in power basis. +-- this is "wrong" for p=2 but we never use that case thanks to pWrap. +pGPow = pWrap (\p !arr -> + let f (i':.0) = arr! (i':.p-2) + arr! (i':.0) + f (i':.i) = arr! (i':.p-2) + arr! (i':.i) - arr! (i':.i-1) + in fromFunction (extent arr) f) + +-- multiplication by g_p=1-zeta_p in decoding basis +pGDec = pWrap (\_ !arr -> + let f (i':.0) = arr! (i':.0) + sumAllS (slice arr (i':.All)) + f (i':.i) = arr! (i':.i) - arr! (i':.i-1) + in fromFunction (extent arr) f) + +-- CJP: profiling suggests that this does two read passes through the +-- array; see if we can rewrite to make it one + +-- doesn't do division by (odd) p +pGInvPow' = + pWrap (\p !arr -> + let f (i':.i) = + let col = slice arr (i':.All) + in fromIntegral (p-i-1) * sumAllS (extract (Z:.0) (Z:.i+1) col) + + fromIntegral (-i-1) * sumAllS (extract (Z:.i+1) (Z:.p-i-2) col) + in fromFunction (extent arr) f) + +-- doesn't do division by (odd) p +pGInvDec' = + pWrap (\p !arr -> + let f (i':.i) = + let col = slice arr (i':.All) + nats = fromFunction (Z:.p-1) (\(Z:.j) -> fromIntegral j+1) + in (sumAllS $ RT.zipWith (*) col nats) - + fromIntegral p * sumAllS (extract (Z:.i+1) (Z:.p-i-2) col) + in fromFunction (extent arr) f) diff --git a/src/Crypto/Lol/Cyclotomic/Tensor/RepaTensor/Gauss.hs b/src/Crypto/Lol/Cyclotomic/Tensor/RepaTensor/Gauss.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/Lol/Cyclotomic/Tensor/RepaTensor/Gauss.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE ConstraintKinds, FlexibleContexts, NoImplicitPrelude, + RebindableSyntax, ScopedTypeVariables #-} + +-- | (Continuous) Gaussian sampling for Repa arrays + +module Crypto.Lol.Cyclotomic.Tensor.RepaTensor.Gauss +( tGaussianDec' ) where + +import Crypto.Lol.Cyclotomic.Tensor.RepaTensor.RTCommon +import Crypto.Lol.GaussRandom +import Crypto.Lol.LatticePrelude + +import Control.Monad.Random + +-- | A function tagged by the cyclotomic index which, +-- given a (scaled) variance, outputs a Gaussian-distributed +-- vector in the decoding basis +tGaussianDec' :: forall m v r rnd . + (Fact m, OrdFloat r, Random r, Unbox r, Elt r, + ToRational v, MonadRandom rnd) + => v -> rnd (Arr m r) +tGaussianDec' = + let pm = Proxy::Proxy m + m = proxy valueFact pm + n = proxy totientFact pm + rad = proxy radicalFact pm + in \v -> do -- rnd monad + x <- realGaussians (v * fromIntegral (m `div` rad)) n + let arr = Arr $ fromUnboxed (Z:.n) x + return $ fD arr + +-- | The fully tensored D transformation +fD :: (Fact m, Transcendental r, Unbox r, Elt r) => Arr m r -> Arr m r +fD = eval $ fTensor $ ppTensor pD + +-- | The D transformation for a prime +pD :: forall p r . (NatC p, Transcendental r, Unbox r, Elt r) + => Tagged p (Trans r) +pD = let pval = proxy valueNatC (Proxy::Proxy p) + in tag $ + if pval==2 + then Id 1 + else trans (pval-1) $ mulMat $ force $ + fromFunction (Z :. pval-1 :. pval-1) + (\(Z:.i:.j) -> + -- mtx is sqrt(2)*[ cos(2pi*i*(j+1)/p) | sin(same) ] + -- (signs of columns doesn't matter for our purposes.) + let theta = 2 * pi * fromIntegral (i*(j+1)) / + fromIntegral pval + in sqrt 2 * if j < pval `div` 2 + then cos theta else sin theta) diff --git a/src/Crypto/Lol/Cyclotomic/Tensor/RepaTensor/RTCommon.hs b/src/Crypto/Lol/Cyclotomic/Tensor/RepaTensor/RTCommon.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/Lol/Cyclotomic/Tensor/RepaTensor/RTCommon.hs @@ -0,0 +1,233 @@ +{-# LANGUAGE BangPatterns, ConstraintKinds, DataKinds, FlexibleContexts, + FlexibleInstances, GADTs, GeneralizedNewtypeDeriving, + KindSignatures, MultiParamTypeClasses, NoImplicitPrelude, + RankNTypes, RebindableSyntax, RoleAnnotations, + ScopedTypeVariables, TypeOperators #-} + +-- | A simple DSL for tensoring Repa arrays and other common functionality +-- on Repa arrays + +module Crypto.Lol.Cyclotomic.Tensor.RepaTensor.RTCommon +( module R +, module Data.Array.Repa.Eval +, module Data.Array.Repa.Repr.Unboxed +, Arr(..), repl, replM, eval, evalM, fTensor, ppTensor +, Trans(Id), trans, dim, (.*), (@*), force +, mulMat, mulDiag +, scalarPow' +, sumS, sumAllS +) where + +import Crypto.Lol.LatticePrelude as LP hiding ((!!)) + +import Control.DeepSeq (NFData (..)) +import Control.Monad.Identity +import Control.Monad.Random +import Data.Array.Repa as R hiding (sumAllP, sumAllS, sumP, + sumS, (*^), (+^), (-^), (/^)) +import Data.Array.Repa.Eval hiding (one, zero) +import Data.Array.Repa.Repr.Unboxed +import Data.Coerce +import Data.Singletons +import Data.Singletons.Prelude hiding ((:.)) +import Data.Type.Natural hiding (Z) +import Data.Typeable +import qualified Data.Vector.Unboxed as U +import Test.QuickCheck + +-- always unboxed (manifest); intermediate calculations can use +-- delayed arrays + +-- | Indexed newtype for 1-dimensional Unbox repa arrays +newtype Arr (m :: Factored) r = Arr (Array U DIM1 r) + deriving (Eq, Show, Typeable, NFData) + +-- the first argument, though phantom, affects representation +-- CJP: why must the second arg be nominal? +-- EAC: From https://ghc.haskell.org/trac/ghc/wiki/Roles#Thesolution: +-- "The exception to the above algorithm is for classes: all parameters for a class default to a nominal role." +-- Arr is a synonym for Array, which is an associated data type to the class Source. The parameter `r` above +-- corresponds to the parameter `e` in the definition of class Source, so it's role must be nominal. +type role Arr nominal nominal + +-- | An 'Arr' filled with the argument. +repl :: forall m r . (Fact m, Unbox r) => r -> Arr m r +repl = let n = proxy totientFact (Proxy::Proxy m) + in Arr . fromUnboxed (Z:.n) . U.replicate n + +-- | Monadic version of 'repl'. +replM :: forall m r mon . (Fact m, Unbox r, Monad mon) + => mon r -> mon (Arr m r) +replM = let n = proxy totientFact (Proxy::Proxy m) + in liftM (Arr . fromUnboxed (Z:.n)) . U.replicateM n + +instance (Unbox r) => NFData (Array U DIM1 r) where + -- EAC: Repa doesn't define any NFData instances, + -- I'm hoping deepSeqArray is a reasonable approx + rnf x = deepSeqArray x () + +instance (Unbox r, Random r, Fact m) => Random (Arr m r) where + random = runRand $ replM (liftRand random) + + randomR = error "randomR nonsensical for Arr" + +instance (Arbitrary r, Unbox r, Fact m) => Arbitrary (Arr m r) where + arbitrary = replM arbitrary + shrink = shrinkNothing + +-- | For a factored index, tensors up any function defined for (and +-- tagged by) any prime power +fTensor :: forall m r mon . (Fact m, Monad mon, Unbox r) + => (forall pp . (PPow pp) => TaggedT pp mon (Trans r)) + -> TaggedT m mon (Trans r) + +fTensor func = tagT $ go $ sUnF (sing :: SFactored m) + where + go :: Sing (pplist :: [PrimePower]) -> mon (Trans r) + go spps = case spps of + SNil -> return $ Id 1 + (SCons spp rest) -> do + rest' <- go rest + func' <- withWitnessT func spp + return $ rest' @* func' + +-- | For a prime power pp > 1, tensors up any function f defined for +-- (and tagged by) a prime to (I_(pp/p) \otimes f) +ppTensor :: forall pp r mon . (PPow pp, Monad mon) + => (forall p . (NatC p) => TaggedT p mon (Trans r)) + -> TaggedT pp mon (Trans r) + +ppTensor func = tagT $ case (sing :: SPrimePower pp) of + -- intentionally no match for zero exponents, because that is + -- ill-formed and indicates an internal error + (SPP (STuple2 sp (SS se1))) -> do + func' <- withWitnessT func sp + let lts = withWitness valuePPow (SPP (STuple2 sp se1)) + return $ Id lts @* func' + + +-- deeply embedded DSL for transformations and their various +-- compositions + +-- (dim(f), f) where f operates on innermost dimension of array +data Tensorable r = Tensorable + Int (forall rep . Source rep r => Array rep DIM2 r -> Array D DIM2 r) + +-- transform component: a Tensorable with particular I_l, I_r +type TransC r = (Tensorable r, Int, Int) + +-- full transform: sequence of zero or more components +-- | a DSL for tensor transforms on Repa arrays +data Trans r = Id Int -- ^| identity sentinel + | TSnoc (Trans r) (TransC r) -- ^| (function) composition of transforms + +dimC :: TransC r -> Int +dimC (Tensorable d _, l, r) = l*d*r + +-- | Returns the (linear) dimension of a transform +dim :: Trans r -> Int +dim (Id n) = n +dim (TSnoc _ f) = dimC f -- just use dimension of head + +-- | smart constructor from a Tensorable +trans :: Int -> (forall rep . Source rep r => Array rep DIM2 r -> Array D DIM2 r) -> Trans r +trans d f = TSnoc (Id d) (Tensorable d f, 1, 1) + +-- | compose transforms +(.*) :: Trans r -> Trans r -> Trans r +f .* g | dim f == dim g = f ..* g + | otherwise = error $ "(.*): transform dimensions don't match " + LP.++ show (dim f) LP.++ ", " LP.++ show (dim g) + where + f' ..* (Id _) = f' -- drop sentinel + f' ..* (TSnoc rest g') = TSnoc (f' ..* rest) g' + +-- | tensor/Kronecker product (otimes) +(@*) :: Trans r -> Trans r -> Trans r +-- merge identity transforms +(Id n) @* (Id m) = Id (n*m) +-- Id on left or right +i@(Id n) @* (TSnoc g' (g, l, r)) = TSnoc (i @* g') (g, n*l, r) +(TSnoc f' (f, l, r)) @* i@(Id n) = TSnoc (f' @* i) (f, l, r*n) +-- no Ids: compose +f @* g = (f @* Id (dim g)) .* (Id (dim f) @* g) + +evalC :: (Unbox r) => TransC r -> Array U DIM1 r -> Array U DIM1 r +evalC (Tensorable d f, _, r) arr = + arr `deepSeqArray` force $ unexpose r $ f $ expose d r arr + +-- | Creates an evaluatable Haskell function from a tensored transform +eval :: (Unbox r) => Tagged m (Trans r) -> Arr m r -> Arr m r +eval x = coerce $ eval' $ untag x + where eval' (Id _) = id + eval' (TSnoc rest f) = eval' rest . evalC f + +-- | Monadic version of 'eval' +evalM :: (Unbox r, Monad mon) => TaggedT m mon (Trans r) -> mon (Arr m r -> Arr m r) +evalM = liftM (eval . return) . untagT + + +-- | maps the innermost dimension to a 2-dim array with innermost dim d, +-- for performing a I_l \otimes f_d \otimes I_r transformation +expose !d !r !arr = + let (sh :. sz) = extent arr + f (s :. i :. j) = let imodr = i `mod` r + idx = (i-imodr)*d + j*r + imodr + in arr ! (s :. idx) + in fromFunction (sh :. sz `div` d :. d) f + +-- | inverse of expose +unexpose !r !arr = + let (sh:.sz:.d) = extent arr + f (s :. i) = let (idivr,imodr) = i `divMod` r + (idivrd,j) = idivr `divMod` d + in arr ! (s :. r*idivrd + imodr :. j) + in fromFunction (sh :. sz*d) f + +-- | general matrix multiplication along innermost dim of v +mulMat :: (Source r1 r, Source r2 r, Ring r, Unbox r, Elt r) + => Array r1 DIM2 r -> Array r2 DIM2 r -> Array D DIM2 r +mulMat !m !v + = let (Z :. mrows :. mcols) = extent m + (sh :. vrows) = extent v + f (sh' :. i) = sumAllS $ R.zipWith (*) (slice m (Z:.i:.All)) $ slice v (sh':.All) + in if mcols == vrows then fromFunction (sh :. mrows) f + else error "mulMatVec: mcols != vdim" + +-- | multiplication by a diagonal matrix along innermost dim +mulDiag :: (Source r1 r, Source r2 r, Ring r, Unbox r, Elt r) + => Array r1 DIM1 r -> Array r2 DIM2 r -> Array D DIM2 r +mulDiag !diag !arr = fromFunction (extent arr) f + where f idx@(_ :. i) = arr! idx * diag! (Z:.i) + +-- misc Tensor functions + +-- | Embeds a scalar into a powerful-basis representation of a Repa array, +-- tagged by the cyclotomic index +scalarPow' :: forall m r . (Fact m, Additive r, Unbox r) => r -> Arr m r +scalarPow' = coerce . (go $ proxy totientFact (Proxy::Proxy m)) + where go n !r = let fct (Z:.0) = r + fct _ = LP.zero + in force $ fromFunction (Z:.n) fct + +-- | Forces a delayed array to a manifest array. +force :: (Shape sh, Unbox r) => Array D sh r -> Array U sh r +-- CJP: computeS just until we figure out how to avoid nested parallel +-- computation! +--force = computeS +force = runIdentity . computeP + +-- copied implementations of functions we need that normally require +-- Num + +-- | Sum the inner-most dimension of an array sequentially +sumS :: (Source r a, Elt a, Unbox a, Additive a, Shape sh) + => Array r (sh :. Int) a + -> Array U sh a +sumS = foldS (+) LP.zero + +-- | Sum all array indices to a scalar sequentially +sumAllS :: (Shape sh, Source r a, Elt a, Unbox a, Additive a) + => Array r sh a + -> a +sumAllS = foldAllS (+) LP.zero diff --git a/src/Crypto/Lol/Cyclotomic/UCyc.hs b/src/Crypto/Lol/Cyclotomic/UCyc.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/Lol/Cyclotomic/UCyc.hs @@ -0,0 +1,655 @@ +{-# LANGUAGE ConstraintKinds, DataKinds, DeriveDataTypeable, + FlexibleContexts, FlexibleInstances, GADTs, InstanceSigs, + MultiParamTypeClasses, NoImplicitPrelude, PolyKinds, + RankNTypes, RebindableSyntax, ScopedTypeVariables, + TypeFamilies, TypeOperators, UndecidableInstances #-} + +-- | An implementation of cyclotomic rings. WARNING: this module +-- provides an experts-only, "unsafe" interface that may result in +-- runtime errors if not used correctly! +-- 'Crypto.Lol.Cyclotomic.Cyc.Cyc' provides a safe interface, and +-- should be used in applications whenever possible. +-- +-- 'UCyc' transparently handles all necessary conversions between +-- internal representations to support fast ring operations, and +-- efficiently stores and operates upon elements that are known to +-- reside in subrings. +-- +-- The 'Functor', 'Applicative', 'Foldable', and 'Traversable' +-- instances of 'UCyc', as well as the 'fmapC' and 'fmapCM' functions, +-- work over the element's /current/ @r@-basis representation (or +-- 'pure' scalar representation as a special case, to satisfy the +-- 'Applicative' laws), and the output remains in that representation. +-- If the input's representation is not one of these, the behavior is +-- a runtime error. To ensure a valid representation when using the +-- methods from these classes, first call 'forceBasis' or one of its +-- specializations ('forcePow', 'forceDec', 'forceAny'). + +module Crypto.Lol.Cyclotomic.UCyc +( +-- * Data type + UCyc, CElt +-- * Basic operations +, mulG, divG +, scalarCyc, liftCyc +, adviseCRT +-- * Error sampling +, tGaussian, errorRounded, errorCoset +-- * Sub/extension rings +, embed, twace, coeffsCyc, powBasis, crtSet +-- * Representations +, forceBasis, forcePow, forceDec, forceAny +-- * Specialized maps +, fmapC, fmapCM +, U.Basis(..), U.RescaleCyc +) where + +import Crypto.Lol.CRTrans +import Crypto.Lol.Cyclotomic.Tensor as T +import qualified Crypto.Lol.Cyclotomic.Utility as U +import Crypto.Lol.Gadget +import Crypto.Lol.LatticePrelude as LP +import Crypto.Lol.Types.FiniteField +import Crypto.Lol.Types.ZPP + +import Algebra.Additive as Additive (C) +import Algebra.Ring as Ring (C) +import Algebra.ZeroTestable as ZeroTestable (C) + +import Control.Applicative hiding ((*>)) +import Control.DeepSeq +import Control.Monad.Identity +import Control.Monad.Random +import Data.Coerce +import Data.Foldable as F +import Data.Maybe +import Data.Traversable +import Data.Typeable +import Test.QuickCheck + +import qualified Debug.Trace as DT + +-- | A data type for representing cyclotomic rings such as @Z[zeta]@, +-- @Zq[zeta]@, and @Q(zeta)@: @t@ is the 'Tensor' type for storing +-- coefficients; @m@ is the cyclotomic index; @r@ is the base ring of +-- the coefficients (e.g., @Z@, @Zq@). +data UCyc t (m :: Factored) r where + Pow :: !(t m r) -> UCyc t m r -- representation wrt powerful basis + Dec :: !(t m r) -> UCyc t m r -- decoding basis + + -- Invariant: use CRTr if and only if crtFuncs exists for (t m r); + -- otherwise use CRTe (because crtFuncs is guaranteed to exist for + -- (t m (CRTExt r)) + CRTr :: !(t m r) -> UCyc t m r -- wrt CRT basis over r, if it exists + CRTe :: !(t m (CRTExt r)) -> UCyc t m r -- wrt CRT basis over r-extension + + -- super-optimized storage of scalars + Scalar :: !r -> UCyc t m r + + -- optimized storage of subring elements + Sub :: (l `Divides` m) => !(UCyc t l r) -> UCyc t m r + + + --EAC: Consider this representation for product rings, but beware of combinatorial explosion of cases. + --Product :: !(UCyc t m a) -> !(UCyc t m b) -> UCyc t m (a,b) + deriving (Typeable) + +-- | Shorthand for frequently reused constraints that are needed for +-- change of basis. +type UCCtx t r = (Tensor t, CRTrans r, CRTrans (CRTExt r), CRTEmbed r, + ZeroTestable r, TElt t r, TElt t (CRTExt r)) + +-- | Shorthand for frequently reused constraints that are needed for +-- most functions involving 'UCyc' and 'Crypto.Lol.Cyclotomic.Cyc.Cyc'. + +-- EAC: duplicated UCCtx for haddock +type CElt t r = (Tensor t, CRTrans r, CRTrans (CRTExt r), CRTEmbed r, + ZeroTestable r, TElt t r, TElt t (CRTExt r), Eq r, NFData r) + +-- | Same as 'Crypto.Lol.Cyclotomic.Cyc.scalarCyc', but for 'UCyc'. +scalarCyc :: (Fact m, CElt t a) => a -> UCyc t m a +scalarCyc = Scalar + +-- Eq instance +instance (UCCtx t r, Fact m, Eq r) => Eq (UCyc t m r) where + -- handle same bases when fidelity allows (i.e., *not* CRTe basis) + (Scalar v1) == (Scalar v2) = v1 == v2 + (Pow v1) == (Pow v2) = v1 == v2 \\ witness entailFullT v1 + (Dec v1) == (Dec v2) = v1 == v2 \\ witness entailFullT v1 + (CRTr v1) == (CRTr v2) = v1 == v2 \\ witness entailFullT v1 + + (Sub (c1 :: UCyc t l1 r)) == (Sub (c2 :: UCyc t l2 r)) = + (embed' c1 :: UCyc t (FLCM l1 l2) r) == embed' c2 + \\ lcmDivides (Proxy::Proxy l1) (Proxy::Proxy l2) + + -- otherwise compare in power basis for fidelity, which involves + -- the most efficient transforms in all cases + p1 == p2 = toPow' p1 == toPow' p2 + +---------- Numeric Prelude instances ---------- + +-- ZeroTestable instance +instance (UCCtx t r, Fact m) => ZeroTestable.C (UCyc t m r) where + isZero (Scalar v) = isZero v + isZero (Pow v) = isZero v \\ witness entailFullT v + isZero (Dec v) = isZero v \\ witness entailFullT v + isZero (CRTr v) = isZero v \\ witness entailFullT v + isZero x@(CRTe _) = isZero $ toPow' x + isZero (Sub c) = isZero c + +-- Additive instance +instance (UCCtx t r, Fact m) => Additive.C (UCyc t m r) where + + zero = Scalar zero + + -- optimized addition of zero + (Scalar c1) + v2 | isZero c1 = v2 + v1 + (Scalar c2) | isZero c2 = v1 + + -- SAME CONSTRUCTORS + (Scalar c1) + (Scalar c2) = Scalar (c1+c2) + (Pow v1) + (Pow v2) = Pow $ v1 + v2 \\ witness entailFullT v1 + (Dec v1) + (Dec v2) = Dec $ v1 + v2 \\ witness entailFullT v1 + (CRTr v1) + (CRTr v2) = CRTr $ v1 + v2 \\ witness entailFullT v1 + -- CJP: is this OK for precision? + (CRTe v1) + (CRTe v2) = CRTe $ v1 + v2 \\ witness entailFullT v1 + -- Sub plus Sub: work in compositum + (Sub (c1 :: UCyc t m1 r)) + (Sub (c2 :: UCyc t m2 r)) = + (Sub $ (embed' c1 :: UCyc t (FLCM m1 m2) r) + embed' c2) + \\ lcm2Divides (Proxy::Proxy m1) (Proxy::Proxy m2) (Proxy::Proxy m) + + -- SCALAR PLUS SOMETHING ELSE + + p1@(Scalar _) + p2@(Pow _) = toPow' p1 + p2 + p1@(Scalar _) + p2@(Dec _) = toDec' p1 + p2 + p1@(Scalar _) + p2@(CRTr _) = toCRT' p1 + p2 + p1@(Scalar _) + p2@(CRTe _) = toCRT' p1 + p2 + (Scalar v1) + (Sub c2) = Sub $ Scalar v1 + c2 + + p1@(Pow _) + p2@(Scalar _) = p1 + toPow' p2 + p1@(Dec _) + p2@(Scalar _) = p1 + toDec' p2 + p1@(CRTr _) + p2@(Scalar _) = p1 + toCRT' p2 + p1@(CRTe _) + p2@(Scalar _) = p1 + toCRT' p2 + (Sub c1) + (Scalar v2) = Sub $ c1 + Scalar v2 + + -- SUB PLUS SOMETHING ELSE (NON-SCALAR): work in full ring + (Sub c1) + c2 = embed' c1 + c2 + c1 + (Sub c2) = c1 + embed' c2 + + -- mixed Dec and Pow: use linear time conversions + p1@(Dec _) + p2@(Pow _) = toPow' p1 + p2 + p1@(Pow _) + p2@(Dec _) = p1 + toPow' p2 + + -- one CRTr: convert other to CRTr + p1@(CRTr _) + p2 = p1 + toCRT' p2 + p1 + p2@(CRTr _) = toCRT' p1 + p2 + + -- else, one is CRTe: convert both to Pow for fidelity and best + -- efficiency + p1 + p2 = toPow' p1 + toPow' p2 + + negate (Scalar c) = Scalar (negate c) + negate (Pow v) = Pow $ fmapT negate v + negate (Dec v) = Dec $ fmapT negate v + negate (CRTr v) = CRTr $ fmapT negate v + negate (CRTe v) = CRTe $ fmapT negate v + negate (Sub c) = Sub $ negate c + +-- Ring instance +instance (UCCtx t r, Fact m) => Ring.C (UCyc t m r) where + + one = Scalar one + + -- optimized mul-by-zero + v1@(Scalar c1) * _ | isZero c1 = v1 + _ * v2@(Scalar c2) | isZero c2 = v2 + + -- BOTH IN A CRT BASIS + (CRTr v1) * (CRTr v2) = CRTr $ v1 * v2 \\ witness entailFullT v1 + (CRTe v1) * (CRTe v2) = toPow' $ CRTe $ v1 * v2 \\ witness entailFullT v1 + + -- AT LEAST ONE SCALAR + (Scalar c1) * (Scalar c2) = Scalar $ c1 * c2 + + (Scalar c) * (Pow v) = Pow $ fmapT (*c) v + (Scalar c) * (Dec v) = Dec $ fmapT (*c) v + (Scalar c) * (CRTr v) = CRTr $ fmapT (*c) v + s@(Scalar _) * c'@(CRTe _) = s * toPow' c' + (Scalar c) * (Sub c2) = Sub $ Scalar c * c2 + + (Pow v) * (Scalar c) = Pow $ fmapT (*c) v + (Dec v) * (Scalar c) = Dec $ fmapT (*c) v + (CRTr v) * (Scalar c) = CRTr $ fmapT (*c) v + c'@(CRTe _) * s@(Scalar _) = toPow' c' * s + (Sub c1) * (Scalar c) = Sub $ c1 * Scalar c + + -- AT LEAST ONE SUB + + -- two Subs: work in compositum + (Sub (c1 :: UCyc t m1 r)) * (Sub (c2 :: UCyc t m2 r)) = + (Sub $ (embed' c1 :: UCyc t (FLCM m1 m2) r) * embed' c2) + \\ lcm2Divides (Proxy::Proxy m1) (Proxy::Proxy m2) (Proxy::Proxy m) + + -- Sub times something else (non-Scalar): work in full ring + (Sub c1) * p2 = embed' c1 * p2 + p1 * (Sub c2) = p1 * embed' c2 + + -- ELSE: work in appropriate CRT basis + p1 * p2 = toCRT' p1 * toCRT' p2 + + fromInteger = Scalar . fromInteger + +-- reduces in any basis +instance (Reduce a b, Fact m, CElt t a, CElt t b) + => Reduce (UCyc t m a) (UCyc t m b) where + + reduce = fmapC reduce . forceAny + +-- promote Gadget from base ring +instance (Gadget gad zq, Fact m, CElt t zq) => Gadget gad (UCyc t m zq) where + gadget = (scalarCyc <$>) <$> gadget + -- specialization of 'encode', done efficiently (via 'adviseCRT'). + encode s = ((* adviseCRT s) <$>) <$> gadget + +-- promote Decompose, using the powerful basis +instance (Decompose gad zq, Fact m, CElt t zq, + Reduce (UCyc t m (DecompOf zq)) (UCyc t m zq)) + => Decompose gad (UCyc t m zq) where + + type DecompOf (UCyc t m zq) = UCyc t m (DecompOf zq) + + -- traverse: Traversable (c m) and Applicative (Tagged gad ZL) + decompose = fromZL . traverse (toZL . decompose) . forcePow + where toZL :: Tagged s [a] -> TaggedT s ZipList a + toZL = coerce + fromZL :: TaggedT s ZipList a -> Tagged s [a] + fromZL = coerce + +-- promote Correct, using the decoding basis +instance (Correct gad zq, Fact m, CElt t zq) + => Correct gad (UCyc t m zq) where + -- sequenceA: Applicative (c m) and Traversable (TaggedT []) + correct bs = (correct . pasteT) <$> (sequenceA $ forceDec <$> peelT bs) + +-- generic RescaleCyc instance + +instance {-# OVERLAPS #-} (Rescale a b, CElt t a, CElt t b) + => U.RescaleCyc (UCyc t) a b where + rescaleCyc b = fmapC rescale . forceBasis (Just b) + +-- specialized instance for product rings: ~2x faster algorithm +instance (Mod a, Field b, Lift a z, Reduce z b, + CElt t a, CElt t b, CElt t (a,b), CElt t z) + => U.RescaleCyc (UCyc t) (a,b) b where + rescaleCyc bas = + let aval = proxy modulus (Proxy::Proxy a) + -- CJP: could use unzipC here to get (a,b) in one pass, but it + -- requires adding that method, and unzipT to Tensor and all its + -- instances. Probably not worth it. + in \x -> let y = forceAny x + a = fmapC fst y + b = fmapC snd y + z = liftCyc bas a + in (pure (recip (fromIntegral aval))) * (b - reduce z) + +-- | Same as 'Crypto.Lol.Cyclotomic.Cyc.liftCyc', but for 'UCyc'. +liftCyc :: (Lift b a, Fact m, CElt t a, CElt t b) + => U.Basis -> UCyc t m b -> UCyc t m a +liftCyc U.Pow = fmapC lift . forceBasis (Just U.Pow) +liftCyc U.Dec = fmapC lift . forceBasis (Just U.Dec) + +-- | Same as 'Crypto.Lol.Cyclotomic.Cyc.adviseCRT', but for 'UCyc'. +adviseCRT :: (Fact m, CElt t r) => UCyc t m r -> UCyc t m r +adviseCRT x@(Scalar _) = x +adviseCRT (Sub c) = Sub $ adviseCRT c +adviseCRT x = toCRT' x + +-- | Same as 'Crypto.Lol.Cyclotomic.Cyc.mulG', but for 'UCyc'. +mulG :: (Fact m, CElt t r) => UCyc t m r -> UCyc t m r +mulG (Scalar c) = Pow $ mulGPow $ scalarPow c -- must go to full ring +mulG (Sub c) = mulG $ embed' c -- must go to full ring +mulG (Pow v) = Pow $ mulGPow v +mulG (Dec v) = Dec $ mulGDec v +-- fromJust is safe here because we're already in CRTr +mulG (CRTr v) = CRTr $ fromMaybe (error "FC.mulG CRTr") mulGCRT v +mulG (CRTe v) = CRTe $ fromMaybe (error "FC.mulG CRTe") mulGCRT v + +-- | Same as 'Crypto.Lol.Cyclotomic.Cyc.divG', but for 'UCyc'. +divG :: (Fact m, CElt t r) => UCyc t m r -> Maybe (UCyc t m r) +divG (Scalar c) = liftM Pow (divGPow $ scalarPow c) -- full ring +divG (Sub c) = divG $ embed' c -- full ring +divG (Pow v) = Pow <$> divGPow v +divG (Dec v) = Dec <$> divGDec v +-- fromJust is safe here because we're already in CRTr +divG (CRTr v) = Just $ CRTr $ fromMaybe (error "FC.divG CRTr") divGCRT v +divG (CRTe v) = Just $ CRTe $ fromMaybe (error "FC.divG CRTe") divGCRT v + +-- | Same as 'Crypto.Lol.Cyclotomic.Cyc.tGaussian', but for 'UCyc'. +tGaussian :: (Fact m, OrdFloat q, Random q, CElt t q, + ToRational v, MonadRandom rnd) + => v -> rnd (UCyc t m q) +tGaussian = liftM Dec . tGaussianDec + +-- | Same as 'Crypto.Lol.Cyclotomic.Cyc.errorRounded', but for 'UCyc'. +errorRounded :: forall v rnd t m z . + (ToInteger z, Fact m, CElt t z, ToRational v, MonadRandom rnd) + => v -> rnd (UCyc t m z) +errorRounded svar = + fmapC (roundMult one) <$> (tGaussian svar :: rnd (UCyc t m Double)) + +-- | Same as 'Crypto.Lol.Cyclotomic.Cyc.errorCoset', but for 'UCyc'. +errorCoset :: forall t m zp z v rnd . + (Mod zp, z ~ ModRep zp, Lift zp z, Fact m, + CElt t zp, CElt t z, ToRational v, MonadRandom rnd) + => v -> UCyc t m zp -> rnd (UCyc t m z) +errorCoset = + let pval = fromIntegral $ proxy modulus (Proxy::Proxy zp) + -- we don't force* here because tGaussian is always in Dec + in \ svar c -> + roundCosetDec c <$> (tGaussian (svar * pval * pval) :: rnd (UCyc t m Double)) + +-- | Deterministically round to the given coset @c+pR@, using the +-- decoding basis. +roundCosetDec :: + (Mod zp, z ~ ModRep zp, Lift zp z, RealField q, + Fact m, CElt t q, CElt t zp, CElt t z) + => UCyc t m zp -> UCyc t m q -> UCyc t m z +roundCosetDec c x = roundCoset <$> forceDec c <*> forceDec x + +-- | Same as 'Crypto.Lol.Cyclotomic.Cyc.embed', but for 'UCyc'. +embed :: forall t r m m' . (m `Divides` m') => UCyc t m r -> UCyc t m' r +embed (Scalar c) = Scalar c +embed (Sub (c :: UCyc t l r)) = Sub c + \\ transDivides (Proxy::Proxy l) (Proxy::Proxy m) (Proxy::Proxy m') +embed c = Sub c + +-- | Same as 'Crypto.Lol.Cyclotomic.Cyc.twace', but for 'UCyc'. +twace :: forall t r m m' . (UCCtx t r, m `Divides` m') + => UCyc t m' r -> UCyc t m r +twace (Scalar c) = Scalar c +-- twace on Sub goes to the largest common subring of O_l and O_m +twace (Sub (c :: UCyc t l r)) = + Sub (twace c :: UCyc t (FGCD l m) r) + \\ gcdDivides (Proxy::Proxy l) (Proxy::Proxy m) +twace (Pow v) = Pow $ twacePowDec v +twace (Dec v) = Dec $ twacePowDec v +-- stay in CRTr only if it's possible, otherwise go to Pow +twace x@(CRTr v) = + fromMaybe (twace $ toPow' x) (CRTr <$> (twaceCRT <*> pure v)) +-- CJP: stay in CRTe: precision OK? +twace (CRTe v) = CRTe $ fromMaybe (error "FC.twace CRTe") twaceCRT v + +-- | Same as 'Crypto.Lol.Cyclotomic.Cyc.coeffsCyc', but for 'UCyc'. +coeffsCyc :: (m `Divides` m', CElt t r) + => U.Basis -> UCyc t m' r -> [UCyc t m r] +coeffsCyc U.Pow (Pow v) = LP.map Pow $ coeffs v +coeffsCyc U.Dec (Dec v) = LP.map Dec $ coeffs v +coeffsCyc U.Pow x = coeffsCyc U.Pow $ toPow' x +coeffsCyc U.Dec x = coeffsCyc U.Dec $ toDec' x + +-- | Same as 'Crypto.Lol.Cyclotomic.Cyc.powBasis', but for 'UCyc'. +powBasis :: (m `Divides` m', CElt t r) => Tagged m [UCyc t m' r] +powBasis = map Pow <$> powBasisPow + +-- | Same as 'Crypto.Lol.Cyclotomic.Cyc.crtSet', but for 'UCyc'. +crtSet :: forall t m m' r p mbar m'bar . + (m `Divides` m', ZPP r, p ~ CharOf (ZPOf r), + mbar ~ PFree p m, m'bar ~ PFree p m', + CElt t r, CElt t (ZPOf r)) + => Tagged m [UCyc t m' r] +crtSet = + -- CJP: consider using traceEvent or traceMarker + --DT.trace ("UCyc.fcCrtSet: m = " ++ + -- show (proxy valueFact (Proxy::Proxy m)) ++ ", m'= " ++ + -- show (proxy valueFact (Proxy::Proxy m'))) $ + let (p,e) = proxy modulusZPP (Proxy::Proxy r) + pp = Proxy::Proxy p + pm = Proxy::Proxy m + pm' = Proxy::Proxy m' + in retag (fmap (embed . (^(p^(e-1))) . Dec . fmapT liftZp) <$> + (crtSetDec :: Tagged mbar [t m'bar (ZPOf r)])) + \\ pFreeDivides pp pm pm' + \\ pSplitTheorems pp pm \\ pSplitTheorems pp pm' + +----- "Unsafe" functions that expose or rely upon internal representation + +-- | Yield an equivalent element whose internal representation /must/ +-- be in the indicated basis: powerful or decoding (for 'Just' 'Pow' +-- and 'Just' 'Dec' arguments, respectively), or any @r@-basis of the +-- implementation's choice (for 'Nothing' argument). (See also the +-- convenient specializations 'forcePow', 'forceDec', 'forceAny'.) +forceBasis :: (Fact m, CElt t r) => Maybe U.Basis -> UCyc t m r -> UCyc t m r +forceBasis (Just U.Pow) x = toPow' x +forceBasis (Just U.Dec) x = toDec' x +forceBasis Nothing x@(Scalar _) = toPow' x +forceBasis Nothing (Sub c) = forceBasis Nothing $ embed' c +forceBasis Nothing x@(CRTe _) = toPow' x +forceBasis Nothing x = x + +forcePow, forceDec, forceAny :: (Fact m, CElt t r) => UCyc t m r -> UCyc t m r +-- | Force a cyclotomic element into the powerful basis. +forcePow = forceBasis (Just U.Pow) +-- | Force a cyclotomic element into the decoding basis. +forceDec = forceBasis (Just U.Dec) +-- | Force a cyclotomic into any @r@-basis of the implementation's +-- choice. +forceAny = forceBasis Nothing + +-- | A more specialized version of 'fmap': apply a function +-- coordinate-wise in the current representation. The caller must +-- ensure that the current representation is an @r@-basis (one of +-- powerful, decoding, or CRT, if it exists), usually by using +-- 'forceBasis' or its specializations ('forcePow', 'forceDec', +-- 'forceAny'). Otherwise, behavior is undefined. +fmapC :: (Fact m, CElt t a, CElt t b) => (a -> b) -> UCyc t m a -> UCyc t m b + +-- must be in an r-basis for correct semantics, e.g., f 0 = 1 +fmapC _ (Scalar _) = error "can't fmapC on Scalar. Must forceBasis first!" +fmapC _ (Sub _) = error "can't fmapC on Sub. Must forceBasis first!" +fmapC _ (CRTe _) = error "can't fmapC on CRTe. Must forceBasis first!" + +fmapC f (Pow v) = Pow $ fmapT f v +fmapC f (Dec v) = Dec $ fmapT f v +fmapC f (CRTr v) = CRTr $ fmapT f v + +-- | Monadic version of 'fmapC'. +fmapCM :: (Fact m, CElt t a, CElt t b, Monad mon) + => (a -> mon b) -> UCyc t m a -> mon (UCyc t m b) + +-- must embed into full ring +fmapCM _ (Scalar _) = error "can't fmapCM on Scalar. Must forceBasis first!" +fmapCM _ (Sub _) = error "can't fmapCM on Sub. Must forceBasis first!" +fmapCM _ (CRTe _) = error "can't fmapCM on CRTe. Must forceBasis first!" + +fmapCM f (Pow v) = liftM Pow $ fmapTM f v +fmapCM f (Dec v) = liftM Dec $ fmapTM f v +fmapCM f (CRTr v) = liftM CRTr $ fmapTM f v + + + + +---------- HELPER FUNCTIONS (NOT FOR EXPORT) ---------- + +-- | Force embed, to a non-Sub constructor. +embed' :: forall t r l m . + (UCCtx t r, l `Divides` m) => UCyc t l r -> UCyc t m r +embed' (Scalar v) = Scalar v +embed' (Pow v) = Pow $ embedPow v +embed' (Dec v) = Dec $ embedDec v +-- stay in CRTr only if it's possible, otherwise go to Pow +embed' x@(CRTr v) = + fromMaybe (embed' $ toPow' x) (CRTr <$> (embedCRT <*> pure v)) +-- Staying in CRTe might not be safe, because the target tensor +-- might have implemented a CRTr even if the source tensor +-- hasn't. Mathematically this is impossible (because target has +-- CRTr only if source does), so this is purely about implementation. +embed' x@(CRTe _) = embed' $ toPow' x +embed' (Sub (c :: UCyc t k r)) = embed' c + \\ transDivides (Proxy::Proxy k) (Proxy::Proxy l) (Proxy::Proxy m) + + +--------- Basis conversion methods ------------------ + +toPow', toDec' :: (UCCtx t r, Fact m) => UCyc t m r -> UCyc t m r +-- forces the argument into the powerful basis +toPow' (Scalar c) = Pow $ scalarPow c +toPow' (Sub c) = toPow' $ embed' c +toPow' x@(Pow _) = x +toPow' (Dec v) = Pow $ l v +toPow' (CRTr v) = Pow $ fromMaybe (error "FC.toPow'") crtInv v +toPow' (CRTe v) = Pow $ fmapT fromExt $ fromMaybe (error "FC.toPow'") crtInv v + +-- forces the argument into the decoding basis +toDec' x@(Scalar _) = toDec' $ toPow' x -- use scalarDec instead +toDec' (Sub c) = toDec' $ embed' c +toDec' (Pow v) = Dec $ lInv v +toDec' x@(Dec _) = x +toDec' (CRTr v) = Dec $ lInv $ fromMaybe (error "FC.toDec'") crtInv v +toDec' (CRTe v) = Dec $ lInv $ fmapT fromExt $ fromMaybe (error "FC.toDec'") crtInv v + +-- forces the argument into a CRT basis, according to the invariant +-- about which one should be used +toCRT' :: forall t m r . (UCCtx t r, Fact m) => UCyc t m r -> UCyc t m r +toCRT' (Sub c) = toCRT' $ embed' c +toCRT' x@(CRTr _) = x +toCRT' x@(CRTe _) = x +toCRT' x = fromMaybe (toCRTe x) (toCRTr <*> pure x) + -- CJP: defining these helpers internally so they can't be called + -- from anywhere else. Therefore, the only way to convert to a + -- CRT basis is through the toCRT' method. + where + toCRTr = do -- Maybe monad + crt' <- crt + scalarCRT' <- scalarCRT + return $ \x -> case x of + (Scalar c) -> CRTr $ scalarCRT' c + (Pow v) -> CRTr $ crt' v + (Dec v) -> CRTr $ crt' $ l v + -- deliberately omit CRTe case, which should + -- never happen by internal invariant, so trigger + -- error if it does + toCRTe = let m = proxy valueFact (Proxy::Proxy m) + crt' = fromMaybe (error $ "FC.toCRT': no crt': " ++ (show m)) crt :: t m (CRTExt r) -> t m (CRTExt r) -- must exist + scalarCRT' = fromMaybe (error "FC.toCRT': no scalar crt'") scalarCRT :: CRTExt r -> t m (CRTExt r) + in \x -> case x of + (Scalar c) -> CRTe $ scalarCRT' $ toExt c + (Pow v) -> CRTe $ crt' $ fmapT toExt v + (Dec v) -> CRTe $ crt' $ fmapT toExt $ l v + +---------- "Container" instances ---------- + +instance (Tensor t, Fact m) => Functor (UCyc t m) where + -- Functor instance is implied by Applicative laws + fmap f x = pure f <*> x + +errApp name = error $ "UCyc.Applicative: can't/won't handle " ++ name ++ + "; call forcePow|Dec first" + +instance (Tensor t, Fact m) => Applicative (UCyc t m) where + + -- This implementation is restricted to the Scalar, Pow, Dec, or + -- CRTr constructors, in order to force the client to choose a + -- concrete @r@-basis and avoid unanticipated non-failure behavior. + -- Encountering a CRTe, or Sub constructor almost certainly means + -- that the client expressed something it did not intend (since it + -- cannot force such constructors to be used), so we want to raise + -- an exception early instead of doing unintended work. + + -- This implementation has one corner case that may + -- yield unexpected non-failure behavior: consider + -- fmap f (pure a) = (pure f) <*> (pure a) = (pure $ f a) + -- which is required by the Applicative homomorphism law. + + -- If the (pure a) is intended as an element of the base ring (which + -- is the custom), then its Pow coeffs are *not* all a's, so the + -- (likely intended) expression + -- fmap f $ forcePow (pure a) + -- may be a different result. If the client forgets the force, we + -- can't recognize it here and throw an error. (This is certainly the + -- client's fault; if it's not specifying a basis before fmap'ing + -- then it shouldn't expect the results to make sense. We just + -- can't catch the error here.) + + -- A solution is to introduce an explicit Pure constructor that's + -- only ever applied in 'pure', and throw an error if we encounter a + -- Scalar here. Arithmetically we'd treat Pures as Scalars, but in + -- a one-way fashion (outputs of arith ops are never Pure). + + pure = Scalar + + -- homomorphism (of pure) + (Scalar f) <*> (Scalar a) = Scalar $ f a + + -- constructors must match + (Pow v1) <*> (Pow v2) = Pow $ v1 <*> v2 \\ witness entailIndexT v1 + (Dec v1) <*> (Dec v2) = Dec $ v1 <*> v2 \\ witness entailIndexT v1 + (CRTr v1) <*> (CRTr v2) = CRTr $ v1 <*> v2 \\ witness entailIndexT v1 + + -- ... but we can also match Scalar with (almost) anything + (Scalar f) <*> (Pow v) = Pow $ pure f <*> v \\ witness entailIndexT v + (Scalar f) <*> (Dec v) = Dec $ pure f <*> v \\ witness entailIndexT v + (Scalar f) <*> (CRTr v) = CRTr $ pure f <*> v \\ witness entailIndexT v + + (Pow v) <*> (Scalar a) = Pow $ v <*> pure a \\ witness entailIndexT v + (Dec v) <*> (Scalar a) = Dec $ v <*> pure a \\ witness entailIndexT v + (CRTr v) <*> (Scalar a) = CRTr $ v <*> pure a \\ witness entailIndexT v + + -- cases we can't/won't handle + (Pow _) <*> (Dec _) = error "UCyc.Applicative: Pow/Dec combo" + (Dec _) <*> (Pow _) = error "UCyc.Applicative: Pow/Dec combo" + (Sub _) <*> _ = errApp "Sub" + _ <*> (Sub _) = errApp "Sub" + (CRTe _) <*> _ = errApp "CRTe" + _ <*> (CRTe _) = errApp "CRTe" + +instance (Tensor t, Fact m) => Foldable (UCyc t m) where + foldr f b (Scalar r) = f r b + foldr f b (Sub c) = F.foldr f b c + foldr f b (Pow v) = F.foldr f b v \\ witness entailIndexT v + foldr f b (Dec v) = F.foldr f b v \\ witness entailIndexT v + foldr f b (CRTr v) = F.foldr f b v \\ witness entailIndexT v + foldr _ _ (CRTe _) = error "UCyc.Foldable: can't handle CRTe" + +instance (Tensor t, Fact m) => Traversable (UCyc t m) where + traverse f (Scalar r) = Scalar <$> f r + traverse f (Sub c) = Sub <$> traverse f c + traverse f (Pow v) = Pow <$> traverse f v \\ witness entailIndexT v + traverse f (Dec v) = Dec <$> traverse f v \\ witness entailIndexT v + traverse f (CRTr v) = CRTr <$> traverse f v \\ witness entailIndexT v + traverse _ (CRTe _) = error "UCyc.Traversable: can't handle CRTe" + +---------- Utility instances ---------- + +instance (Tensor t, Fact m, TElt t r, CRTrans r) => Random (UCyc t m r) where + + -- create in CRTr basis if legal, otherwise in powerful + random = let cons = fromMaybe Pow + (proxyT hasCRTFuncs (Proxy::Proxy (t m r)) >> Just CRTr) + in \g -> let (v,g') = random g + \\ proxy entailFullT (Proxy::Proxy (t m r)) + in (cons v, g') + + randomR _ = error "randomR non-sensical for cyclotomic rings" + +instance (Show r, Show (t m r), Show (t m (CRTExt r))) + => Show (UCyc t m r) where + + show (Scalar c) = "scalar " ++ show c + show (Sub _) = "subring (not showing due to missing constraints)" + show (Pow v) = "powerful basis coeffs " ++ show v + show (Dec v) = "decoding basis coeffs " ++ show v + show (CRTr v) = "CRTr basis coeffs " ++ show v + show (CRTe v) = "CRTe basis coeffs " ++ show v + +instance (Arbitrary (t m r)) => Arbitrary (UCyc t m r) where + arbitrary = liftM Pow arbitrary + shrink = shrinkNothing + +instance (Tensor t, Fact m, NFData r, TElt t r, TElt t (CRTExt r)) + => NFData (UCyc t m r) where + rnf (Pow x) = rnf x \\ witness entailFullT x + rnf (Dec x) = rnf x \\ witness entailFullT x + rnf (CRTr x) = rnf x \\ witness entailFullT x + rnf (CRTe x) = rnf x \\ witness entailFullT x + rnf (Scalar x) = rnf x + rnf (Sub x) = rnf x diff --git a/src/Crypto/Lol/Cyclotomic/Utility.hs b/src/Crypto/Lol/Cyclotomic/Utility.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/Lol/Cyclotomic/Utility.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE MultiParamTypeClasses #-} + +module Crypto.Lol.Cyclotomic.Utility where + +import Crypto.Lol.Factored + +import Control.DeepSeq + +-- | Represents the powerful or decoding basis. +data Basis = Pow | Dec + +instance NFData Basis where + rnf Pow = () + rnf Dec = () + +-- | Represents cyclotomic rings that are rescalable over their base +-- rings. (This is a class because it allows for more efficient +-- specialized implementations.) + +class RescaleCyc c a b where + -- | Rescale in the given basis. + rescaleCyc :: Fact m => Basis -> c m a -> c m b diff --git a/src/Crypto/Lol/Factored.hs b/src/Crypto/Lol/Factored.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/Lol/Factored.hs @@ -0,0 +1,481 @@ +{-# LANGUAGE ConstraintKinds, DataKinds, + GADTs, KindSignatures, PolyKinds, + ScopedTypeVariables, TemplateHaskell, TypeFamilies, + TypeOperators, UndecidableInstances #-} + +-- | This file defines types and operations for type-level +-- representation and manipulation of factored integers. It relies on +-- TH, so the documentation will be difficult to read. See comments +-- for better documentation. + +module Crypto.Lol.Factored +( +-- * Factored natural numbers + Factored(..), SFactored, Fact +-- * Prime powers +, PrimePower(..), SPrimePower, PPow, Sing (SPP) +-- * Naturals +, Nat, NatC, PrimeNat, Prime +-- * Constructors +, toPP, sToPP, ToPP, ppToF, sPpToF, PpToF, PToF +-- * Unwrappers +, unF, sUnF, UnF, unPP, sUnPP, UnPP, primePP, PrimePP, exponentPP, ExponentPP +-- * Arithmetic operations +, fPPMul, FPPMul, fMul, FMul, type (*) +, fDivides, FDivides, Divides, fDiv, FDiv, type (/) +, fGCD, FGCD, fLCM, FLCM, Coprime +, fOddRadical, FOddRadical +, pFree, PFree +-- * Reflections +, ppsFact, valueFact, totientFact, valueHatFact, radicalFact, oddRadicalFact +, ppPPow, primePPow, exponentPPow, valuePPow, totientPPow +, valueNatC +-- * Number-theoretic laws +, transDivides, gcdDivides, lcmDivides, lcm2Divides +, pSplitTheorems, pFreeDivides +, (\\) -- re-export from Data.Constraint for convenience +-- * Utility operations (on prime powers) +, valueHat +, PP, ppToPP, valuePP, totientPP, radicalPP, oddRadicalPP +, valuePPs, totientPPs, radicalPPs, oddRadicalPPs +-- * Type synonyms (not type families) +, F1, F2, F3, F4, F5, F6, F7, F8, F9, F10 +, F11, F12, F13, F14, F15, F16, F17, F18, F19, F20 +, F21, F22, F24, F25, F26, F27, F28, F30 +, F32, F33, F34, F35, F36, F38, F39 +, F40, F42, F44, F45, F48, F49 +, F50, F51, F52, F54, F55, F56, F57 +, F60, F63, F64, F65, F66, F68 +, F70, F72, F75, F76, F77, F78, F80, F81, F84, F85, F88 +, F90, F91, F95, F96, F98, F99 +, F128, F256, F512, F1024, F2048 +) where + +import Data.Constraint hiding ((***)) +import Data.Functor.Trans.Tagged +import Data.Singletons.Prelude hiding (sMin, sMax, MinSym0, MaxSym0, (:-)) +import Data.Singletons.TH +import Data.Type.Natural as N hiding ((:-)) +import Data.Typeable + +import Control.Arrow ((***)) +import Unsafe.Coerce + +-- | Copied from Data.Type.Natural because the data-level version +-- is not exported there. +(<<=) :: Nat -> Nat -> Bool +Z <<= _ = True +S _ <<= Z = False +S n <<= S m = n <<= m + +singletons [d| + + -- Invariant: first component is prime, second component + -- (the exponent) is positive (nonzero) + newtype PrimePower = PP (Nat,Nat) deriving (Eq,Show,Typeable) + + -- List invariant: primes appear in strictly increasing + -- order (no duplicates) + newtype Factored = F [PrimePower] deriving (Eq,Show,Typeable) + + -- unwrap 'Factored' + unF :: Factored -> [PrimePower] + unF (F pps) = pps + + -- unwrap 'PrimePower' + unPP :: PrimePower -> (Nat,Nat) + unPP (PP pp) = pp + + -- grab individual components of a 'PrimePower' + primePP, exponentPP :: PrimePower -> Nat + primePP = fst . unPP + exponentPP = snd . unPP + + |] + +-- SMART CONSTRUCTORS +singletons [d| + + fPPMul :: PrimePower -> Factored -> Factored + fMul :: Factored -> Factored -> Factored + + -- constructor implementations + -- multiply a new 'PrimePower' into a 'Factored' number + fPPMul (PP(_,Z)) y = y -- throw away trivial prime power + fPPMul pp@(PP(_,S _)) (F pps) = F (ppMul pp pps) + + -- multiply two 'Factored' numbers + fMul (F pps1) (F pps2) = F (ppsMul pps1 pps2) + + -- helper functions (not for export) + + -- keeps primes in sorted order; merges duplicates + + -- EAC: Singletons(?) doesn't play well with pattern synonyms (e.g. x@(PP(p,e))) + -- when compiling with -O2 + -- reported as #10924 + -- singletons-2.0 doesn't work well with guards: https://github.com/goldfirere/singletons/issues/131 + ppMul :: PrimePower -> [PrimePower] -> [PrimePower] + ppMul x [] = [x] + ppMul (PP(p,e)) (PP (p',e'):pps') = + if p == p' then PP(p,e + e'):pps' + else if p <<= p' then (PP(p,e)):(PP (p',e'):pps') + else (PP(p',e')):ppMul (PP(p,e)) pps' + + ppsMul :: [PrimePower] -> [PrimePower] -> [PrimePower] + ppsMul [] ys = ys + ppsMul (pp:pps) ys = ppsMul pps (ppMul pp ys) + + |] + +-- ARITHMETIC OPERATIONS +singletons [d| + -- Smart constructor that checks that the first arg is + -- prime (< 20) and the second arg is positive + toPP :: Nat -> Nat -> PrimePower + toPP p e | primeNat p && (n1 <<= e) = PP (p,e) + + -- EAC: isn't there a singletons promotion for 'F' + -- that could replace this function? + ppToF :: PrimePower -> Factored + ppToF pp = F [pp] + + primeToF :: Nat -> Factored + primeToF p | primeNat p = ppToF $ PP (p, n1) + + fGCD, fLCM :: Factored -> Factored -> Factored + fDivides :: Factored -> Factored -> Bool + fDiv :: Factored -> Factored -> Factored + fOddRadical :: Factored -> Factored + + -- can't pattern-match on n*, but can test equality + primeNat n + | n==n2 = True + | n==n3 = True + | n==n5 = True + | n==n7 = True + | n==n11 = True + | n==n13 = True + | n==n17 = True + | n==n19 = True + fGCD (F pps1) (F pps2) = F (ppsGCD pps1 pps2) + fLCM (F pps1) (F pps2) = F (ppsLCM pps1 pps2) + + fDivides (F pps1) (F pps2) = ppsDivides pps1 pps2 + fDiv (F pps1) (F pps2) = F (ppsDiv pps1 pps2) + fOddRadical (F pps) = F (ppsOddRad pps) + + -- Helper functions (not for export) on PrimePowers and + -- lists. Can assume that input lists obey the invariant + -- of Factored lists, and need to ensure that output lists + -- also obey the invariant. + ppsGCD :: [PrimePower] -> [PrimePower] -> [PrimePower] + ppsGCD [] [] = [] + ppsGCD [] (_:_) = [] + ppsGCD (_:_) [] = [] + ppsGCD (PP (p,e) : xs') (PP (p',e') : ys') = + if p == p' then PP (p,N.min e e') : ppsGCD xs' ys' + else if p <<= p' then ppsGCD xs' (PP (p',e') : ys') + else ppsGCD (PP (p,e) : xs') ys' + + ppsLCM :: [PrimePower] -> [PrimePower] -> [PrimePower] + ppsLCM [] [] = [] + ppsLCM [] ys@(_:_) = ys + ppsLCM xs@(_:_) [] = xs + ppsLCM ((PP (p,e)) : xs') ((PP (p',e')) : ys') = + if p == p' then PP (p,N.max e e') : ppsLCM xs' ys' + else if p <<= p' then (PP (p,e)) : ppsLCM xs' ((PP (p',e')) : ys') + else (PP (p',e')) : ppsLCM ((PP (p,e)) : xs') ys' + + ppsDivides :: [PrimePower] -> [PrimePower] -> Bool + ppsDivides [] _ = True + ppsDivides (_:_) [] = False + ppsDivides (PP (p,e) : xs') (PP (p',e') : ys') = + if p == p' then (e <<= e') && ppsDivides xs' ys' + else not (p <<= p') && ppsDivides (PP (p,e) : xs') ys' + + ppsDiv :: [PrimePower] -> [PrimePower] -> [PrimePower] + ppsDiv xs [] = xs + ppsDiv ((PP (p,e)) : xs') (PP (p',e') : ys') = + if p == p' && e' == e then ppsDiv xs' ys' + else if p == p' && e' <<= e then PP (p,e-e') : ppsDiv xs' ys' + else if p <<= p' then (PP (p,e)) : ppsDiv xs' (PP (p',e') : ys') + else error "type error in ppsDiv" -- if p' <<= p then it's an error + + ppsOddRad :: [PrimePower] -> [PrimePower] + ppsOddRad [] = [] + ppsOddRad (PP ((S (S Z)),_) : xs') = ppsOddRad xs' + -- need to expand to avoid overlapping with previous case + ppsOddRad (PP (p@(S (S (S _))),_) : xs') = PP (p,n1) : ppsOddRad xs' + + |] + +singletons [d| + -- removes all @p@-factors from a 'Factored' + pFree :: Nat -> Factored -> Factored + pFree n (F pps) = F (go pps) + where go [] = [] + go (pp@(PP (p,_)) : ps) = + if n == p then ps + else pp : (go ps) + |] + +singletons [d| + + f1 = F [] + f2 = primeToF n2 + f3 = primeToF n3 + f4 = f2 `fMul` f2 + f5 = primeToF n5 + f6 = f2 `fMul` f3 + f7 = primeToF n7 + f8 = f2 `fMul` f4 + f9 = f3 `fMul` f3 + f10 = f2 `fMul` f5 + f11 = primeToF n11 + f12 = f4 `fMul` f3 + f13 = primeToF n13 + f14 = f2 `fMul` f7 + f15 = f3 `fMul` f5 + f16 = f2 `fMul` f8 + f17 = primeToF n17 + f18 = f2 `fMul` f9 + f19 = primeToF n19 + f20 = f2 `fMul` f10 + f21 = f3 `fMul` f7 + f22 = f2 `fMul` f11 + f24 = f2 `fMul` f12 + f25 = f5 `fMul` f5 + f26 = f2 `fMul` f13 + f27 = f3 `fMul` f9 + f28 = f2 `fMul` f14 + f30 = f2 `fMul` f15 + f32 = f2 `fMul` f16 + f33 = f3 `fMul` f11 + f34 = f2 `fMul` f17 + f35 = f5 `fMul` f7 + f36 = f2 `fMul` f18 + f38 = f2 `fMul` f19 + f39 = f3 `fMul` f13 + f40 = f2 `fMul` f20 + f42 = f2 `fMul` f21 + f44 = f2 `fMul` f22 + f45 = f3 `fMul` f15 + f48 = f2 `fMul` f24 + f49 = f7 `fMul` f7 + f50 = f2 `fMul` f25 + f51 = f3 `fMul` f17 + f52 = f2 `fMul` f26 + f54 = f2 `fMul` f27 + f55 = f5 `fMul` f11 + f56 = f2 `fMul` f28 + f57 = f3 `fMul` f19 + f60 = f2 `fMul` f30 + f63 = f3 `fMul` f21 + f64 = f2 `fMul` f32 + f65 = f5 `fMul` f13 + f66 = f2 `fMul` f33 + f68 = f2 `fMul` f34 + f70 = f2 `fMul` f35 + f72 = f2 `fMul` f36 + f75 = f3 `fMul` f25 + f76 = f2 `fMul` f38 + f77 = f7 `fMul` f11 + f78 = f2 `fMul` f39 + f80 = f2 `fMul` f40 + f81 = f3 `fMul` f27 + f84 = f2 `fMul` f42 + f85 = f5 `fMul` f17 + f88 = f2 `fMul` f44 + f90 = f2 `fMul` f45 + f91 = f7 `fMul` f13 + f95 = f5 `fMul` f19 + f96 = f2 `fMul` f48 + f98 = f2 `fMul` f49 + f99 = f9 `fMul` f11 + f128 = f2 `fMul` f64 + f256 = f2 `fMul` f128 + f512 = f2 `fMul` f256 + f1024 = f2 `fMul` f512 + f2048 = f2 `fMul` f1024 + |] + +-- | Type (family) synonym for division of 'Factored' types +type a / b = FDiv a b + +-- | Type (family) synonym for multiplication of 'Factored' types +type a * b = FMul a b + +-- | Type (family) synonym to create a Factored from a prime Nat +type PToF p = PpToF (ToPP p N1) + +-- convenience aliases: enforce kind, hide SingI + +-- | Kind-restricted synonym for 'SingI'. Use this in constraints +-- for types requiring a 'Factored' type. +type Fact (m :: Factored) = SingI m + +-- | Kind-restricted synonym for 'SingI'. Use this in constraints +-- for types requiring a 'PrimePower' type. +type PPow (pp :: PrimePower) = SingI pp + +-- | Kind-restricted synonym for 'SingI'. Use this in constraints +-- for types requiring a 'Nat' type. +type NatC (p :: Nat) = SingI p + +type Prime p = (NatC p, PrimeNat p ~ 'True) + +-- | Constraint synonym for divisibility of 'Factored' types +type Divides m m' = (Fact m, Fact m', FDivides m m' ~ 'True) + +-- | Constraint synonym for coprimality of 'Factored' types +type Coprime m m' = (FGCD m m' ~ F1) + +-- coercions: using proxy arguments here due to compiler bugs in usage + +-- coerce any divisibility relationship we want +coerceFDivs :: p m -> p' m' -> (() :- (FDivides m m' ~ True)) +coerceFDivs _ _ = Sub $ unsafeCoerce (Dict :: Dict ()) + +-- coerce any GCD we want +coerceGCD :: p a -> p' a' -> p'' a'' -> (() :- (FGCD a a' ~ a'')) +coerceGCD _ _ _ = Sub $ unsafeCoerce (Dict :: Dict ()) + +-- | Entails constraint for transitivity of division, i.e. +-- if @k|l@ and @l|m@, then @k|m@. +transDivides :: forall k l m . Proxy k -> Proxy l -> Proxy m -> + ((k `Divides` l, l `Divides` m) :- (k `Divides` m)) +transDivides k _ m = Sub Dict \\ coerceFDivs k m + +-- | Entails constraint for divisibility by GCD, i.e. +-- if @g=GCD(m1,m2)@, then @g|m1@ and @g|m2@. +gcdDivides :: forall m1 m2 g . Proxy m1 -> Proxy m2 -> + ((Fact m1, Fact m2, g ~ FGCD m1 m2) :- + (g `Divides` m1, g `Divides` m2)) +gcdDivides m1 m2 = + Sub $ withSingI (sFGCD (sing :: SFactored m1) (sing :: SFactored m2)) + Dict \\ coerceFDivs (Proxy::Proxy g) m1 + \\ coerceFDivs (Proxy::Proxy g) m2 + +-- | Entails constraint for LCM divisibility, i.e. +-- if @l=LCM(m1,m2)@, then @m1|l@ and @m2|l@. +lcmDivides :: forall m1 m2 l . Proxy m1 -> Proxy m2 -> + ((Fact m1, Fact m2, l ~ FLCM m1 m2) :- + (m1 `Divides` l, m2 `Divides` l)) +lcmDivides m1 m2 = + Sub $ withSingI (sFLCM (sing :: SFactored m1) (sing :: SFactored m2)) + Dict \\ coerceFDivs m1 (Proxy::Proxy l) + \\ coerceFDivs m2 (Proxy::Proxy l) + +-- | Entails constraint for LCM divisibility, i.e. +-- the LCM of two divisors of @m@ also divides @m@. +lcm2Divides :: forall m1 m2 l m . Proxy m1 -> Proxy m2 -> Proxy m -> + ((m1 `Divides` m, m2 `Divides` m, l ~ FLCM m1 m2) :- + (m1 `Divides` l, m2 `Divides` l, (FLCM m1 m2) `Divides` m)) +lcm2Divides m1 m2 m = + Sub $ withSingI (sFLCM (sing :: SFactored m1) (sing :: SFactored m2)) + Dict \\ coerceFDivs (Proxy::Proxy (FLCM m1 m2)) m \\ lcmDivides m1 m2 + +-- | Entails basic facts for @p@-free division, i.e. +-- if @f@ is @m@ after removing all @p@-factors, then @f|m@ and +-- @gcd(f,p)=1@ +pSplitTheorems :: forall p m f . Proxy p -> Proxy m -> + ((NatC p, Fact m, f ~ PFree p m) :- + (f `Divides` m, Coprime (PToF p) f)) +pSplitTheorems _ m = + Sub $ withSingI (sPFree (sing :: SNat p) (sing :: SFactored m)) + Dict \\ coerceFDivs (Proxy::Proxy f) m + \\ coerceGCD (Proxy::Proxy (PToF p)) (Proxy::Proxy f) (Proxy::Proxy F1) + +-- | Entails basic facts for @p@-free division, i.e., +-- if @m|m'@, then @p-free(m) | p-free(m')@ +pFreeDivides :: forall p m m' . Proxy p -> Proxy m -> Proxy m' -> + ((NatC p, m `Divides` m') :- + ((PFree p m) `Divides` (PFree p m'))) +pFreeDivides _ _ _ = + Sub $ withSingI (sPFree (sing :: SNat p) (sing :: SFactored m)) $ + withSingI (sPFree (sing :: SNat p) (sing :: SFactored m')) $ + Dict \\ coerceFDivs (Proxy::Proxy (PFree p m)) (Proxy::Proxy (PFree p m')) + +-- | Type synonym for @(prime :: Int, exponent :: Int)@ pair +type PP = (Int, Int) + +-- | Value-level prime-power factorization tagged by a 'Factored' type. +ppsFact :: forall m . (Fact m) => Tagged m [PP] +ppsFact = tag $ map ppToPP $ unF $ fromSing (sing :: SFactored m) + +valueFact, totientFact, valueHatFact, radicalFact, oddRadicalFact :: + (Fact m) => Tagged m Int + +-- | @Int@ representing the value of a 'Factored' type +valueFact = valuePPs <$> ppsFact + +-- | @Int@ representing the totient of a 'Factored' type's value +totientFact = totientPPs <$> ppsFact + +-- | @Int@ representing the "hat" of a 'Factored' type's value @m@: +-- @m@, if @m@ is odd, or @m/2@ otherwise. +valueHatFact = valueHat <$> valueFact + +-- | @Int@ representing the radical (product of prime divisors) +-- of a 'Factored' type +radicalFact = radicalPPs <$> ppsFact + +-- | @Int@ representing the odd radical (product of odd prime divisors) +-- of a 'Factored' type +oddRadicalFact = oddRadicalPPs <$> ppsFact + +-- | Reflects a 'PrimePower' type to a 'PP' value +ppPPow :: forall pp . (PPow pp) => Tagged pp PP +ppPPow = tag $ ppToPP $ fromSing (sing :: SPrimePower pp) + +primePPow, exponentPPow, valuePPow, totientPPow :: (PPow pp) => Tagged pp Int +-- | Reflects the prime component of a 'PrimePower' type +primePPow = fst <$> ppPPow +-- | Reflects the exponent component of a 'PrimePower' type +exponentPPow = snd <$> ppPPow +-- | @Int@ representing the value of a 'PrimePower' type +valuePPow = valuePP <$> ppPPow +-- | @Int@ representing the totient of a 'PrimePower' type's value +totientPPow = totientPP <$> ppPPow + +-- | @Int@ representing the value of a 'Nat' +valueNatC :: forall p . (NatC p) => Tagged p Int +valueNatC = tag $ sNatToInt (sing :: SNat p) + +-- | Returns @m@, if @m@ is odd, or @m/2@ otherwise +valueHat :: (Integral i) => i -> i +valueHat m = if m `mod` 2 == 0 then m `div` 2 else m + +-- | Converts a 'Nat' prime-power pair to an @Int@ prime-power pair +ppToPP :: PrimePower -> PP +ppToPP = (natToInt *** natToInt) . unPP + +valuePP, totientPP, radicalPP, oddRadicalPP :: PP -> Int +-- | Evaluates a prime-power pair @(p,e)@ to @p^e@ +valuePP (p,e) = p^e + +-- | Euler's totient function of a prime-power pair +totientPP (_,0) = 1 +totientPP (p,e) = (p-1)*(p^(e-1)) + +-- | The prime component of a prime-power pair +radicalPP (_,0) = 1 +radicalPP (p,_) = p + +-- | The odd radical of a prime-power pair (p,_): +-- p if p is odd, +-- 1 if p==2 +oddRadicalPP (_,0) = 1 +oddRadicalPP (2,_) = 1 +oddRadicalPP (p,_) = p + +valuePPs, totientPPs, radicalPPs, oddRadicalPPs :: [PP] -> Int +-- | Product of values of individual 'PP's +valuePPs = product . map valuePP +-- | Product of totients of individual 'PP's +totientPPs = product . map totientPP +-- | Product of radicals of individual 'PP's +radicalPPs = product . map radicalPP +-- | Product of odd radicals of individual 'PP's +oddRadicalPPs = product . map oddRadicalPP diff --git a/src/Crypto/Lol/Gadget.hs b/src/Crypto/Lol/Gadget.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/Lol/Gadget.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE ConstraintKinds, DataKinds, DeriveDataTypeable, + FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, + NoImplicitPrelude, PolyKinds, ScopedTypeVariables, + TupleSections, TypeFamilies, UndecidableInstances #-} + +-- | Interfaces for "gadgets," decomposition, and error correction. + +module Crypto.Lol.Gadget +( Gadget(..), Decompose(..), Correct(..) +, TrivGad, BaseBGad +) where + +import Crypto.Lol.LatticePrelude + +import Control.Applicative +import Data.Typeable + +-- | Dummy type representing the gadget @[1]@. +data TrivGad deriving (Typeable) +-- | Dummy type representing the gadget @[1,b,b^2,...]@. +data BaseBGad b deriving (Typeable) + +-- | "Gadget" vectors, parameterized by an index type. + +class Ring u => Gadget gad u where + -- | The gadget vector over @u@. + gadget :: Tagged gad [u] + + -- | Yield an error-tolerant encoding of an element with respect to + -- the gadget. (Mathematically, this should just be the product of + -- the input with the gadget, but it is a class method to allow for + -- optimized implementations.) + encode :: u -> Tagged gad [u] + encode s = ((* s) <$>) <$> gadget + +-- | Decomposition relative to a gadget. + +class (Gadget gad u, Reduce (DecompOf u) u) => Decompose gad u where + -- | The ring that @u@ decomposes over. + type DecompOf u + + -- | Yield a short vector @x@ such that @\ = u@. + decompose :: u -> Tagged gad [DecompOf u] + +-- | Error correction relative to a gadget. + +class Gadget gad u => Correct gad u where + + -- | Correct a "noisy" encoding of an element (see 'encode'). + correct :: Tagged gad [u] -> u + + + +-- instances for products + +instance (Gadget gad a, Gadget gad b) => Gadget gad (a,b) where + + gadget = (++) <$> (map (,zero) <$> gadget) <*> (map (zero,) <$> gadget) + +instance (Decompose gad a, Decompose gad b, DecompOf a ~ DecompOf b) + => Decompose gad (a,b) where + + type DecompOf (a,b) = DecompOf a + + decompose (a,b) = (++) <$> decompose a <*> decompose b + + +-- TODO: need some extra constraints on a,b, like Mod and maybe Rescale. +-- instance (Correct gad a, Correct gad b) => Correct gad (a,b) where + + + +{- CJP: strawman class for the more general view of LWE secrets as +"module characters," i.e., module homomorphisms into a particular +range. This is probably wrong, though. + +class Character u where -- Module superclass(es)? + type CharRange u + data Char u -- need data for injectivity + + evalChar :: Char u -> u -> CharRange u + +class (Gadget gad u, Character u) => Correct gad u where + + -- | Correct a "noisy" encoding of an LWE secret (i.e., a + -- 'ModuleHomom' on 'u'). + correct :: Tagged gad [CharRange u] -> Char u + +encode :: (Correct gad u) => Char u -> Tagged gad [CharRange u] +encode s = pasteT $ evalMH s <$> peelT gadget + +-} + diff --git a/src/Crypto/Lol/GaussRandom.hs b/src/Crypto/Lol/GaussRandom.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/Lol/GaussRandom.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE NoImplicitPrelude, RebindableSyntax, ScopedTypeVariables #-} + +-- | Functions for sampling from a continuous Gaussian distribution + +module Crypto.Lol.GaussRandom +( realGaussian, realGaussians ) where + +import Crypto.Lol.LatticePrelude + +import qualified Data.Vector.Generic as V + +import Control.Monad +import Control.Monad.Random + +-- | Using polar form of Box-Muller transform, returns a pair of +-- centered, Gaussian-distributed real numbers with scaled variance +-- @svar = true variance * (2*pi)@. See +-- for details. + +realGaussian :: forall v q m . + (ToRational v, OrdFloat q, Random q, MonadRandom m) + => v -> m (q,q) +realGaussian svar = + let var = realToField svar / pi :: q -- twice true variance + in do (u,v) <- iterateWhile uvGuard getUV + let t = u*u+v*v + com = sqrt (-var * log t / t) + return (u * com, v * com) + where getUV = do u <- getRandomR (zero,one) + v <- getRandomR (zero,one) + return (u,v) + uvGuard (u,v) = (u*u+v*v >= one) || (u*u+v*v == zero) + +-- | Generate @n@ real, independent gaussians of scaled variance @svar +-- = true variance * (2*pi)@. +realGaussians :: + (ToRational svar, OrdFloat i, Random i, V.Vector v i, MonadRandom m) + => svar -> Int -> m (v i) +realGaussians var n + | odd n = liftM V.tail (realGaussians var (n+1)) -- O(1) tail + | otherwise = liftM (V.fromList . uncurry (++) . unzip) $ + replicateM (n `div` 2) (realGaussian var) + + + + + + +-- Taken from monad-loops-0.4.3 + +-- | Execute an action repeatedly until its result fails to satisfy a predicate, +-- and return that result (discarding all others). +iterateWhile :: (Monad m) => (a -> Bool) -> m a -> m a +iterateWhile p x = x >>= iterateUntilM (not . p) (const x) + +-- | Analogue of @('Prelude.until')@ +-- Yields the result of applying f until p holds. +iterateUntilM :: (Monad m) => (a -> Bool) -> (a -> m a) -> a -> m a +iterateUntilM p f v + | p v = return v + | otherwise = f v >>= iterateUntilM p f + +{- +-- | Returns a Gaussian-distributed sample over 'pZ' with given +-- (scaled) variance parameter @v=var/(2*pi)@ and center, using +-- rejection sampling + +gaussRound :: (RealTranscendental v, Random v, + RealRing c, ToRational c, + Ring i, ToInteger i, Random i, MonadRandom m) + => v -> c -> m i +gaussRound svar c = + let dev = ceiling $ 6 * sqrt svar -- 6 gives stat dist < 2^-163 + lower = floor c - dev + upper = ceiling c + dev + sampler = do + z <- getRandomR (lower, upper) + u <- getRandomR (zero, one) + let dist = fromIntegral z - realToField c + let prob = exp (-pi * (dist*dist / svar)) + if u <= prob then return z else sampler + in sampler +-} diff --git a/src/Crypto/Lol/LatticePrelude.hs b/src/Crypto/Lol/LatticePrelude.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/Lol/LatticePrelude.hs @@ -0,0 +1,244 @@ +{-# LANGUAGE ConstraintKinds, DataKinds, FlexibleContexts, + FlexibleInstances, FunctionalDependencies, + GeneralizedNewtypeDeriving, MultiParamTypeClasses, + NoImplicitPrelude, PolyKinds, RankNTypes, RebindableSyntax, + ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, + TypeFamilies, TypeOperators, UndecidableInstances #-} + +-- | A substitute for the Prelude that is more suitable for Lol. This +-- module exports most of the Numeric Prelude and other frequently +-- used modules, plus some low-level classes, missing instances, and +-- assorted utility functions. + +module Crypto.Lol.LatticePrelude +( +-- * Classes + Enumerable(..) +, Mod(..) +, Reduce(..), Lift, Lift'(..), Rescale(..), Encode(..), msdToLSD +-- * Numeric +, module Crypto.Lol.Types.Numeric +-- * Complex +, module Crypto.Lol.Types.Complex +-- * Factored +, module Crypto.Lol.Factored +-- * Miscellaneous +, rescaleMod, roundCoset +, pureT, peelT, pasteT, withWitness, withWitnessT +, module Data.Functor.Trans.Tagged +, module Data.Proxy +) where + +import Crypto.Lol.Factored +import Crypto.Lol.Types.Complex +import Crypto.Lol.Types.Numeric + +import Algebra.Field as Field (C) +import Algebra.IntegralDomain as IntegralDomain (C) +import Algebra.Ring as Ring (C) + +import Control.Applicative +import Control.Arrow +import Control.DeepSeq +import Control.Monad.Identity +import Control.Monad.Random +import Data.Coerce +import Data.Default +import Data.Functor.Trans.Tagged +import Data.Maybe +import Data.Proxy +import Data.Singletons + +-- for Unbox instance of Maybe a +import qualified Data.Vector.Unboxed as U +import Data.Vector.Unboxed.Deriving + +instance NFData (Proxy (a :: k)) where rnf Proxy = () + +deriving instance NFData (m a) => NFData (TaggedT s m a) +deriving instance (MonadRandom m) => MonadRandom (TaggedT (tag :: k) m) + +derivingUnbox "Maybe" + [t| forall a . (Default a, U.Unbox a) => Maybe a -> (Bool, a) |] + [| maybe (False, def) (\ x -> (True, x)) |] + [| \ (b, x) -> if b then Just x else Nothing |] + +instance Default Bool where def = False + +-- | Poor man's 'Enum'. +class Enumerable a where + values :: [a] + +-- | Represents a quotient group modulo some integer. +class (ToInteger (ModRep a), Additive a) => Mod a where + type ModRep a + modulus :: Tagged a (ModRep a) + +-- | Represents that @b@ is a quotient group of @a@. +class (Additive a, Additive b) => Reduce a b where + reduce :: a -> b + +-- | Represents that @b@ can be lifted to a "short" @a@ congruent to @b@. +type Lift b a = (Lift' b, LiftOf b ~ a) + +-- | Fun-dep version of Lift. +class (Reduce (LiftOf b) b) => Lift' b where + type LiftOf b + lift :: b -> LiftOf b + +-- | Represents that @a@ can be rescaled to @b@, as an "approximate" +-- additive homomorphism. +class (Additive a, Additive b) => Rescale a b where + rescale :: a -> b + +-- | Represents that the target ring can "noisily encode" values from +-- the source ring, in either "most significant digit" (MSD) or "least +-- significant digit" (LSD) encodings, and provides conversion factors +-- between the two types of encodings. + +class (Field src, Field tgt) => Encode src tgt where + -- | The factor that converts an element from LSD to MSD encoding + -- in the target field, with associated scale factor to apply to + -- correct the resulting encoded value. + lsdToMSD :: (src, tgt) + +-- | Inverted entries of 'lsdToMSD'. +msdToLSD :: (Encode src tgt) => (src, tgt) +msdToLSD = (recip *** recip) lsdToMSD + +-- | A default implementation of rescaling for 'Mod' types. +rescaleMod :: forall a b . + (Mod a, Mod b, (ModRep a) ~ (ModRep b), + Lift a (ModRep b), Ring b) + => a -> b +rescaleMod = + let qval = proxy modulus (Proxy :: Proxy a) + q'val = proxy modulus (Proxy :: Proxy b) + in \x -> let (quot',_) = divModCent (q'val * lift x) qval + in fromIntegral quot' + +-- | Deterministically round to a nearby value in the desired coset +roundCoset :: forall zp z r . + (Mod zp, z ~ ModRep zp, Lift zp z, RealField r) => zp -> r -> z +roundCoset = let pval = proxy modulus (Proxy::Proxy zp) + in \ zp x -> let rep = lift zp + in rep + roundMult pval (x - fromIntegral rep) + +---------- Instances for product groups/rings ---------- + +instance (Mod a, Mod b, Lift' a, Lift' b, Reduce Integer (a,b), + ToInteger (LiftOf a), ToInteger (LiftOf b)) + => Lift' (a,b) where + + type LiftOf (a,b) = Integer + + lift (a,b) = + let moda = toInteger $ proxy modulus (Proxy::Proxy a) + modb = toInteger $ proxy modulus (Proxy::Proxy b) + q = moda * modb + ainv = fromMaybe (error "Lift' (a,b): moduli not coprime") $ moda `modinv` modb + lifta = toInteger $ lift a + liftb = toInteger $ lift b + -- put in [-q/2, q/2) + (_,r) = (moda * (liftb - lifta) * ainv + lifta) `divModCent` q + in r + + +-- NP should define Ring and Field instances for pairs, but doesn't. +-- So we do it here. +instance (Ring r1, Ring r2) => Ring.C (r1, r2) where + + (x1, x2) * (y1, y2) = (x1*y1, x2*y2) + one = (one,one) + fromInteger x = (fromInteger x, fromInteger x) + +instance (Field f1, Field f2) => Field.C (f1, f2) where + (x1, x2) / (y1, y2) = (x1 / y1, x2 / y2) + recip = recip *** recip + +instance (IntegralDomain a, IntegralDomain b) => IntegralDomain.C (a,b) where + (a1,b1) `divMod` (a2,b2) = + let (da,ra) = (a1 `divMod` a2) + (db,rb) = (b1 `divMod` b2) + in ((da,db), (ra,rb)) + +instance (Mod a, Mod b) => Mod (a,b) where + type ModRep (a,b) = Integer + + modulus = tag $ fromIntegral (proxy modulus (Proxy::Proxy a)) * + fromIntegral (proxy modulus (Proxy::Proxy b)) + +instance (Reduce a b1, Reduce a b2) => Reduce a (b1, b2) where + reduce x = (reduce x, reduce x) + +-- instances of Rescale for a product +instance (Mod a, Field b, Lift a (ModRep a), Reduce (LiftOf a) b) + => Rescale (a,b) b where + rescale = let q1val = proxy modulus (Proxy::Proxy a) + q1inv = recip $ reduce q1val + in \(x1,x2) -> q1inv * (x2 - reduce (lift x1)) + +instance (Mod b, Field a, Lift b (ModRep b), Reduce (LiftOf b) a) + => Rescale (a,b) a where + rescale = let q2val = proxy modulus (Proxy::Proxy b) + q2inv = recip $ reduce q2val + in \(x1,x2) -> q2inv * (x1 - reduce (lift x2)) + +-- some multi-step scaledowns; could do this forever +instance (Rescale (a,(b,c)) (b,c), Rescale (b,c) c) + => Rescale (a,(b,c)) c where + rescale = (rescale :: (b,c) -> c) . rescale + +instance (Rescale ((a,b),c) (a,b), Rescale (a,b) a) + => Rescale ((a,b),c) a where + rescale = (rescale :: (a,b) -> a) . rescale + +-- scaling up to a product +instance (Ring a, Mod b, Reduce (ModRep b) a) => Rescale a (a,b) where + -- multiply by q2 + rescale = let q2val = reduce $ proxy modulus (Proxy::Proxy b) + in \x -> (q2val * x, zero) + +instance (Ring b, Mod a, Reduce (ModRep a) b) => Rescale b (a,b) where + -- multiply by q1 + rescale = let q1val = reduce $ proxy modulus (Proxy::Proxy a) + in \x -> (zero, q1val * x) + +-- Instance of 'Encode' for product ring. +instance (Encode s t1, Encode s t2, Field (t1, t2)) => Encode s (t1, t2) where + + lsdToMSD = let (s1, t1conv) = lsdToMSD + (s2, t2conv) = lsdToMSD + in (negate s1 * s2, (t1conv,t2conv)) + +-- Random could have defined this instance, but didn't, so we do it +-- here. +instance (Random a, Random b) => Random (a,b) where + random g = let (a,g') = random g + (b, g'') = random g' + in ((a,b), g'') + + randomR ((loa,lob), (hia,hib)) g = let (a,g') = randomR (loa,hia) g + (b,g'') = randomR (lob,hib) g' + in ((a,b),g'') + +-- | Apply any applicative to a Tagged value. +pureT :: Applicative f => TaggedT t Identity a -> TaggedT t f a +pureT = mapTaggedT (pure . runIdentity) + +-- | Expose the monad of a tagged value. +peelT :: Tagged t (f a) -> TaggedT t f a +peelT = coerce + +-- | Hide the monad of a tagged value. +pasteT :: TaggedT t f a -> Tagged t (f a) +pasteT = coerce + +-- | Use a singleton as a witness to extract a value from a tagged value. +withWitness :: forall n r . (SingI n => Tagged n r) -> Sing n -> r +withWitness t wit = withSingI wit $ proxy t (Proxy::Proxy n) + +-- | Monadic version of 'withWitness'. +withWitnessT :: forall n mon r . (Monad mon) => + (SingI n => TaggedT n mon r) -> Sing n -> mon r +withWitnessT t wit = withSingI wit $ proxyT t (Proxy::Proxy n) diff --git a/src/Crypto/Lol/Reflects.hs b/src/Crypto/Lol/Reflects.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/Lol/Reflects.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE DataKinds, FlexibleContexts, FlexibleInstances, + KindSignatures, MultiParamTypeClasses, PolyKinds, + ScopedTypeVariables, UndecidableInstances #-} + +-- | Generic interface for reflecting types to values. + +module Crypto.Lol.Reflects +( Reflects(..) +) where + +import Crypto.Lol.Factored + +import Data.Functor.Trans.Tagged +import Data.Proxy +import Data.Reflection +import GHC.TypeLits as TL + +-- | Reflection without fundep, and with tagged value. Intended only +-- for low-level code; build specialized wrappers around it for +-- specific functionality. + +class Reflects a i where + -- | Reflect the value assiated with the type @a@. + value :: Tagged a i + +instance (KnownNat a, Integral i) => Reflects (a :: TL.Nat) i where + value = return $ fromIntegral $ natVal (Proxy::Proxy a) + +instance (NatC a, Integral i) => Reflects a i where + value = fmap fromIntegral valueNatC + +instance (PPow pp, Integral i) => Reflects pp i where + value = fmap fromIntegral valuePPow + +instance (Fact m, Integral i) => Reflects m i where + value = fmap fromIntegral valueFact + +instance {-# OVERLAPS #-} (Reifies rei a) => Reflects (rei :: *) a where + value = tag $ reflect (Proxy::Proxy rei) diff --git a/src/Crypto/Lol/Types/Complex.hs b/src/Crypto/Lol/Types/Complex.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/Lol/Types/Complex.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE DataKinds, DeriveDataTypeable, FlexibleContexts, + FlexibleInstances, GeneralizedNewtypeDeriving, + MultiParamTypeClasses, NoImplicitPrelude, RebindableSyntax, + ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, + TypeFamilies, UndecidableInstances #-} + +-- | Data type, functions, and instances for complex numbers. + +module Crypto.Lol.Types.Complex ( + Complex +, roundComplex +, cis, real, imag, fromReal +) where + +import Algebra.Additive as Additive (C) +import Algebra.Field as Field (C) +import Algebra.IntegralDomain as IntegralDomain +import Algebra.Ring as Ring (C) +import Algebra.ZeroTestable as ZeroTestable (C) +import qualified Number.Complex as C hiding (exp, signum) + +import Crypto.Lol.Types.Numeric as LP + +import Control.DeepSeq +import Data.Array.Repa.Eval as R +import Data.Vector.Storable (Storable) +import Data.Vector.Unboxed (Unbox) +import Data.Vector.Unboxed.Deriving +import System.Random +import Test.QuickCheck + +-- | Newtype wrapper (with slightly different instances) for +-- . +newtype Complex a = Complex (C.T a) deriving (Additive.C, Ring.C, ZeroTestable.C, Field.C, Storable, Eq, Show, Arbitrary) + +derivingUnbox "Complex" + [t| forall a . (Unbox a) => Complex a -> (a, a) |] + [| \ (Complex x) -> (C.real x, C.imag x) |] + [| \ (r, i) -> Complex $ r C.+: i |] + +-- a custom IntegralDomain instance, replacing the one provided by NP. +-- it always returns 0 as the remainder of a division. If we were to +-- use the NP instance, sometimes precision issues yield nonzero +-- remainders, which makes, e.g., 'divGPow' think that division has +-- failed, when it has not. This in turn causes 'divGCRT' to yield +-- Nothing, among other problems. +instance (Field a) => IntegralDomain.C (Complex a) where + (Complex a) `divMod` (Complex b) = (Complex $ a / b, LP.zero) + +-- we can't use Generics for NFData because NP doesn't export the +-- (deep) constructor for Complex.T +instance (NFData a) => NFData (Complex a) where + rnf (Complex x) = let r = C.real x + i = C.imag x + in rnf r `seq` rnf i `seq` () + +instance (Random a) => Random (Complex a) where + random g = let (a,g') = random g + (b,g'') = random g' + in (Complex $ a C.+: b, g'') + + randomR = error "randomR not defined for (Complex t)" + +instance (R.Elt a) => R.Elt (Complex a) where + touch (Complex c) = do + touch $ C.real c + touch $ C.imag c + zero = Complex $ R.zero C.+: R.zero + one = Complex $ R.one C.+: R.zero + +-- | Rounds the real and imaginary components to the nearest integer. +roundComplex :: (RealRing a, ToInteger b) => Complex a -> (b,b) +roundComplex (Complex x) = (round $ C.real x, round $ C.imag x) + +-- | 'cis' @t@ is a complex value with magnitude 1 and phase t (modulo @2*Pi@). +cis :: Transcendental a => a -> Complex a +cis = Complex . C.cis + +-- | Real component of a complex number. +real :: Complex a -> a +real (Complex a) = C.real a + +-- | Imaginary component of a complex number. +imag :: Complex a -> a +imag (Complex a) = C.imag a + +-- | Embeds a scalar as the real component of a complex number. +fromReal :: Additive a => a -> Complex a +fromReal = Complex . C.fromReal diff --git a/src/Crypto/Lol/Types/FiniteField.hs b/src/Crypto/Lol/Types/FiniteField.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/Lol/Types/FiniteField.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE ConstraintKinds, FlexibleContexts, + GeneralizedNewtypeDeriving, + NoImplicitPrelude, PolyKinds, + RebindableSyntax, RoleAnnotations, ScopedTypeVariables #-} + +-- CJP: need PolyKinds to allow deg to have non-* kind + +-- | Basic (unoptimized) finite field arithmetic. + +module Crypto.Lol.Types.FiniteField +( PrimeField, CharOf, GF -- export type but not constructor +, trace +, size +) where + +import Crypto.Lol.CRTrans +import Crypto.Lol.Factored +import Crypto.Lol.LatticePrelude +import Crypto.Lol.Reflects +import Crypto.Lol.Types.PrimeField hiding ((^)) +import qualified Crypto.Lol.Types.PrimeField as PF + +import Algebra.Additive as Additive (C) +import Algebra.Field as Field (C) +import Algebra.Ring as Ring (C) +import Algebra.ZeroTestable as ZeroTestable (C) +import MathObj.Polynomial + +import Math.NumberTheory.Primes.Factorisation + +import Control.Applicative +import Control.DeepSeq +import Control.Monad +import qualified Data.Vector as V + +--import qualified Debug.Trace as DT + +-- | A finite field of given degree over @F_p@. +newtype GF fp deg = GF (Polynomial fp) + deriving (Eq, Show, Additive.C, ZeroTestable.C, NFData) + +-- the second argument, though phantom, affects representation +type role GF representational representational + +type GFCtx fp deg = (PrimeField fp, Reflects deg Int) + +instance (GFCtx fp deg) => Enumerable (GF fp deg) where + values = GF <$> fromCoeffs <$> + -- d-fold cartesian product of Fp values + replicateM (proxy value (Proxy::Proxy deg)) values + +instance (GFCtx fp deg) => Ring.C (GF fp deg) where + + one = GF one + + (*) = let poly = proxy irreduciblePoly (Proxy :: Proxy deg) + in \(GF f) (GF g) -> GF $ (f*g) `mod` poly + + fromInteger = GF . fromInteger + +instance (GFCtx fp deg) => Field.C (GF fp deg) where + + recip = let g = proxy irreduciblePoly (Proxy :: Proxy deg) + in \(GF f) -> let (_,(a,_)) = extendedGCD f g + in GF a + +instance (GFCtx fp deg) => CRTrans (GF fp deg) where + + crtInfo m = (,) <$> omegaPow <*> scalarInv + where + omegaPow = + let size' = proxy size (Proxy :: Proxy (GF fp deg)) + (q,r) = (size'-1) `quotRem` m + gen = head $ filter isPrimitive values + omega = gen^q + omegaPows = V.iterateN m (*omega) one + in if r == 0 + then Just $ (omegaPows V.!) . (`mod` m) + else Nothing + scalarInv = Just $ recip $ fromIntegral $ valueHat m + +sizePP :: forall fp deg . (GFCtx fp deg) => Tagged (GF fp deg) PP +sizePP = tag (proxy value (Proxy::Proxy (CharOf fp)), + proxy value (Proxy::Proxy deg)) + +-- | The order of the field: @size (GF fp deg) = p^deg@ +size :: (GFCtx fp deg) => Tagged (GF fp deg) Int +size = uncurry (^) <$> sizePP + +isPrimitive :: forall fp deg . (GFCtx fp deg) => GF fp deg -> Bool +isPrimitive = let q = proxy size (Proxy :: Proxy (GF fp deg)) + ps = map (fromIntegral . fst) $ factorise $ + fromIntegral $ q-1 + exps = map ((q-1) `div`) ps + in \g -> not (isZero g) && all (\e -> g^e /= 1) exps + +dotp :: (Ring a) => [a] -> [a] -> a +dotp a b = sum $ zipWith (*) a b + +-- | Trace into the prime subfield. +trace :: forall fp deg . (GFCtx fp deg) => GF fp deg -> fp +trace = let ts = proxy powTraces (Proxy::Proxy (GF fp deg)) + in \(GF f) -> dotp ts (coeffs f) + +-- | Traces of the power basis elements 1, x, x^2, ..., x^(deg-1). +powTraces :: forall fp deg . (GFCtx fp deg) => Tagged (GF fp deg) [fp] +powTraces = + --DT.trace ("FiniteField.powTraces: p = " ++ + -- show (proxy value (Proxy::Proxy (CharOf fp)) :: Int) ++ + -- ", d = " ++ show (proxy value (Proxy::Proxy deg) :: Int)) $ + let d = proxy value (Proxy :: Proxy deg) + in tag $ map trace' $ take d $ + iterate (* (GF (X PF.^ 1))) (one :: GF fp deg) + +-- helper that computes trace via brute force: sum frobenius +-- automorphisms +trace' :: (GFCtx fp deg) => GF fp deg -> fp +trace' e = let (p,d) = witness sizePP e + (GF t) = sum $ take d $ iterate (^p) e + -- t is a constant polynomial + in head $ coeffs t + diff --git a/src/Crypto/Lol/Types/IZipVector.hs b/src/Crypto/Lol/Types/IZipVector.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/Lol/Types/IZipVector.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE ConstraintKinds, DataKinds, DeriveDataTypeable, + DeriveTraversable, FlexibleContexts, + GeneralizedNewtypeDeriving, KindSignatures, + MultiParamTypeClasses, RoleAnnotations, ScopedTypeVariables, + TypeFamilies, UndecidableInstances #-} + +-- | Provides applicative-like functions for indexed vectors + +module Crypto.Lol.Types.IZipVector +( IZipVector, iZipVector, unIZipVector +) where + +import Crypto.Lol.Factored + +import Algebra.ZeroTestable as ZeroTestable + +import Control.DeepSeq +import Data.Data +import Data.Functor.Trans.Tagged +import Data.Vector as V + +-- | Indexed Zip Vector: a wrapper around a (boxed) 'Vector' that has +-- zip-py 'Applicative' behavior, analogous to +-- 'Control.Applicative.ZipList' for lists. The index @m@ enforces +-- proper lengths (and is necessary to implement 'pure'). + +newtype IZipVector (m :: Factored) a = + IZipVector { -- | Deconstructor for IZipVector + unIZipVector :: Vector a} + -- not deriving Read, Monoid, Alternative, Monad[Plus], IsList + -- because of different semantics and/or length restriction + deriving (Show, Eq, Data, NFData, Typeable, Functor, + Foldable, Traversable, ZeroTestable.C) + +-- the first argument, though phantom, affects representation +type role IZipVector representational representational + +-- | Smart constructor that checks whether length of input is right +-- (should be totient of @m@). +iZipVector :: forall m a . (Fact m) => Vector a -> Maybe (IZipVector m a) +iZipVector = let n = proxy totientFact (Proxy::Proxy m) + in \vec -> if n == V.length vec + then Just $ IZipVector vec + else Nothing + +-- don't export +repl :: forall m a . (Fact m) => a -> IZipVector m a +repl = let n = proxy totientFact (Proxy::Proxy m) + in IZipVector . V.replicate n + +-- Zip-py 'Applicative' instance. +instance (Fact m) => Applicative (IZipVector m) where + pure = repl + (IZipVector f) <*> (IZipVector a) = IZipVector $ V.zipWith ($) f a + +-- no ZeroTestable instance for Vectors, so define here +instance (ZeroTestable.C a) => ZeroTestable.C (Vector a) where + isZero = V.all isZero diff --git a/src/Crypto/Lol/Types/IrreducibleChar2.hs b/src/Crypto/Lol/Types/IrreducibleChar2.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/Lol/Types/IrreducibleChar2.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE NoImplicitPrelude, RebindableSyntax, ScopedTypeVariables, + FlexibleInstances, TypeFamilies, UndecidableInstances, PolyKinds #-} + +-- | (Orphan) instance of 'IrreduciblePoly' for characteristic 2 fields. + +module Crypto.Lol.Types.IrreducibleChar2 () where + +import Crypto.Lol.LatticePrelude hiding ((^)) +import Crypto.Lol.Reflects +import Crypto.Lol.Types.PrimeField + +import Data.Type.Natural (N2) + +-- conway +--generate in Python (or choose any irreducible polynomial) +-- to generate with Sage, start sage and type: +-- conway_polynomial(p,e) +-- then copy and paste +instance (CharOf a ~ N2, Ring a) => IrreduciblePoly a where + irreduciblePoly = do + pn <- taggedProxy + let n = proxy value pn :: Int + return $ case n of + 1 -> X^1 + 1 + 2 -> X^2 + X^1 + 1 + 3 -> X^3 + X^1 + 1 + 4 -> X^4 + X^1 + 1 + 5 -> X^5 + X^2 + 1 + 6 -> X^6 + X^4 + X^3 + X^1 + 1 + 7 -> X^7 + X^1 + 1 + 8 -> X^8 + X^4 + X^3 + X^2 + 1 + 9 -> X^9 + X^4 + 1 + 10 -> X^10 + X^6 + X^5 + X^3 + X^2 + X^1 + 1 + 11 -> X^11 + X^2 + 1 + 12 -> X^12 + X^7 + X^6 + X^5 + X^3 + X^1 + 1 + 13 -> X^13 + X^4 + X^3 + X^1 + 1 + 14 -> X^14 + X^7 + X^5 + X^3 + 1 + 15 -> X^15 + X^5 + X^4 + X^2 + 1 + 16 -> X^16 + X^5 + X^3 + X^2 + 1 + 17 -> X^17 + X^3 + 1 + 18 -> X^18 + X^12 + X^10 + X^1 + 1 + 19 -> X^19 + X^5 + X^2 + X^1 + 1 + 20 -> X^20 + X^10 + X^9 + X^7 + X^6 + X^5 + X^4 + X^1 + 1 + 21 -> X^21 + X^6 + X^5 + X^2 + 1 + 22 -> X^22 + X^12 + X^11 + X^10 + X^9 + X^8 + X^6 + X^5 + 1 + 23 -> X^23 + X^5 + 1 + 24 -> X^24 + X^16 + X^15 + X^14 + X^13 + X^10 + X^9 + X^7 + X^5 + X^3 + 1 + 25 -> X^25 + X^8 + X^6 + X^2 + 1 + 26 -> X^26 + X^14 + X^10 + X^8 + X^7 + X^6 + X^4 + X^1 + 1 + 27 -> X^27 + X^12 + X^10 + X^9 + X^7 + X^5 + X^3 + X^2 + 1 + 28 -> X^28 + X^13 + X^7 + X^6 + X^5 + X^2 + 1 + 29 -> X^29 + X^2 + 1 + 30 -> X^30 + X^17 + X^16 + X^13 + X^11 + X^7 + X^5 + X^3 + X^2 + X^1 + 1 + 31 -> X^31 + X^3 + 1 + 32 -> X^32 + X^15 + X^9 + X^7 + X^4 + X^3 + 1 + otherwise -> + error $ "The ConwayPoly instance for N2 included with the library (and exported by Crypto.Lol) only contains " ++ + "irreducible polynomials for characteristic-2 fields up to GF(2^32). You need a polynomial " ++ + "for GF(2^" ++ (show n) ++ "). Define your own instance of ConwayPoly and do " ++ + "not import Crypto.Lol." diff --git a/src/Crypto/Lol/Types/Numeric.hs b/src/Crypto/Lol/Types/Numeric.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/Lol/Types/Numeric.hs @@ -0,0 +1,213 @@ +{-# LANGUAGE ConstraintKinds, DataKinds, FlexibleInstances, GADTs, + MultiParamTypeClasses, NoImplicitPrelude, RebindableSyntax, + ScopedTypeVariables, TypeOperators #-} + +-- we have some orphan instances here for instances of +-- package classes with Prelude data types +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | This module imports NumericPrelude and defines constraint +-- synonyms for NumericPrelude classes to help with code readability, +-- and defines saner versions of some NumericPrelude functions + +module Crypto.Lol.Types.Numeric +( module Crypto.Lol.Types.Numeric -- everything we define here +, module NumericPrelude -- re-export +, Int64 -- commonly used +) where + +import Control.DeepSeq +import Control.Monad.Random + +import Algebra.IntegralDomain (divUp) +-- NumericPrelude has silly types for these functions +import NumericPrelude hiding (abs, max, min, (^)) +import qualified NumericPrelude.Numeric (abs) +import qualified Prelude (max, min) + +import qualified Algebra.Absolute (C) +import qualified Algebra.Additive (C) +import qualified Algebra.Algebraic (C) +import qualified Algebra.Field (C) +import qualified Algebra.IntegralDomain (C) +import qualified Algebra.Module (C) +import qualified Algebra.PrincipalIdealDomain (C) +import qualified Algebra.RealField (C) +import qualified Algebra.RealIntegral (C) +import qualified Algebra.RealRing (C) +import qualified Algebra.RealTranscendental (C) +import qualified Algebra.Ring (C) +import qualified Algebra.ToInteger (C) +import qualified Algebra.ToRational (C, realToField) +import qualified Algebra.Transcendental (C) +import qualified Algebra.ZeroTestable (C) +import MathObj.Polynomial + +import Data.Int (Int64) + +-- | The Prelude definition of 'max'. +max :: Ord a => a -> a -> a +max = Prelude.max + +-- | The Prelude definition of 'min'. +min :: Ord a => a -> a -> a +min = Prelude.min + +-- | The sane definition of 'abs' from +-- 'NumericPrelude.Numeric' +-- rather than the default from 'NumericPrelude'. +abs :: Absolute a => a -> a +abs = NumericPrelude.Numeric.abs + +-- | The hidden NP function from 'Algebra.ToRational'. +realToField :: (Field b, ToRational a) => a -> b +realToField = Algebra.ToRational.realToField + +-- use this if you need: +{- isZero -} +-- | Sane synonym for 'Algebra.ZeroTestable.C'. +type ZeroTestable a = (Algebra.ZeroTestable.C a) + +{- - + negate -} +-- | Sane synonym for 'Algebra.Additive.C'. +type Additive a = (Algebra.Additive.C a) + +{- Additive, plus: * fromIntegral -} +-- | Sane synonym for 'Algebra.Ring.C'. +type Ring a = (Algebra.Ring.C a) + +{- Ring and Additive, plus: *> -} +-- | Sane synonym for 'Algebra.Module.C'. +type Module a v = (Algebra.Module.C a v) + +{- Ring, plus: div, mod, divmod -} +-- | Sane synonym for 'Algebra.IntegralDomain.C'. +type IntegralDomain a = (Algebra.IntegralDomain.C a) + +{- Ring, plus: abs signum toRational' -} +-- | Sane synonym for 'Algebra.ToRational.C'. +type ToRational a = (Algebra.ToRational.C a) + +{- Ring, plus: / recip fromRational -} +-- | Sane synonym for 'Algebra.Field.C'. +type Field a = (Algebra.Field.C a) + +{- Ring, plus: abs and rounding functions -} +-- | Sane synonym for 'Algebra.RealRing.C'. +type RealRing a = (Algebra.RealRing.C a) + +{- Field, plus: abs signum round floor ceiling -} +-- | Sane synonym for 'Algebra.RealField.C'. +type RealField a = (Algebra.RealField.C a) + +{- Field, plus: sqrt root ^/ -} +-- | Sane synonym for 'Algebra.Algebraic.C'. +type Algebraic a = (Algebra.Algebraic.C a) + +{- Algebraic, plus: pi exp log sin atan -} +-- | Sane synonym for 'Algebra.Transcendental.C'. +type Transcendental a = (Algebra.Transcendental.C a) + +{- Transcendental and RealField, plus atan2 -} +-- | Sane synonym for 'Algebra.RealTranscendental.C'. +type RealTranscendental a = (Algebra.RealTranscendental.C a) + +{- Transcendental, plus: == <= >= < > -} +-- | Convenient synonym for @(Ord a, Transcendental a)@ +type OrdFloat a = (Ord a, Transcendental a) + +{- ToRational and Ring, plus: toInteger div mod divmod quot rem quotrem -} +-- | Sane synonym for 'Algebra.ToInteger.C'. +type ToInteger a = (Algebra.ToInteger.C a) + +-- | Sane synonym for 'Algebra.Absolute.C'. +type Absolute a = (Algebra.Absolute.C a) + +-- | Sane synonym for 'Algebra.RealIntegral.C'. +type RealIntegral a = (Algebra.RealIntegral.C a) + +-- | Sane synonym for 'Algebra.PrincipalIdealDomain.C'. +type PID a = (Algebra.PrincipalIdealDomain.C a) + +-- | Sane synonym for 'MathObj.Polynomial.T'. +type Polynomial a = MathObj.Polynomial.T a + +-- | IntegralDomain instance for Double +instance Algebra.IntegralDomain.C Double where + _ `div` 0 = error "cannot divide Double by 0\n" + a `div` b = a / b + _ `mod` _ = 0 + +-- NFData instance for Polynomial, missing from NP +instance (NFData r) => NFData (Polynomial r) where + rnf = rnf . coeffs + +-- | Our custom exponentiation, overriding NP's version that +-- requires 'Integer' exponent. +-- Copied from http://hackage.haskell.org/package/base-4.7.0.0/docs/src/GHC-Real.html#%5E +{-# SPECIALISE [1] (^) :: + Integer -> Integer -> Integer, + Integer -> Int -> Integer, + Int -> Int -> Int, + Int64 -> Int64 -> Int64 + #-} +(^) :: forall a i . (Ring a, ToInteger i) => a -> i -> a +x0 ^ y0 | y0 < 0 = error "Negative exponent" + | y0 == 0 = 1 + | otherwise = f x0 y0 + where -- f : x0 ^ y0 = x ^ y + f :: a -> i -> a -- a polymorphic local binding needs a sig + f x y | even y = f (x * x) (y `quot` 2) + | y == 1 = x + | otherwise = g (x * x) ((y - 1) `quot` 2) x + -- g : x0 ^ y0 = (x ^ y) * z + g :: a -> i -> a -> a + g x y z | even y = g (x * x) (y `quot` 2) z + | y == 1 = x * z + | otherwise = g (x * x) ((y - 1) `quot` 2) (x * z) + +-- | Inverse of @a@ modulo @q@, in range @0..q-1@. (Argument order is +-- infix-friendly.) +modinv :: (PID i, Eq i) => i -> i -> Maybe i +modinv a q = let (d, (_, inv)) = extendedGCD q a + in if d == one + then Just $ inv `mod` q + else Nothing + +-- | Decompose an element into a list of "centered" digits with respect +-- to relative radices. +decomp :: (IntegralDomain z, Ord z) => [z] -> z -> [z] +decomp [] v = [v] +decomp (b:bs) v = let (q,r) = v `divModCent` b + in r : decomp bs q + +-- | Yield @ceil (log_b(x))@. +logCeil :: (ToInteger i) => i -> i -> Int +logCeil _ 1 = 0 +logCeil b x = 1 + logCeil b (x `divUp` b) + +-- | Deterministically round to the nearest multiple of @i@. +roundMult :: (RealField r, ToInteger i) => i -> r -> i +roundMult 1 r = round r +roundMult i r = let r' = r / fromIntegral i in i * round r' + +-- | Randomly round to the nearest larger or smaller multiple of @i@, +-- where the round-off term has expectation zero. +roundScalarCentered :: (RealField r, Random r, ToInteger i, + MonadRandom mon) + => i -> r -> mon i +roundScalarCentered p x = + let x' = x / fromIntegral p + mod1 = x' - floor x' + in do prob <- getRandomR (zero, one) + return $ p * if prob < mod1 + then ceiling x' + else floor x' + +-- | Variant of 'Algebra.IntegralDomain.divMod' in which the remainder +-- is in the range @[-b\/2,b\/2)@. +divModCent :: (IntegralDomain i, Ord i) => i -> i -> (i,i) +divModCent a b = let (q,r) = a `divMod` b + in if 2*r < b -- divMod returns non-neg remainder + then (q,r) + else (q+1,r-b) diff --git a/src/Crypto/Lol/Types/PrimeField.hs b/src/Crypto/Lol/Types/PrimeField.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/Lol/Types/PrimeField.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE NoImplicitPrelude, RebindableSyntax, PolyKinds, TypeFamilies, + DataKinds, FlexibleContexts, ConstraintKinds #-} + +-- | Prime-order fields. + +module Crypto.Lol.Types.PrimeField where + +import Crypto.Lol.LatticePrelude as LP +import Crypto.Lol.Reflects + +import MathObj.Polynomial + +-- | Constraint synonym for prime-order fields. +type PrimeField fp = (Enumerable fp, Eq fp, ZeroTestable fp, Field fp, + IrreduciblePoly fp) + +-- | The characteristic of a field, represented as a type. +type family CharOf (fp :: k) :: Nat + +-- | Represents prime-order fields over which we can get irreducible +-- polynomials of desired degree. (An instance of this class is +-- defined in 'Crypto.Lol.Types.IrreducibleChar2' and exported from +-- 'Crypto.Lol'.) +class (Ring fp, Prime (CharOf fp)) => IrreduciblePoly fp where + irreduciblePoly :: (Reflects deg Int) => Tagged deg (Polynomial fp) + +-- | Convenience function for writing 'IrreduciblePoly' instances. +taggedProxy :: Tagged s (Proxy s) +taggedProxy = tag Proxy + +-- | Convenience data type for writing 'IrreduciblePoly' instances. +data X = X + +-- | Convenience function for writing 'IrreduciblePoly' instances. +(^) :: (Ring a) => X -> Int -> Polynomial a +X ^ i | i >= 0 = fromCoeffs $ (replicate i 0) ++ [1] diff --git a/src/Crypto/Lol/Types/ZPP.hs b/src/Crypto/Lol/Types/ZPP.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/Lol/Types/ZPP.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE FlexibleContexts, TypeFamilies #-} + +-- | A class for integers mod a prime power. + +module Crypto.Lol.Types.ZPP +( ZPP(..) +) where + +import Crypto.Lol.LatticePrelude +import Crypto.Lol.Types.FiniteField + +-- | Represents integers modulo a prime power. +class (PrimeField (ZPOf zq), Ring zq, Ring (ZPOf zq)) => ZPP zq where + + -- | An implementation of the integers modulo the prime base. + type ZPOf zq + + -- | The prime and exponent of the modulus. + modulusZPP :: Tagged zq PP + + -- | Lift from @Z_p@ to a representative. + liftZp :: ZPOf zq -> zq + diff --git a/src/Crypto/Lol/Types/ZmStar.hs b/src/Crypto/Lol/Types/ZmStar.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/Lol/Types/ZmStar.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE ConstraintKinds, DataKinds, FlexibleContexts, + NoImplicitPrelude, PolyKinds, RebindableSyntax, + ScopedTypeVariables, TypeFamilies, TypeOperators, + UndecidableInstances #-} + +-- | A collection of helper functions for working with @Z_m^*@ + +module Crypto.Lol.Types.ZmStar +( order, partitionCosets +) where + +import Crypto.Lol.Factored +import Crypto.Lol.LatticePrelude as LP hiding (null) +import Crypto.Lol.Reflects +import Crypto.Lol.Types.ZqBasic + +import Data.List as L (foldl', transpose) +import Data.Map (Map, elems, empty, insertWith') +import Data.Set as S (Set, difference, findMin, fromList, map, null) + + +-- | The multiplicative order of @p@ (the argument) modulo @m@. +-- Requires @gcd(p,m)=1@. +order :: forall m . (Reflects m Int) => Int -> Tagged m Int +order p = tag $ + let mval = proxy value (Proxy::Proxy m) + in if gcd p mval /= 1 + then error "p and m not coprime" + else 1 + (length $ takeWhile (/= one) $ + tail $ iterate (* (fromIntegral p)) (one :: ZqBasic m Int)) + +-- given p, returns the cosets of Z_m^* /

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

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

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

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