module Bitcoin.Crypto.EC.Projective where
import Data.Bits
import Bitcoin.Crypto.FiniteField.Fast.Fp hiding ( secp256k1_p )
import Bitcoin.Crypto.FiniteField.Naive.Fn hiding ( secp256k1_n )
import Bitcoin.Crypto.EC.Curve
import Data.Word
import Foreign
import System.IO.Unsafe as Unsafe
import Bitcoin.Crypto.Word256
data ECProj = ECProj !Fp !Fp !Fp deriving (Eq,Show)
toECProj :: ECPoint -> ECProj
toECProj ep = case ep of
ECPoint x y -> ECProj x (y+y) 1
ECInfinity -> ECProj 1 2 0
fromECProj :: ECProj -> ECPoint
fromECProj (ECProj x@(Fp xrep) y@(Fp yrep) z@(Fp zrep)) =
if zrep /= 0
then ECPoint (x/z2) (y/(z3+z3))
else if 2*xrep == yrep
then ECInfinity
else error "fromECProj: infinity not on the curve"
where
z2 = z*z
z3 = z*z2
foreign import ccall unsafe "c_ec.c c_addECP" c_addECP_ :: Ptr Word32 -> Ptr Word32 -> Ptr Word32
-> Ptr Word32 -> Ptr Word32 -> Ptr Word32
-> Ptr Word32 -> Ptr Word32 -> Ptr Word32 -> IO ()
foreign import ccall unsafe "c_ec.c c_dblECP" c_dblECP_ :: Ptr Word32 -> Ptr Word32 -> Ptr Word32
-> Ptr Word32 -> Ptr Word32 -> Ptr Word32 -> IO ()
foreign import ccall unsafe "c_ec.c c_mulECP" c_mulECP_ :: Ptr Word32 -> Ptr Word32 -> Ptr Word32
-> Ptr Word32
-> Ptr Word32 -> Ptr Word32 -> Ptr Word32 -> IO ()
withECProj :: ECProj -> (Ptr Word32 -> Ptr Word32 -> Ptr Word32 -> IO a) -> IO a
withECProj (ECProj (Fp x) (Fp y) (Fp z)) action =
withWord256 x $ \px -> withWord256 y $ \py -> withWord256 z $ \pz -> action px py pz
withNewECProj :: (Ptr Word32 -> Ptr Word32 -> Ptr Word32 -> IO ()) -> IO ECProj
withNewECProj action = do
x <- newWord256
y <- newWord256
z <- newWord256
withWord256 x $ \px -> withWord256 y $ \py -> withWord256 z $ \pz -> action px py pz
return (ECProj (Fp x) (Fp y) (Fp z))
c_dblECP :: ECProj -> ECProj
c_dblECP ep = Unsafe.unsafePerformIO $ do
withECProj ep $ \xp yp zp -> withNewECProj $ \xr yr zr -> c_dblECP_ xp yp zp xr yr zr
c_addECP :: ECProj -> ECProj -> ECProj
c_addECP ep eq = Unsafe.unsafePerformIO $ do
withECProj ep $ \xp yp zp -> withECProj eq $ \xq yq zq -> withNewECProj $ \xr yr zr -> c_addECP_ xp yp zp xq yq zq xr yr zr
c_mulECP :: ECProj -> Integer -> ECProj
c_mulECP ep m = Unsafe.unsafePerformIO $ do
w256 <- makeWord256 (mod m secp256k1_n)
withECProj ep $ \xp yp zp -> withWord256 w256 $ \pw256 -> withNewECProj $ \xr yr zr -> c_mulECP_ xp yp zp pw256 xr yr zr
dblECP :: ECProj -> ECProj
dblECP = c_dblECP
addECP :: ECProj -> ECProj -> ECProj
addECP = c_addECP
mulECP :: ECProj -> Integer -> ECProj
mulECP = c_mulECP
instance Num ECProj where
(+) = addECP
() = subECP
negate = invECP
(*) = error "ECProj/Num: (*) doesn't makes sense"
abs = error "ECProj/Num: `abs' doesn't makes sense"
signum = error "ECProj/Num: `signum' doesn't makes sense"
fromInteger n = case n of
0 -> ecpInfinity
_ -> error "ECProj/Num: `fromInteger' doesn't makes sense, apart from 0"
infix 4 =~=
(=~=) :: ECProj -> ECProj -> Bool
(=~=) (ECProj xp yp zp) (ECProj xq yq zq) = ( zp==0 && zq==0 && z_zero) || z_nonzero
where
zp2 = zp*zp
zq2 = zq*zq
zp3 = zp*zp2
zq3 = zq*zq2
z_zero = ( yp == 0 && yq == 0 ) || ( yq2*xp3 == yp2*xq3 )
z_nonzero = ( xp*zq2 == xq*zp2 ) && ( yp*zq3 == yq*zp3 )
xp2 = xp*xp
xq2 = xq*xq
xp3 = xp2*xp
xq3 = xq2*xq
yp2 = yp*xp
yq2 = yq*xq
ecpInfinity :: ECProj
ecpInfinity = ECProj 1 2 0
isECPInfinity :: ECProj -> Bool
isECPInfinity (ECProj x@(Fp xrep) y@(Fp yrep) z@(Fp zrep)) = (zrep==0) && (xrep/=0) && (yrep/=0) && (y2==4*x3) where
y2 = y*y
x2 = x*x
x3 = x2*x
isECPOnCurve :: ECProj -> Bool
isECPOnCurve (ECProj x y z) = (y2 == 4 * (x3 + 7*z6)) where
y2 = y*y
x2 = x*x
x3 = x2*x
z2 = z*z
z3 = z2*z
z6 = z3*z3
secp256k1_G_proj :: ECProj
secp256k1_G_proj = ECProj (fromInteger secp256k1_Gx) (fromInteger secp256k1_Gy * 2) 1
hs_addECP :: ECProj -> ECProj -> ECProj
hs_addECP ep@(ECProj xp yp zp) eq@(ECProj xq yq zq)
| zp == 0 = if isECPInfinity ep then eq else error "addECP: eq not on the curve"
| zq == 0 = if isECPInfinity eq then ep else error "addECP: ep not on the curve"
| b == 0 && d == 0 = dblECP ep
| otherwise = ECProj xr yr zr
where
zp2 = zp*zp
zq2 = zq*zq
zp3 = zp*zp2
zq3 = zq*zq2
xpzq2 = xp*zq2
xqzp2 = xq*zp2
ypzq3 = yp*zq3
yqzp3 = yq*zp3
a = xpzq2 + xqzp2
b = xpzq2 xqzp2
c = ypzq3 + yqzp3
d = ypzq3 yqzp3
e = b+b
e2 = e*e
ae2 = a*e2
xr = d*dae2
yr = d*(ae2(xr+xr)) e2*b*c
zr = e*zp*zq
hs_dblECP :: ECProj -> ECProj
hs_dblECP (ECProj xp yp zp) = ECProj xr yr zr
where
yp2 = yp*yp
xp2 = xp*xp
a = xp2+xp2+xp2
xpyp2 = xp*yp2
b = xpyp2 + xpyp2
c = yp2*yp2
xr = a*a b
yr = a*(b(xr+xr)) c
zr = yp*zp
invECP :: ECProj -> ECProj
invECP (ECProj x y z) = ECProj x (negate y) z
subECP :: ECProj -> ECProj -> ECProj
subECP a b = addECP a (invECP b)
hs_mulECP :: ECProj -> Integer -> ECProj
hs_mulECP !base !exp = go ecpInfinity base exp where
go !acc _ 0 = acc
go !acc !b !e = if (e .&. 1 > 0)
then go (hs_addECP acc b) (hs_dblECP b) (shiftR e 1)
else go acc (hs_dblECP b) (shiftR e 1)