├── .gitignore
├── ChangeLog.md
├── LICENSE
├── README.md
├── Setup.hs
├── package.yaml
├── src
    ├── Main.hs
    ├── Phase.hs
    └── Random.hs
├── stack.yaml
└── test
    └── Spec.hs


/.gitignore:
--------------------------------------------------------------------------------
1 | .stack-work/
2 | collimation-sieve.cabal
3 | *~
4 | TAGS
5 | **/*.aux
6 | **/*.hp
7 | **/*.prof
8 | **/*.ps
9 | 


--------------------------------------------------------------------------------
/ChangeLog.md:
--------------------------------------------------------------------------------
1 | # Changelog for collimation-sieve
2 | 
3 | ## Unreleased changes
4 | 


--------------------------------------------------------------------------------
/LICENSE:
--------------------------------------------------------------------------------
 1 | Copyright Chris Peikert (c) 2019
 2 | 
 3 | All rights reserved.
 4 | 
 5 | Redistribution and use in source and binary forms, with or without
 6 | modification, are permitted provided that the following conditions are met:
 7 | 
 8 |     * Redistributions of source code must retain the above copyright
 9 |       notice, this list of conditions and the following disclaimer.
10 | 
11 |     * Redistributions in binary form must reproduce the above
12 |       copyright notice, this list of conditions and the following
13 |       disclaimer in the documentation and/or other materials provided
14 |       with the distribution.
15 | 
16 |     * Neither the name of Author name here nor the names of other
17 |       contributors may be used to endorse or promote products derived
18 |       from this software without specific prior written permission.
19 | 
20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
31 | 


--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
 1 | # Collimation Sieve
 2 | 
 3 | This Haskell code simulates and benchmarks a generalization of
 4 | Kuperberg's quantum *collimation sieve* algorithm for arbitrary cyclic
 5 | groups. We have used it to estimate the quantum (in)security of CSIDH
 6 | ("Commutative SIDH"), a proposed "post quantum" drop-in replacement
 7 | for noninteractive Diffie-Hellman-style key agreement and
 8 | encryption. See
 9 | [our paper](https://web.eecs.umich.edu/~cpeikert/pubs/csidh-sieve.pdf)
10 | for further details.
11 | 
12 | ## Building
13 | 
14 | 1. Make sure you have a recent version of
15 | [Haskell stack installed](https://docs.haskellstack.org/en/stable/install_and_upgrade/). (Warning:
16 | pre-1.0 versions of stack will crash with a parsing error.)
17 | 
18 | 2. Clone this repository and do `stack build`. Go have a hot chocolate
19 | while several packages build (just this one time).
20 | 
21 | ## Execution
22 | 
23 | * Run the sieve with
24 | 
25 |         stack run <log N> <log L> <log S> [threshold]
26 |   where `N` is the group order (use `log N=0` for the exact CSIDH-512
27 |   group order), `L` is the desired phase vector length, `S` is the
28 |   desired range size, and `threshold < 1` (optional, defaults to 0.25)
29 |   is the factor that determines whether a phase vector is too short
30 |   (i.e., any vector shorter than `threshold * L` is discarded).
31 | 
32 | * Small parameters like `log N=150`, `log L=16`, `log S=16` will cause
33 |   the sieve to finish relatively quickly (and use relatively little
34 |   memory), and will give you an idea of how it works and how to
35 |   interpret the output.
36 | 
37 | * `stack run` will use as many CPU cores as it deems appropriate,
38 |   which may not give the best performance. To specify the number of
39 |   cores and other options, use `stack exec` with RTS
40 |   options. (Caution: `stack run` silently ignores RTS options!)  For
41 |   example,
42 | 
43 |         stack exec -- collimation-sieve-exe <args> +RTS -N4 -s -RTS
44 |   runs on 4 cores, and outputs various memory and garbage-collection
45 |   statistics at the end.
46 | 
47 | * **WARNING:** a length limit in Haskell's `vector` package
48 |   effectively imposes a length limit of 2^30 on the sieve's vectors,
49 |   so the sieve will not run reliably for `log L >= 26` unless
50 |   `threshold` is increased somewhat, e.g., to `0.4` (and even this is
51 |   not a guarantee). We are working on a tweak to address this, but in
52 |   any case note that `log L >= 26` can use 100 GB of RAM or more.
53 | 


--------------------------------------------------------------------------------
/Setup.hs:
--------------------------------------------------------------------------------
1 | import Distribution.Simple
2 | main = defaultMain
3 | 


--------------------------------------------------------------------------------
/package.yaml:
--------------------------------------------------------------------------------
 1 | name:                collimation-sieve
 2 | version:             0.1.0.0
 3 | github:              "githubuser/collimation-sieve"
 4 | license:             BSD3
 5 | author:              "Chris Peikert"
 6 | maintainer:          "cpeikert@alum.mit.edu"
 7 | copyright:           "2019 Chris Peikert"
 8 | 
 9 | extra-source-files:
10 | - README.md
11 | - ChangeLog.md
12 | 
13 | # Metadata used when publishing your package
14 | # synopsis:            Collimation sieve simulator and benchmarker
15 | # category:            Web
16 | 
17 | # To avoid duplicated efforts in documentation and dealing with the
18 | # complications of embedding Haddock markup inside cabal files, it is
19 | # common to point users to the README.md file.
20 | description:         Please see the README on Bitbucket at <https://bitbucket.com/chrispeikert/collimationsieve>
21 | 
22 | dependencies:
23 | - base >= 4.7 && < 5
24 | - vector
25 | - vector-th-unbox
26 | - massiv
27 | - data-dword
28 | - mtl
29 | - multiset
30 | - random
31 | - MonadRandom
32 | - crypto-api
33 | - monadcryptorandom
34 | - DRBG
35 | - logging-effect
36 | - ansi-terminal
37 | - timeit
38 | 
39 | library:
40 |   source-dirs: src
41 | 
42 | executables:
43 |   collimation-sieve-exe:
44 |     main:                Main.hs
45 |     source-dirs:         src
46 |     ghc-options:
47 |     - -O2
48 |     - -funbox-strict-fields
49 |     - -threaded
50 |     - -rtsopts
51 |     - -with-rtsopts=-N
52 |     dependencies:
53 |     - collimation-sieve
54 | 
55 | tests:
56 |   collimation-sieve-test:
57 |     main:                Spec.hs
58 |     source-dirs:         test
59 |     ghc-options:
60 |     - -threaded
61 |     - -rtsopts
62 |     - -with-rtsopts=-N
63 |     dependencies:
64 |     - collimation-sieve
65 | 


--------------------------------------------------------------------------------
/src/Main.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE FlexibleContexts           #-}
  2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-}
  3 | {-# LANGUAGE RecordWildCards            #-}
  4 | {-# LANGUAGE ScopedTypeVariables        #-}
  5 | {-# LANGUAGE StandaloneDeriving         #-}
  6 | 
  7 | module Main (main)
  8 | where
  9 | 
 10 | import           Phase
 11 | import           Random
 12 | 
 13 | import           Control.Monad                     as CM
 14 | import qualified Control.Monad.Log                 as ML
 15 | import           Control.Monad.Random
 16 | import qualified Control.Monad.State.Strict        as MS
 17 | import           Data.Complex
 18 | import qualified Data.List                         as L
 19 | import qualified Data.Massiv.Array                 as A
 20 | import qualified Data.Massiv.Array.Manifest.Vector as AMV
 21 | import qualified Data.MultiSet                     as M
 22 | import qualified Data.Vector.Unboxed               as V
 23 | import           Numeric
 24 | import           Prelude                           as P
 25 | import           System.Console.ANSI
 26 | import           System.Environment
 27 | import           System.TimeIt
 28 | 
 29 | -- | a vector of multiplication phases; should be kept sorted
 30 | type PhaseVector = A.Array A.U A.Ix1 Phase
 31 | 
 32 | -- | the massiv computation strategy to use throughout
 33 | strat :: A.Comp
 34 | strat = A.Par
 35 | 
 36 | fromVector :: Vector Phase -> PhaseVector
 37 | fromVector vec = AMV.fromVector' strat (A.Sz1 (V.length vec)) vec
 38 | 
 39 | -- | a tuple of phase vectors to be collimated
 40 | type PVTuple = (PhaseVector, PhaseVector)
 41 | 
 42 | -- what LoggingT couldn't
 43 | deriving instance (MonadRandom m) => MonadRandom (ML.LoggingT message m)
 44 | 
 45 | -- | the base-2 logarithm
 46 | log2 :: Integral a => a -> Double
 47 | log2 = logBase (2 :: Double) . fromIntegral
 48 | 
 49 | -- | for convenience
 50 | log2rnd :: Integral a => a -> Int
 51 | log2rnd  = round . log2
 52 | 
 53 | dot :: Num a => [a] -> [a] -> a
 54 | dot [] _          = 0
 55 | dot _ []          = 0
 56 | dot (x:xs) (y:ys) = x*y + dot xs ys
 57 | 
 58 | ---------- COLLIMATION ----------
 59 | 
 60 | data CollimateInfo = SI { s     :: !Phase, lReq :: !Int,
 61 |                           lReal :: !Int,   kept :: !Bool }
 62 | 
 63 | instance Show CollimateInfo where
 64 |   show SI{..} =
 65 |     let lRatio = fromIntegral lReal / fromIntegral lReq :: Double
 66 |     in "(~2^" P.++ show (log2rnd s) P.++
 67 |        "," P.++ show lReq P.++
 68 |        "," P.++ show lReal P.++
 69 |        "," P.++ showFFloat (Just 2) lRatio
 70 |        (if not kept then " DISCARDED" else "") P.++ ")"
 71 | 
 72 | collimateInfoHandler :: MonadIO m
 73 |                      => Int     -- | number of bottom sieve layers to suppress
 74 |                      -> [Phase] -- | list of intervals sizes for sieve
 75 |                      -> CollimateInfo
 76 |                      -> m ()
 77 | collimateInfoHandler skip ss =
 78 |   let len = P.length ss in \si@SI{..} ->
 79 |     let i' = L.elemIndex s ss
 80 |     in maybe (return ())
 81 |        (\i -> when (i < len - skip) $ liftIO $ do
 82 |            setSGR [SetColor Foreground (if i < 7 then Vivid else Dull)
 83 |                    (toEnum (i `mod` 7 + 1))]
 84 |            putStrLn $ P.concat (P.replicate i "  ") P.++ show si
 85 |            setSGR [Reset]) i'
 86 | 
 87 | -- | all the mod-@n@ subset-sums of a vector. Results are not
 88 | -- necessarily sorted!
 89 | subsetSums :: Vector Phase -> Vector Phase
 90 | subsetSums v =
 91 |   V.generate (2^V.length v) (go 0 0) where
 92 |   go i acc s
 93 |     | i >= V.length v = acc
 94 |     | otherwise = go (i+1) (acc + if odd s then v V.! i else 0) (s `div` 2)
 95 | 
 96 | -- | choose a random phase multiplier from the given phase vector
 97 | randomElt :: MonadRandom m => PhaseVector -> m Phase
 98 | randomElt v =  (v A.!) <$> getRandomR (0, A.elemsCount v - 1)
 99 | 
100 | -- | the first index (in a sorted vector) of an element that is /at
101 | -- least/ @a@, or 'length v' if none exists
102 | findAtLeast :: PhaseVector -> Phase -> Int
103 | findAtLeast v a = go 0 (A.elemsCount v) where
104 |   go i j | i == j         = i
105 |          | (v A.! i) >= a = i
106 |          -- don't use i+j `div` 2, to avoid overflow on big arrays
107 |          | otherwise      = let k = i + ((j - i) `div` 2)
108 |                             in if (v A.! k) >= a then go i k else go (k+1) j
109 | 
110 | -- | collimate phase vectors
111 | collimate :: (MonadRandom m)
112 |           => Phase              -- | desired interval size S (upper bound)
113 |           -> PVTuple            -- | phase vectors to collimate
114 |           -> m PhaseVector
115 | collimate s (v1,v2) = do
116 |   b1 <- randomElt v1
117 |   b2 <- randomElt v2
118 |   let q = (b1 + b2) `div` s
119 |       qs = q*s
120 |       start i1 = (i1, findAtLeast v2 (qs - (v1 A.! i1)))
121 |       gen (i1,i2)
122 |         | i1 >= A.elemsCount v1 = Nothing
123 |         | i2 >= A.elemsCount v2 = gen $ start (i1+1)
124 |         | v < qs + s            = Just (v `mod` s, (i1, i2+1))
125 |         | otherwise             = gen $ start (i1+1)
126 |         where v = (v1 A.! i1) + (v2 A.! i2)
127 |       -- Create a Vector because massiv doesn't supported
128 |       -- unknown-length unfoldr.
129 |   return $ A.quicksort $ fromVector $ V.unfoldr gen (start 0)
130 | 
131 | ---------- SIEVE ----------
132 | 
133 | data SieveState = SS { numQueries :: !Int, maxLength    :: !Int,
134 |                        numNodes   :: !Int, numDiscarded :: !Int}
135 |   deriving (Show, Eq)
136 | 
137 | newSieveState :: SieveState
138 | newSieveState = SS 0 0 0 0
139 | 
140 | addQueries :: Int -> SieveState -> SieveState
141 | addQueries i ss@SS{..} = ss { numQueries = numQueries + i }
142 | 
143 | updateLength :: Int -> SieveState -> SieveState
144 | updateLength l ss@SS{..} = ss { maxLength = max l maxLength }
145 | 
146 | incrementNodes :: SieveState -> SieveState
147 | incrementNodes ss@SS{..} = ss { numNodes = succ numNodes }
148 | 
149 | incrementDiscarded :: SieveState -> SieveState
150 | incrementDiscarded ss@SS{..} = ss { numDiscarded = succ numDiscarded }
151 | 
152 | -- | Collimation sieve.
153 | sieve :: (MonadRandom m, ML.MonadLog CollimateInfo m,
154 |           MS.MonadState SieveState m)
155 |       => Phase   -- | group order N
156 |       -> Double  -- | threshold factor for long-enough phase vectors
157 |       -> [Phase] -- | increasing interval sizes S_i for the i'th level
158 |                  -- of the sieve; the final one should equal N
159 |       -> Int     -- | desired phase vector length L
160 |       -> m PhaseVector
161 | sieve = sieve' True where       -- don't discard final output
162 |   sieve' _ _ _ [] _ = error "sieve: empty list of interval sizes"
163 |   sieve' alwaysKeep n threshold ss@(s:ss') l
164 |     | s >= n = do
165 |         let logl = log2rnd l
166 |         v <- (A.quicksort . fromVector . V.map (`mod` n)) . subsetSums <$>
167 |           -- create a Vector because massiv doesn't support monadic replicate
168 |              V.replicateM logl (getRandomR (0,n-1))
169 |         ML.logMessage (SI s l (A.elemsCount v) True)
170 |         MS.modify'   incrementNodes
171 |         MS.modify' $ addQueries logl
172 |         MS.modify' $ updateLength (A.elemsCount v)
173 |         return v
174 |     | otherwise =
175 |         let s' = P.head ss'
176 |             z  = 1.5 * fromIntegral l * fromIntegral s' / fromIntegral s :: Double
177 |             l' = ceiling $ sqrt z
178 |         in do v1   <- sieve' False n threshold ss' l'
179 |               v2   <- sieve' False n threshold ss' $
180 |                       ceiling (z / fromIntegral (A.elemsCount v1))
181 |               v    <- collimate s (v1,v2)
182 |               let vlen = A.elemsCount v
183 |                   -- check if vector is long enough to be useful
184 |                   keep = alwaysKeep ||
185 |                          fromIntegral vlen / fromIntegral l >= threshold
186 |               ML.logMessage (SI s l vlen keep)
187 |               MS.modify' incrementNodes
188 |               if keep
189 |                 then MS.modify' (updateLength vlen) >> return v
190 |                 else MS.modify' incrementDiscarded >> sieve' False n threshold ss l
191 | 
192 | -- | histogram of (n, # multipliers appearing n times) in a phase
193 | -- vector for a (final, small) interval [S]
194 | histogram :: Int -> Vector Int -> [(Int,Int)]
195 | histogram s v =
196 |   let occurs = fmap snd $ M.toOccurList $ M.fromList $ V.toList v
197 |       num    = P.length occurs
198 |       hist   = L.sortOn fst $ M.toOccurList $ M.fromList occurs
199 |   in if s == num then hist else (0, s - num) : hist
200 | 
201 | chi :: Double -> Complex Double
202 | chi = cis . (2.0 * pi *)
203 | 
204 | square :: Num a => a -> a
205 | square x = x*x
206 | 
207 | -- | partition a phase vector into one consisting of its unique phase
208 | -- multipliers, and one containing all the leftovers.
209 | puncture :: PhaseVector -> (PhaseVector, PhaseVector)
210 | puncture v =
211 |   let v' = AMV.toVector v
212 |       u' = V.uniq v'
213 |       gen i
214 |         | i >= V.length v' = Nothing
215 |         | v' V.! (i-1) == v' V.! i = Just (v' V.! i, i+1)
216 |         | otherwise = gen $ i+1
217 |   in (fromVector u', fromVector $ V.unfoldr gen 1)
218 | 
219 | unfold :: (b -> (a,b)) -> b -> [a]
220 | unfold f b = let (a,b') = f b in a : unfold f b'
221 | 
222 | -- | probability assigned to \( w \), given by \( \theta = s/N - w/T
223 | -- \), by the \( T \)-dimensional inverse-QFT of the given punctured
224 | -- phase vector on \( [T] \).
225 | probTheta :: Int                -- | range \( [T] \) of phase vector
226 |           -> PhaseVector        -- | uniquified phase vector
227 |           -> Double             -- | \( \theta \)
228 |           -> Double
229 | probTheta t v theta =
230 |   square (magnitude $ A.sum $ A.map (chi . (* theta) . fromIntegral) v) /
231 |   (fromIntegral t * fromIntegral (A.elemsCount v))
232 | 
233 | -- | probability that the \( T \)-dimensional inverse-QFT on the given
234 | -- punctured phase vector on \( [T] \) will output some \( w \in
235 | -- \lfloor sT/N \rceil - \{ - \lfloor z/2 \rfloor, \ldots, \lfloor
236 | -- (z-1)/2 \rfloor \} \), given the (essentially uniform) shift \(
237 | -- sT/N \bmod 1 \in [-1/2,1/2) \).  Assumes that (\ z \) is positive
238 | -- and small enough not to double-count probabilities.
239 | probClosest :: Int               -- | \( T \)
240 |             -> Double            -- | \( sT/N \bmod 1 \in [-1/2,1/2) \)
241 |             -> PhaseVector       -- | uniquified phase vector
242 |             -> Int               -- | number \( z \) of closest to count
243 |             -> Double
244 | probClosest t shift v z =
245 |   let thetas = A.makeArrayR A.D strat (A.Sz1 z)
246 |                (\(A.Ix1 i) -> (shift + fromIntegral (i - z `div` 2))
247 |                               / fromIntegral t)
248 |   in A.sum $ A.map (probTheta t v) thetas
249 | 
250 | main :: IO ()
251 | main = do
252 |   args <- getArgs
253 |   let (params,rest) = splitAt 3 args
254 |       [logn :: Int, logl, logs] = read <$> params
255 |       threshold = if null rest then 0.25 :: Double else read (head rest)
256 |       n     = if logn > 0
257 |               then 2^logn
258 |                    -- from https://eprint.iacr.org/2019/498.pdf
259 |               else 3 * 37 * 1407181 * 51593604295295867744293584889 *
260 |                    31599414504681995853008278745587832204909
261 |       l     = 2^logl
262 |       s     = 2^logs
263 |       ss    = P.takeWhile (< n)
264 |               (iterate (\t -> (2 * t * fromIntegral l) `div` 3) $ fromIntegral s)
265 |               P.++ [n]
266 | 
267 |   -- print schedule of log interval sizes
268 |   putStrLn $ "log S's = " P.++ show (log2rnd <$> ss)
269 | 
270 |   -- run the sieve
271 |   (time, (v, sieveState@SS{..})) <- timeItT $
272 |     evalCryptoRandIO
273 |     (flip ML.runLoggingT (collimateInfoHandler (min 5 (P.length ss - 1)) ss)
274 |      (flip MS.runStateT newSieveState (sieve n threshold ss l)))
275 | 
276 |   -- print results
277 | 
278 |   -- parameters again, for convenience
279 |   putStrLn $ "\n[log N, log L, log S_0] = " P.++
280 |     show [logn, logl, logs]
281 | 
282 |   putStrLn $ "threshold = " P.++ showFFloat (Just 2) threshold ""
283 | 
284 |   -- log interval sizes again, for convenience
285 |   putStrLn $ "\nlog S's = " P.++ show (log2rnd <$> ss)
286 | 
287 |   putStrLn $ "\nSieve summary = " P.++ show sieveState
288 | 
289 |   -- compute number of queries according to model
290 |   let delta = fromIntegral numDiscarded / fromIntegral numNodes :: Double
291 |       depth = P.length ss - 1
292 |       l' = sqrt $ 1.5 * fromIntegral l * fromIntegral n /
293 |            fromIntegral (ss P.!! (P.length ss - 2)) :: Double
294 |       modelQueries = (2.0 / (1-delta))^depth * logBase 2 l'
295 | 
296 |   putStrLn $ "\nProbability of discarding = " P.++ showFFloat (Just 4) delta ""
297 | 
298 |   putStrLn $ (P.++) "\nNumber of queries actual/modeled = " $ (P.++)
299 |     (show numQueries)                $ (P.++) "/" $
300 |     showFFloat (Just 1) modelQueries $ (P.++) " ~= " $
301 |     showFFloat (Just 2) (fromIntegral numQueries / modelQueries) ""
302 | 
303 |   -- compute probability of obtaining a regular state
304 |   let hist = histogram s $ V.map fromIntegral $ AMV.toVector v
305 |       num  = s * fst (P.head hist)
306 |       den  = A.elemsCount v
307 |       probRegular = fromIntegral num / fromIntegral den :: Double
308 | 
309 |   putStrLn $ "\nProbability of obtaining a regular state = " P.++
310 |     show num P.++ "/" P.++ show den P.++ " ~= " P.++
311 |     showFFloat (Just 3) probRegular ""
312 | 
313 |   -- compute probabilities of getting punctured regular states, and close
314 |   shift :: Double <- getRandomR (-0.5, 0.5)
315 |   let punctureds = takeWhile ((> 2^(logs - 6)) . A.elemsCount) $
316 |                    unfold puncture v
317 |       puncturedProbs :: [Double] =
318 |         (/ fromIntegral den) . fromIntegral . A.elemsCount <$> punctureds
319 |       closest = [1,2,4,8]       -- how many of the closest w to check
320 |       closestProbs = map (<$> closest) (probClosest s shift <$> punctureds)
321 |       totalClosestProbs = dot puncturedProbs <$> L.transpose closestProbs
322 | 
323 |   putStrLn $ (P.++) "\nProbability of obtaining each punctured state (1st, 2nd, ... attempt) =\n" $
324 |     L.intercalate ", " $ mapM (showFFloat (Just 3)) puncturedProbs ""
325 | 
326 |   putStrLn $ (P.++) "\nProbability bounds for each punctured state for " $
327 |     (P.++) (show closest) $ (P.++) " closest w = \n" $
328 |     L.intercalate "\n" $ L.intercalate ", " <$>
329 |     (mapM . mapM) (showFFloat (Just 3)) closestProbs ""
330 | 
331 |   putStrLn $ (P.++) "\nTotal probability bounds for " $
332 |     (P.++) (show closest) $ (P.++) " closest w = \n" $
333 |     L.intercalate ", " $ mapM (showFFloat (Just 3)) totalClosestProbs ""
334 | 
335 |   putStrLn $ (P.++) "\nLaTeX table row:\n" $
336 |     showFFloat (Just 1) (log2 n)                          $ (P.++) " & " $
337 |     showFFloat (Just 1) (log2 numQueries)                 $ (P.++) " & " $
338 |     showFFloat (Just 1) (logBase 2 modelQueries)          $ (P.++) " & " $
339 |     showFFloat (Just 1) (log2 maxLength)                  $ (P.++) " & " $
340 |     (P.++) (show logl)                                    $ (P.++) " & " $
341 |     (P.++) (show logs)                                    $ (P.++) " & " $
342 |     showFFloat (Just 0) (probRegular * 100)               $ (P.++) " & " $
343 |     showFFloat (Just 1) (fromIntegral logs * probRegular) $ (P.++) " & " $
344 |     showFFloat (Just 2) threshold                         $ (P.++) " & " $
345 |     showFFloat (Just 1) (delta * 100)                     $ (P.++) " & " $
346 |     (P.++) (show depth)                                   $ (P.++) " & " $
347 |     showFFloat (Just 1) (time / 3600) " \\\\"
348 | 
349 | 


--------------------------------------------------------------------------------
/src/Phase.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE MultiParamTypeClasses #-}
 2 | {-# LANGUAGE TemplateHaskell       #-}
 3 | {-# LANGUAGE TypeFamilies          #-}
 4 | 
 5 | module Phase where
 6 | 
 7 | import           Data.DoubleWord
 8 | import           Data.DoubleWord.TH
 9 | import           Data.Int
10 | import           Data.Vector.Unboxed.Deriving
11 | import           Data.Word
12 | import           System.Random
13 | 
14 | mkUnpackedDoubleWord "Word320" ''Word64 "Int320" ''Int64 ''Word256 []
15 | 
16 | instance Random Word128 where
17 |   {-# INLINABLE random #-}
18 |   {-# INLINABLE randomR #-}
19 | 
20 |   random g = let (h,g')  = random g
21 |                  (l,g'') = random g'
22 |              in (Word128 h l, g'')
23 | 
24 |   randomR (lo,hi) g
25 |     | lo > hi   = randomR (hi,lo) g
26 |     | otherwise = let w@(Word128 h l) = hi - lo
27 |                   in if h == 0
28 |                      then let (r , g')  = randomR (0,l) g
29 |                           in (lo + Word128 0 r, g')
30 |                      else let (rh, g')  = randomR (0,h) g
31 |                               (rl, g'') = random g'
32 |                               r = Word128 rh rl
33 |                           in if r > w then randomR (lo,hi) g'' else (lo+r, g'')
34 | 
35 | instance Random Word256 where
36 |   {-# INLINABLE random #-}
37 |   {-# INLINABLE randomR #-}
38 | 
39 |   random g = let (h,g')  = random g
40 |                  (l,g'') = random g'
41 |              in (Word256 h l, g'')
42 | 
43 |   randomR (lo,hi) g
44 |     | lo > hi   = randomR (hi,lo) g
45 |     | otherwise = let w@(Word256 h l) = hi - lo
46 |                   in if h == 0
47 |                      then let (r , g')  = randomR (0,l) g
48 |                           in (lo + Word256 0 r, g')
49 |                      else let (rh, g')  = randomR (0,h) g
50 |                               (rl, g'') = random g'
51 |                               r = Word256 rh rl
52 |                           in if r > w then randomR (lo,hi) g'' else (lo+r, g'')
53 | 
54 | instance Random Word320 where
55 |   {-# INLINABLE random #-}
56 |   {-# INLINABLE randomR #-}
57 | 
58 |   random g = let (h,g')  = random g
59 |                  (l,g'') = random g'
60 |              in (Word320 h l, g'')
61 | 
62 |   randomR (lo,hi) g
63 |     | lo > hi   = randomR (hi,lo) g
64 |     | otherwise = let w@(Word320 h l) = hi - lo
65 |                   in if h == 0
66 |                      then let (r , g')  = randomR (0,l) g
67 |                           in (lo + Word320 0 r, g')
68 |                      else let (rh, g')  = randomR (0,h) g
69 |                               (rl, g'') = random g'
70 |                               r = Word320 rh rl
71 |                           in if r > w then randomR (lo,hi) g'' else (lo+r, g'')
72 | 
73 | derivingUnbox "Word128"
74 |     [t| Word128 -> (Word64, Word64) |]
75 |     [| \ (Word128 h l) -> (h, l) |]
76 |     [| uncurry Word128 |]
77 | 
78 | derivingUnbox "Word256"
79 |     [t| Word256 -> (Word128, Word128) |]
80 |     [| \ (Word256 h l) -> (h, l) |]
81 |     [| uncurry Word256 |]
82 | 
83 | derivingUnbox "Word320"
84 |     [t| Word320 -> (Word64, Word256) |]
85 |     [| \ (Word320 h l) -> (h, l) |]
86 |     [| uncurry Word320 |]
87 | 
88 | type Phase = Word320
89 | 


--------------------------------------------------------------------------------
/src/Random.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 2 | 
 3 | module Random (CryptoRand, evalCryptoRandIO) where
 4 | 
 5 | import           Control.Arrow
 6 | import           Control.Monad.CryptoRandom
 7 | import           Control.Monad.IO.Class
 8 | import           Control.Monad.Random       (RandT, evalRandT)
 9 | import           Crypto.Random
10 | import           Crypto.Random.DRBG
11 | import           System.Random
12 | 
13 | -- | wrapper
14 | newtype CryptoRand g = CryptoRand g deriving (CryptoRandomGen)
15 | 
16 | type DefaultDRBG = CryptoRand HashDRBG
17 | 
18 | -- | Evaluate a 'RandT' computation using the default cryptographic
19 | -- generator, seeded by system entropy.  (Note that the updated
20 | -- generator is not returned.)
21 | evalCryptoRandIO :: MonadIO io => RandT DefaultDRBG io a -> io a
22 | evalCryptoRandIO x = do
23 |   gen <- liftIO newGenIO -- uses system entropy
24 |   evalRandT x gen
25 | 
26 | -- | Turns a 'CryptoRandomGen' @g@ into a standard 'RandomGen'.
27 | instance (CryptoRandomGen g) => RandomGen (CryptoRand g) where
28 |   -- use 'CRandom' instance for 'Int'
29 |   next (CryptoRand g) = either (error . show) (second CryptoRand) $ crandom g
30 | 
31 |   split (CryptoRand g) =
32 |     either (error . show) (CryptoRand *** CryptoRand) $ splitGen g
33 | 
34 |   {-# INLINABLE next #-}
35 |   {-# INLINABLE split #-}
36 | 


--------------------------------------------------------------------------------
/stack.yaml:
--------------------------------------------------------------------------------
 1 | # This file was automatically generated by 'stack init'
 2 | #
 3 | # Some commonly used options have been documented as comments in this file.
 4 | # For advanced use and comprehensive documentation of the format, please see:
 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/
 6 | 
 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version.
 8 | # A snapshot resolver dictates the compiler version and the set of packages
 9 | # to be used for project dependencies. For example:
10 | #
11 | # resolver: lts-3.5
12 | # resolver: nightly-2015-09-21
13 | # resolver: ghc-7.10.2
14 | #
15 | # The location of a snapshot can be provided as a file or url. Stack assumes
16 | # a snapshot provided as a file might change, whereas a url resource does not.
17 | #
18 | # resolver: ./custom-snapshot.yaml
19 | # resolver: https://example.com/snapshots/2018-01-01.yaml
20 | resolver: lts-13.21
21 | 
22 | # User packages to be built.
23 | # Various formats can be used as shown in the example below.
24 | #
25 | # packages:
26 | # - some-directory
27 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz
28 | # - location:
29 | #    git: https://github.com/commercialhaskell/stack.git
30 | #    commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
31 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a
32 | #  subdirs:
33 | #  - auto-update
34 | #  - wai
35 | packages:
36 | - .
37 | 
38 | # Dependency packages to be pulled from upstream that are not in the resolver
39 | # using the same syntax as the packages field.
40 | # (e.g., acme-missiles-0.3)
41 | 
42 | extra-deps:
43 | - monadcryptorandom-0.7.2.1
44 | - DRBG-0.5.5
45 | - massiv-0.3.4.0   # until it gets into LTS
46 | - scheduler-1.4.0  # needed by massiv
47 | 
48 | # Override default flag values for local packages and extra-deps
49 | # flags: {}
50 | 
51 | # Extra package databases containing global packages
52 | # extra-package-dbs: []
53 | 
54 | # Control whether we use the GHC we find on the path
55 | # system-ghc: true
56 | #
57 | # Require a specific version of stack, using version ranges
58 | # require-stack-version: -any # Default
59 | # require-stack-version: ">=1.9"
60 | #
61 | # Override the architecture used by stack, especially useful on Windows
62 | # arch: i386
63 | # arch: x86_64
64 | #
65 | # Extra directories used by stack for building
66 | # extra-include-dirs: [/path/to/dir]
67 | # extra-lib-dirs: [/path/to/dir]
68 | #
69 | # Allow a newer minor version of GHC than the snapshot specifies
70 | # compiler-check: newer-minor
71 | 


--------------------------------------------------------------------------------
/test/Spec.hs:
--------------------------------------------------------------------------------
1 | main :: IO ()
2 | main = putStrLn "Test suite not yet implemented"
3 | 


--------------------------------------------------------------------------------