packages feed

lol (empty) → 0.0.1.0

raw patch · 47 files changed

+10488/−0 lines, 47 filesdep +MonadRandomdep +QuickCheckdep +arithmoisetup-changed

Dependencies added: MonadRandom, QuickCheck, arithmoi, base, constraints, containers, data-default, deepseq, lol, mtl, numeric-prelude, random, reflection, repa, singletons, storable-record, storable-tuple, tagged-transformer, test-framework, test-framework-quickcheck2, th-desugar, time, transformers, type-natural, vector, vector-th-unbox

Files

+ LICENSE view
@@ -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.++    <one line to give the program's name and a brief idea of what it does.>+    Copyright (C) <year>  <name of author>++    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.++  <signature of Ty Coon>, 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.
+ README view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ lol.cabal view
@@ -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 <ecrockett0@gmail.com>+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
+ src/Crypto/Lol.hs view
@@ -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
+ src/Crypto/Lol/Applications/SymmSHE.hs view
@@ -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')
+ src/Crypto/Lol/CRTrans.hs view
@@ -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
+ src/Crypto/Lol/Cyclotomic/Cyc.hs view
@@ -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++
+ src/Crypto/Lol/Cyclotomic/Linear.hs view
@@ -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)
+ src/Crypto/Lol/Cyclotomic/Tensor.hs view
@@ -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')))
+ src/Crypto/Lol/Cyclotomic/Tensor/CTensor.hs view
@@ -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"
+ src/Crypto/Lol/Cyclotomic/Tensor/CTensor/Extension.hs view
@@ -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 <a,b,c,d> <0,3,2,3,1,0> = <a,d,c,d,b,a>+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
+ src/Crypto/Lol/Cyclotomic/Tensor/CTensor/basic.c view
@@ -0,0 +1,162 @@+#include "tensorTypes.h"+#ifdef CINTRIN+#include <immintrin.h>+#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)-1; // R-1++    for(int i = 0; i < totm; i++) {+        hInt_t x = a[i]*b[i];+        hInt_t s = k*(x & mask);+        hInt_t m = s & mask;+        a[i] = (x+m*q)>>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+}+
+ src/Crypto/Lol/Cyclotomic/Tensor/CTensor/crt.c view
@@ -0,0 +1,1305 @@+#include "tensorTypes.h"+#include <time.h>+#include <stdlib.h>++// there should be a special cases that do NOT require temp space to be allocated for all primes *smaller* than DFTP_GENERIC_SIZE+#define DFTP_GENERIC_SIZE 11++#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+}
+ src/Crypto/Lol/Cyclotomic/Tensor/CTensor/g.c view
@@ -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);
+}
+
+ src/Crypto/Lol/Cyclotomic/Tensor/CTensor/generalfuncs.c view
@@ -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);
+}
+
+
+ src/Crypto/Lol/Cyclotomic/Tensor/CTensor/l.c view
@@ -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
+}
+
+ src/Crypto/Lol/Cyclotomic/Tensor/CTensor/random.c view
@@ -0,0 +1,72 @@++#include <math.h>+#include <stdlib.h>+#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);+}
+ src/Crypto/Lol/Cyclotomic/Tensor/CTensor/tensorTypes.h view
@@ -0,0 +1,224 @@+
+#ifndef TENSORTYPES_H_
+#define TENSORTYPES_H_
+
+
+// remove next line for more efficient code
+//#define DEBUG_MODE
+
+
+#include <stdbool.h>
+#include <inttypes.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <time.h>
+
+
+#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_ */
+
+ src/Crypto/Lol/Cyclotomic/Tensor/RepaTensor.hs view
@@ -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
+ src/Crypto/Lol/Cyclotomic/Tensor/RepaTensor/CRT.hs view
@@ -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)
+ src/Crypto/Lol/Cyclotomic/Tensor/RepaTensor/Extension.hs view
@@ -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
+ src/Crypto/Lol/Cyclotomic/Tensor/RepaTensor/GL.hs view
@@ -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)
+ src/Crypto/Lol/Cyclotomic/Tensor/RepaTensor/Gauss.hs view
@@ -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)
+ src/Crypto/Lol/Cyclotomic/Tensor/RepaTensor/RTCommon.hs view
@@ -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
+ src/Crypto/Lol/Cyclotomic/UCyc.hs view
@@ -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
+ src/Crypto/Lol/Cyclotomic/Utility.hs view
@@ -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
+ src/Crypto/Lol/Factored.hs view
@@ -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
+ src/Crypto/Lol/Gadget.hs view
@@ -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 @\<g, x\> = 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++-}+
+ src/Crypto/Lol/GaussRandom.hs view
@@ -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+-- <http://www.alpheratz.net/murison/Maple/GaussianDistribution/GaussianDistribution.pdf+-- this link> 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+-}
+ src/Crypto/Lol/LatticePrelude.hs view
@@ -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)
+ src/Crypto/Lol/Reflects.hs view
@@ -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)
+ src/Crypto/Lol/Types/Complex.hs view
@@ -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+-- <https://hackage.haskell.org/package/numeric-prelude-0.4.2/docs/Number-Complex.html numeric-prelude Complex>.+newtype Complex a = Complex (C.T a) deriving (Additive.C, Ring.C, ZeroTestable.C, Field.C, Storable, Eq, Show, Arbitrary)++derivingUnbox "Complex"+  [t| forall a . (Unbox a) => Complex a -> (a, a) |]+  [| \ (Complex x) -> (C.real x, C.imag x) |]+  [| \ (r, i) -> Complex $ r C.+: i |]++-- 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
+ src/Crypto/Lol/Types/FiniteField.hs view
@@ -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+
+ src/Crypto/Lol/Types/IZipVector.hs view
@@ -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
+ src/Crypto/Lol/Types/IrreducibleChar2.hs view
@@ -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."
+ src/Crypto/Lol/Types/Numeric.hs view
@@ -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)
+ src/Crypto/Lol/Types/PrimeField.hs view
@@ -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]
+ src/Crypto/Lol/Types/ZPP.hs view
@@ -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+
+ src/Crypto/Lol/Types/ZmStar.hs view
@@ -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^* / <p>+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\'}^* \/ \<p>@+-- (specified by representatives), where the cosets in each component+-- are in bijective correspondence with the cosets of @Z_m^* \/ \<p>@ 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^* / <p> 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'
+ src/Crypto/Lol/Types/ZqBasic.hs view
@@ -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
+ test-suite/CycTests.hs view
@@ -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  +-}
+ test-suite/Main.hs view
@@ -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+    ]
+ test-suite/SHETests.hs view
@@ -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))]
+ test-suite/TensorTests.hs view
@@ -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))]
+ test-suite/TestTypes.hs view
@@ -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)
+ test-suite/ZqTests.hs view
@@ -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]