fixed

Pure Haskell large fixed-width integers.
git clone git://git.ppad.tech/fixed.git
Log | Files | Refs | README | LICENSE

Wider.hs (5051B)

      1 {-# LANGUAGE BangPatterns #-}
      2 {-# LANGUAGE MagicHash #-}
      3 {-# LANGUAGE NumericUnderscores #-}
      4 {-# LANGUAGE UnboxedTuples #-}
      5 
      6 module Wider (
      7     tests
      8   ) where
      9 
     10 import qualified Data.Choice as C
     11 import qualified Data.Word.Wider as W
     12 import Test.Tasty
     13 import qualified Test.Tasty.HUnit as H
     14 
     15 overflowing_add_no_carry :: H.Assertion
     16 overflowing_add_no_carry = do
     17   let !(r, c) = W.add_o 1 0
     18   H.assertBool mempty (W.eq_vartime r 1)
     19   H.assertBool mempty (c == 0)
     20 
     21 overflowing_add_with_carry :: H.Assertion
     22 overflowing_add_with_carry = do
     23   let !(r, c) = W.add_o (2 ^ (256 :: Word) - 1) 1
     24   H.assertBool mempty (W.eq_vartime r 0)
     25   H.assertBool mempty (c == 1)
     26 
     27 wrapping_add_no_carry :: H.Assertion
     28 wrapping_add_no_carry = do
     29   let !r = W.add 0 1
     30   H.assertBool mempty (W.eq_vartime r 1)
     31 
     32 wrapping_add_with_carry :: H.Assertion
     33 wrapping_add_with_carry = do
     34   let !r = W.add (2 ^ (256 :: Word) - 1) 1
     35   H.assertBool mempty (W.eq_vartime r 0)
     36 
     37 borrowing_sub_no_borrow :: H.Assertion
     38 borrowing_sub_no_borrow = do
     39   let !(d, b) = W.sub_b 1 1
     40   H.assertBool mempty (W.eq_vartime d 0)
     41   H.assertBool mempty (b == 0)
     42 
     43 borrowing_sub_with_borrow :: H.Assertion
     44 borrowing_sub_with_borrow = do
     45   let !(d, b) = W.sub_b 0 1
     46   H.assertBool mempty (W.eq_vartime d (2 ^ (256 :: Word) - 1))
     47   H.assertBool mempty (b == (2 ^ (64 :: Word) - 1))
     48 
     49 wrapping_sub_no_borrow :: H.Assertion
     50 wrapping_sub_no_borrow = do
     51   let !r = W.sub 1 1
     52   H.assertBool mempty (W.eq_vartime r 0)
     53 
     54 wrapping_sub_with_borrow :: H.Assertion
     55 wrapping_sub_with_borrow = do
     56   let !r = W.sub 0 1
     57   H.assertBool mempty (W.eq_vartime r (2 ^ (256 :: Word) - 1))
     58 
     59 eq :: H.Assertion
     60 eq = do
     61   let !(W.Wider a) = 0
     62       !(W.Wider b) = 2 ^ (256 :: Word) - 1
     63   H.assertBool mempty (C.decide (W.eq# a a))
     64   H.assertBool mempty (not (C.decide (W.eq# a b)))
     65   H.assertBool mempty (not (C.decide (W.eq# b a)))
     66   H.assertBool mempty (C.decide (W.eq# b b))
     67 
     68 gt :: H.Assertion
     69 gt = do
     70   let !(W.Wider a) = 0
     71       !(W.Wider b) = 1
     72       !(W.Wider c) = 2 ^ (256 :: Word) - 1
     73   H.assertBool mempty (C.decide (W.gt# b a))
     74   H.assertBool mempty (C.decide (W.gt# c a))
     75   H.assertBool mempty (C.decide (W.gt# c b))
     76 
     77   H.assertBool mempty (not (C.decide (W.gt# a a)))
     78   H.assertBool mempty (not (C.decide (W.gt# b b)))
     79   H.assertBool mempty (not (C.decide (W.gt# c c)))
     80 
     81   H.assertBool mempty (not (C.decide (W.gt# a b)))
     82   H.assertBool mempty (not (C.decide (W.gt# a c)))
     83   H.assertBool mempty (not (C.decide (W.gt# b c)))
     84 
     85 lt :: H.Assertion
     86 lt = do
     87   let !(W.Wider a) = 0
     88       !(W.Wider b) = 1
     89       !(W.Wider c) = 2 ^ (256 :: Word) - 1
     90   H.assertBool mempty (C.decide (W.lt# a b))
     91   H.assertBool mempty (C.decide (W.lt# a c))
     92   H.assertBool mempty (C.decide (W.lt# b c))
     93 
     94   H.assertBool mempty (not (C.decide (W.lt# a a)))
     95   H.assertBool mempty (not (C.decide (W.lt# b b)))
     96   H.assertBool mempty (not (C.decide (W.lt# c c)))
     97 
     98   H.assertBool mempty (not (C.decide (W.lt# b a)))
     99   H.assertBool mempty (not (C.decide (W.lt# c a)))
    100   H.assertBool mempty (not (C.decide (W.lt# c b)))
    101 
    102 cmp :: H.Assertion
    103 cmp = do
    104   let !a = 0
    105       !b = 1
    106       !c = 2 ^ (256 :: Word) - 1
    107   H.assertEqual mempty (W.cmp a b) LT
    108   H.assertEqual mempty (W.cmp a c) LT
    109   H.assertEqual mempty (W.cmp b c) LT
    110 
    111   H.assertEqual mempty (W.cmp a a) EQ
    112   H.assertEqual mempty (W.cmp b b) EQ
    113   H.assertEqual mempty (W.cmp c c) EQ
    114 
    115   H.assertEqual mempty (W.cmp b a) GT
    116   H.assertEqual mempty (W.cmp c a) GT
    117   H.assertEqual mempty (W.cmp c b) GT
    118 
    119 sqr :: H.Assertion
    120 sqr = do
    121   let !n = 2 ^ (256 :: Word) - 1
    122       !(l, h ) = W.sqr n
    123   H.assertBool mempty (W.eq_vartime l 1)
    124   H.assertBool mempty (W.eq_vartime h (n - 1))
    125 
    126 mul :: H.Assertion
    127 mul = do
    128   let !n = 2 ^ (256 :: Word) - 1
    129   H.assertBool mempty (W.eq_vartime (W.mul 0 n) 0)
    130   H.assertBool mempty (W.eq_vartime (W.mul n 0) 0)
    131   H.assertBool mempty (W.eq_vartime (W.mul n n) 1)
    132   H.assertBool mempty (W.eq_vartime (W.mul 1 n) n)
    133 
    134 sub_mod :: H.Assertion
    135 sub_mod = do
    136   let !a = 0x1a2472fde50286541d97ca6a3592dd75beb9c9646e40c511b82496cfc3926956
    137       !b = 0xd5777c45019673125ad240f83094d4252d829516fac8601ed01979ec1ec1a251
    138       !n = 0xffffffff00000000ffffffffffffffffbce6faada7179e84f3b9cac2fc632551
    139       !o = W.sub_mod a b n
    140       !e = 0x44acf6b7e36c1342c2c5897204fe09504e1e2efb1a900377dbc4e7a6a133ec56
    141   H.assertBool mempty (W.eq_vartime o e)
    142 
    143 tests :: TestTree
    144 tests = testGroup "wider tests" [
    145     H.testCase "overflowing add, no carry" overflowing_add_no_carry
    146   , H.testCase "overflowing add, carry" overflowing_add_with_carry
    147   , H.testCase "wrapping add, no carry" wrapping_add_no_carry
    148   , H.testCase "wrapping add, carry" wrapping_add_with_carry
    149   , H.testCase "borrowing sub, no borrow" borrowing_sub_no_borrow
    150   , H.testCase "borrowing sub, borrow" borrowing_sub_with_borrow
    151   , H.testCase "wrapping sub, no borrow" wrapping_sub_no_borrow
    152   , H.testCase "wrapping sub, borrow" wrapping_sub_with_borrow
    153   , H.testCase "eq" eq
    154   , H.testCase "gt" gt
    155   , H.testCase "lt" lt
    156   , H.testCase "cmp" cmp
    157   , H.testCase "sqr" sqr
    158   , H.testCase "mul" mul
    159   , H.testCase "sub_mod" sub_mod
    160   ]
    161