module Data.Pairing.Ate
( module Data.Pairing
, millerAlgorithmBLS12
, finalExponentiationBLS12
, millerAlgorithmBN
, finalExponentiationBN
) where
import Protolude
import Data.Curve.Weierstrass (Curve(..), Point(..))
import Data.Field.Galois as F
import Data.Pairing
millerAlgorithmBLS12 :: ECPairing e q r u v w
=> [Int8] -> G1 e -> G2 e -> GT e
millerAlgorithmBLS12 (x:xs) p q = snd $
millerLoop p q xs (if x > 0 then q else inv q, mempty)
millerAlgorithmBLS12 _ _ _ = mempty
{-# INLINABLE millerAlgorithmBLS12 #-}
millerAlgorithmBN :: ECPairing e q r u v w
=> Extension u (Prime q) -> [Int8] -> G1 e -> G2 e -> GT e
millerAlgorithmBN xi (x:xs) p q = finalStepBN xi p q $
millerLoop p q xs (if x > 0 then q else inv q, mempty)
millerAlgorithmBN _ _ _ _ = mempty
{-# INLINABLE millerAlgorithmBN #-}
millerLoop :: ECPairing e q r u v w
=> G1 e -> G2 e -> [Int8] -> (G2 e, GT e) -> (G2 e, GT e)
millerLoop p q = millerLoop'
where
millerLoop' [] tf = tf
millerLoop' (x:xs) tf = case doublingStep p tf of
tf2
| x == 0 -> millerLoop' xs tf2
| x == 1 -> millerLoop' xs $ additionStep p q tf2
| otherwise -> millerLoop' xs $ additionStep p (inv q) tf2
{-# INLINABLE millerLoop #-}
doublingStep :: ECPairing e q r u v w
=> G1 e -> (G2 e, GT e) -> (G2 e, GT e)
doublingStep p (t, f) = (<>) f . (<>) f <$> lineFunction p t t
{-# INLINABLE doublingStep #-}
additionStep :: ECPairing e q r u v w
=> G1 e -> G2 e -> (G2 e, GT e) -> (G2 e, GT e)
additionStep p q (t, f) = (<>) f <$> lineFunction p q t
{-# INLINABLE additionStep #-}
finalStepBN :: ECPairing e q r u v w
=> Extension u (Prime q) -> G1 e -> G2 e -> (G2 e, GT e) -> GT e
finalStepBN xi p q (t, f) = case lineFunction p t q1 of
(t', f') -> case lineFunction p t' q2 of
(_, f'') -> f <> f' <> f''
where
q1 = frobTwisted xi q
q2 = inv $ frobTwisted xi q1
{-# INLINABLE finalStepBN #-}
finalExponentiationBLS12 :: ECPairing e q r u v w
=> Integer -> GT e -> GT e
finalExponentiationBLS12 u = (<$>) $ hardPart . easyPart
where
easyPart = p2 . p6
where
p6 = (*) <$> conj <*> recip
p2 = (*) <$> identity <*> F.frob . F.frob
hardPart f = p4
where
f2 = f * f
y3 = powUnitary (powUnitary f u * conj f2) u * f
y2 = powUnitary y3 u
y1 = powUnitary y2 u * conj y3
y0 = powUnitary y1 u * f2 * f
p4 = y0 * F.frob (y1 * F.frob (y2 * (F.frob y3)))
{-# INLINABLE finalExponentiationBLS12 #-}
finalExponentiationBN :: ECPairing e q r u v w
=> Integer -> GT e -> GT e
finalExponentiationBN u = (<$>) $ hardPart . easyPart
where
easyPart = p2 . p6
where
p6 = (*) <$> conj <*> recip
p2 = (*) <$> identity <*> F.frob . F.frob
hardPart f = p4
where
fu = powUnitary f u
fu2 = powUnitary fu u
fu3 = powUnitary fu2 u
fpu = F.frob fu2
y0 = F.frob (f * F.frob (f * F.frob f))
y1 = conj f
y2 = F.frob fpu
y3 = conj $ F.frob fu
y4 = conj $ fu * fpu
y5 = conj fu2
y6 = conj $ fu3 * F.frob fu3
p4 = p4' * y0 * join (*) (p4' * y1)
where
p4' = join (*) $ p4'' * y2 * join (*) (p4'' * y3 * y5)
p4'' = y4 * y5 * join (*) y6
{-# INLINABLE finalExponentiationBN #-}
lineFunction :: ECPairing e q r u v w
=> G1 e
-> G2 e
-> G2 e
-> (G2 e, GT e)
lineFunction (A x y) (A x1 y1) (A x2 y2)
| x1 /= x2 = (A x3 y3 , toU' [embed $ -y, [x *^ l , y1 - l * x1]])
| y1 + y2 == 0 = (O , toU' [embed x, embed $ -x1 ])
| otherwise = (A x3' y3', toU' [embed $ -y, [x *^ l', y1 - l' * x1]])
where
l = (y2 - y1) / (x2 - x1)
x3 = l * l - x1 - x2
y3 = l * (x1 - x3) - y1
x12 = x1 * x1
l' = (x12 + x12 + x12) / (y1 + y1)
x3' = l' * l' - x1 - x2
y3' = l' * (x1 - x3') - y1
lineFunction _ _ _ = (O, mempty)
{-# INLINABLE lineFunction #-}
frobTwisted :: forall e q r u v w . ECPairing e q r u v w
=> Extension u (Prime q)
-> G2 e
-> G2 e
frobTwisted xi (A x y) = A (F.frob x * pow xi tx) (F.frob y * pow xi ty)
where
tx = quot (F.char (witness :: Prime q) - 1) 3
ty = shiftR (F.char (witness :: Prime q)) 1
frobTwisted _ _ = O
powUnitary :: IrreducibleMonic p k
=> Extension p k
-> Integer
-> Extension p k
powUnitary x n
| n < 0 = pow (conj x) (negate n)
| otherwise = pow x n
{-# INLINE powUnitary #-}