noiioiu/nimbers - Change MCBWM3FBZPTBMBJM4QISAX45C2D75QGHWXPLAYMN3EXJJ2CV4ASAC

Rewrite some functions to avoid recomputing log^2.

Add Artin-Schreier root function.

Add tests.

Created by noiioiu on April 25, 2024

MCBWM3FBZPTBMBJM4QISAX45C2D75QGHWXPLAYMN3EXJJ2CV4ASAC

Dependencies

In channels

main

Change contents

Insertion in test/Main.hs at line 10 [7.22]
[5.34]
[6.2]
```
import Data.Bits
```

Insertion in test/Main.hs at line 18 [7.22]

[8.123]

[7.256]


prop_floorLog :: Positive Int -> Bool
prop_floorLog Positive {getPositive = n} =
  floorLog n == floor @Double @Int (logBase 2 $ fromIntegral n)

Replacement in test/Main.hs at line 27 [7.22]
B:BD[9.112] → [9.112:157]
```
prop_add_id a = (a + 0) == a && (0 + a == a)
```
[9.112]
[7.306]
```
prop_add_id a = a + 0 == a && 0 + a == a
```

Replacement in test/Main.hs at line 30 [7.22]

B:BD[9.189] → [9.189:235]

prop_mult_id a = (a * 1) == a && (1 * a == a)

[9.189]

[9.235]

prop_mult_id a = a * 1 == a && 1 * a == a

Replacement in test/Main.hs at line 35 [7.22]

B:BD[7.403] → [7.403:456]

B:BD[7.456] → [5.135:185]

prop_assoc_mul :: Nimber -> Nimber -> Nimber -> Bool
prop_assoc_mul a b c = a * (b * c) == (a * b) * c

[7.403]

[7.498]

prop_assoc_mult :: Nimber -> Nimber -> Nimber -> Bool
prop_assoc_mult a b c = a * (b * c) == (a * b) * c

Replacement in test/Main.hs at line 41 [7.22]

B:BD[5.237] → [5.237:302]

prop_recip :: Nimber -> Bool
prop_recip a = a == 0 || a / a == 1

[5.237]

[7.590]

prop_recip :: NonZero Nimber -> Bool
prop_recip NonZero {getNonZero = a} = a / a == 1

Insertion in test/Main.hs at line 59 [7.22]

[10.68]

[11.46]

prop_as :: Nimber -> Bool
prop_as a = let x = artinSchreierRoot a in sqr x + x == a && not (x `testBit` 0)

Replacement in test/Main.hs at line 75 [7.22]

B:BD[11.617] → [11.617:688]

nimberMul :: Int -> Int -> Int
nimberMul = (!!) . (nimberProdTable !!)

[11.617]

[8.124]

nimberMult :: Int -> Int -> Int
nimberMult = (!!) . (nimberProdTable !!)

Replacement in test/Main.hs at line 79 [7.22]

B:BD[11.716] → [11.716:779]

nimberProdTable = fmap mul <$> [(i,) <$> [0 ..] | i <- [0 ..]]

[11.716]

[11.779]

nimberProdTable = [mult i <$> [0 ..] | i <- [0 ..]]

Replacement in test/Main.hs at line 81 [7.22]

B:BD[11.787] → [11.787:965]

    mul (a, b) = mex $ [(nimberProdTable !! a' !! b) `nimberAdd` (nimberProdTable !! a !! b') `nimberAdd` (nimberProdTable !! a' !! b') | a' <- [0 .. a - 1], b' <- [0 .. b - 1]]

[11.787]

[12.2]

    mult a b = mex $ [(nimberProdTable !! a' !! b) `nimberAdd` (nimberProdTable !! a !! b') `nimberAdd` (nimberProdTable !! a' !! b') | a' <- [0 .. a - 1], b' <- [0 .. b - 1]]

Replacement in test/Main.hs at line 83 [7.22]

B:BD[12.3] → [13.224:420]

-- prop_def_add :: Small Int -> Small Int -> Bool
-- prop_def_add Small {getSmall = a} Small {getSmall = b} = abs a `nimberAdd` abs b == fromIntegral (getNimber $ fromIntegral a + fromIntegral b)

[12.3]

[12.197]

prop_def_add :: Bool
prop_def_add = and $ do
  i <- [0 .. 15]
  j <- [0 .. 15]
  pure $ fromIntegral @Int @Nimber (nimberAdd i j) == fromIntegral i + fromIntegral j

Replacement in test/Main.hs at line 89 [7.22]

B:BD[12.198] → [13.421:617]

-- prop_def_mul :: Small Int -> Small Int -> Bool
-- prop_def_mul Small {getSmall = a} Small {getSmall = b} = abs a `nimberMul` abs b == fromIntegral (getNimber $ fromIntegral a * fromIntegral b)

[12.198]

[11.965]

prop_def_mult :: Bool
prop_def_mult = and $ do
  i <- [0 .. 15]
  j <- [0 .. 15]
  pure $ fromIntegral @Int @Nimber (nimberMult i j) == fromIntegral i * fromIntegral j

Replacement in src/Data/Nimber.hs at line 46 [7.880]

B:BD[14.211] → [14.211:430]

B:BD[14.430] → [2.30:125]

        semiD = bit (bit m - 1) -- semimultiple of D
        a1 = a `shiftR` bit m -- a = a1D+a2
        a2 = a .^. (a1 `shiftL` bit m)
        b1 = b `shiftR` bit m -- b = b1D+b2
        b2 = b .^. (b1 `shiftL` bit m)
        c = a2 * b2
     in (((a1 + a2) * (b1 + b2) - c) `shiftL` bit m) + a1 * b1 * semiD + c

[14.211]

[7.3728]

        mult' _ 0 _ = 0
        mult' _ _ 0 = 0
        mult' _ 1 t = t
        mult' _ s 1 = s
        mult' k s t =
          let semiD = bit (bit k - 1) -- semimultiple of D
              s1 = s `shiftR` bit k -- a = a1D+a2
              s2 = s .^. (s1 `shiftL` bit k)
              t1 = t `shiftR` bit k -- b = b1D+b2
              t2 = t .^. (t1 `shiftL` bit k)
              c = mult' (k-1) s2 t2
           in ((mult' (k-1) (s1 + s2) (t1 + t2) - c) `shiftL` bit k) + mult' (k-1) (mult' (k-1) s1 t1) semiD + c
     in mult' m a b

Replacement in src/Data/Nimber.hs at line 69 [7.880]

B:BD[13.959] → [13.959:1164]

      a = n `shiftR` bit m -- n = aD+b
      aD = a `shiftL` bit m
      b = n .^. aD
      semiD = bit (bit m - 1) -- semimultiple of D
      sqra = sqr a
   in sqra `shiftL` bit m + sqra * semiD + sqr b

[13.959]

[4.388]

      sqr' _ 0 = 0
      sqr' _ 1 = 1
      sqr' k l =
        let a = l `shiftR` bit k -- n = aD+b
            aD = a `shiftL` bit k
            b = l .^. aD
            semiD = bit (bit k - 1) -- semimultiple of D
            sqra = sqr' (k - 1) a
         in sqra `shiftL` bit k + sqra * semiD + sqr' (k - 1) b
   in sqr' m n

Replacement in src/Data/Nimber.hs at line 81 [7.880]

B:BD[4.467] → [4.467:786]

pow :: (Integral a) => Nimber -> a -> Nimber
_ `pow` 0 = 1
a `pow` n
  | n < 0 = recip a `pow` negate n
  | otherwise = if even n then sqr a `pow` quot n 2 else powAcc (sqr a) (quot n 2) a
  where
    powAcc _ 0 x = x
    powAcc b m x = if even m then powAcc (sqr b) (quot m 2) x else powAcc (sqr b) (quot m 2) (b * x)

[4.467]

[15.5]

pow :: (Integral a, Bits a) => Nimber -> a -> Nimber
x `pow` n
  | n < 0 = recip x `pow` negate n
  | otherwise = product . fmap snd . filter (testBit n . fst) . zip [0 ..] . take (1 + floorLog (n + 1)) $ iterate sqr x

Replacement in src/Data/Nimber.hs at line 93 [7.880]

B:BD[3.458] → [3.458:656]

        a = n `shiftR` bit m -- n = aD+b
        aD = a `shiftL` bit m
        b = n .^. aD
        semiD = bit (bit m - 1) -- semimultiple of D
     in (aD + a + b) / (semiD * sqr a + b * (a + b))

[3.458]

[3.656]

        recip' _ 1 = 1
        recip' k l =
          let a = l `shiftR` bit k -- n = aD+b
              aD = a `shiftL` bit k
              b = l .^. aD
              semiD = bit (bit k - 1) -- semimultiple of D
           in (aD + a + b) * recip' (k - 1) (semiD * sqr a + b * (a + b))
     in recip' m n

Replacement in src/Data/Nimber.hs at line 108 [7.880]

B:BD[15.311] → [15.311:456]

B:BD[15.456] → [13.1165:1247]

        a = n `shiftR` bit m -- n = aD+b
        aD = a `shiftL` bit m
        b = n .^. aD
        semiD = bit (bit m - 1) -- semimultiple of D
        sqrta = sqrt a
     in sqrta `shiftL` bit m + sqrta * sqrt semiD + sqrt b

[15.311]

[15.517]

        sqrt' _ 0 = 0
        sqrt' _ 1 = 1
        sqrt' k l =
          let a = l `shiftR` bit k -- n = aD+b
              aD = a `shiftL` bit k
              b = l .^. aD
              semiD = bit (bit k - 1) -- semimultiple of D
              sqrta = sqrt' (k - 1) a
           in sqrta `shiftL` bit k + sqrta * sqrt semiD + sqrt' (k - 1) b
     in sqrt' m n

Insertion in src/Data/Nimber.hs at line 133 [7.880]

[15.1401]


evens :: [a] -> [a]
evens (x : _ : xs) = x : evens xs
evens xs = xs
-- | @'artinSchreierRoot' n@ is the smallest solution to the equation \(x^2 - x = n\).
--   The algorithm is due to Chin-Long Chen: <https://ieeexplore.ieee.org/document/1056557>.
--   In fields of characteristic 2, the standard quadratic formula does not work, but any quadratic equation can be solved using square roots and Artin-Schreier roots.
--
--   This function is __much__ slower than @'sqrt'@.
artinSchreierRoot :: Nimber -> Nimber
artinSchreierRoot 0 = 0
artinSchreierRoot 1 = 2
artinSchreierRoot 2 = 4
artinSchreierRoot 3 = 6
artinSchreierRoot n =
  let m = 1 + floorLog @Int (floorLog n) -- 2^2^m is the order of the smallest field containing n
      m' = if n < bit (bit m - 1) then m else m + 1 -- 2^2^m' is the order of the smallest field containing the Artin-Schreier root of n
      squares = iterate sqr n
      quarts = evens squares
      t4k = sum $ take (bit (m' - 1)) quarts -- trace of the Artin-Screier root of n
   in if t4k == 1
        then
          let s = sum $ do
                j <- [1 .. bit (m' - 2) - 1]
                i <- [j .. bit (m' - 2) - 1]
                pure $ (squares !! (shiftL i 1 - 1 .^. bit (m' - 1))) * (squares !! (shiftL j 1 - 2))
           in flip clearBit 0 $
                s
                  + sqr s
                  + (squares !! (bit m' - 1))
                    * (1 + sum (take (bit (m' - 2)) $ drop (bit (m' - 2)) quarts))
        else
          let y = bit $ bit m' - 1
              z = artinSchreierRoot $ sqr y + y + n
           in y + z